diff --git a/GNUmakefile b/GNUmakefile index 89f7ae1446..38e3b0d736 100755 --- a/GNUmakefile +++ b/GNUmakefile @@ -96,7 +96,6 @@ help: @echo "macosx-ppc" @echo "solaris-x86-32" @echo "solaris-x86-64" - @echo "wince-arm" @echo "winnt-x86-32" @echo "winnt-x86-64" @echo "" @@ -162,9 +161,6 @@ winnt-x86-64: $(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64 $(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64 -wince-arm: - $(MAKE) $(ALL) CONFIG=vm/Config.windows.ce.arm - ifdef CONFIG macosx.app: factor @@ -219,7 +215,4 @@ clean: rm -f libfactor-ffi-test.* rm -f Factor.app/Contents/Frameworks/libfactor.dylib -tags: - etags vm/*.{cpp,hpp,mm,S,c} - .PHONY: factor factor-lib factor-console factor-ffi-test tags clean macosx.app diff --git a/Nmakefile b/Nmakefile index 5297e49171..c6f24da08a 100755 --- a/Nmakefile +++ b/Nmakefile @@ -14,18 +14,17 @@ CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG !IF "$(PLATFORM)" == "x86-32" LINK_FLAGS = $(LINK_FLAGS) /safeseh -PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj +PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj !ELSEIF "$(PLATFORM)" == "x86-64" -PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj +PLAF_DLL_OBJS = vm\os-windows-x86.64.obj !ENDIF ML_FLAGS = /nologo /safeseh -EXE_OBJS = vm\main-windows-nt.obj vm\factor.res +EXE_OBJS = vm/main-windows.obj vm\factor.res DLL_OBJS = $(PLAF_DLL_OBJS) \ vm\os-windows.obj \ - vm\os-windows-nt.obj \ vm\aging_collector.obj \ vm\alien.obj \ vm\arrays.obj \ @@ -56,7 +55,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm\jit.obj \ vm\math.obj \ vm\mvm.obj \ - vm\mvm-windows-nt.obj \ + vm\mvm-windows.obj \ vm\nursery_collector.obj \ vm\object_start_map.obj \ vm\objects.obj \ @@ -68,7 +67,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm\to_tenured_collector.obj \ vm\tuples.obj \ vm\utilities.obj \ - vm\vm.obj \ + vm\vm.obj \ vm\words.obj .cpp.obj: diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 7ad4bbb074..5e4635e018 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -33,6 +33,8 @@ TYPEDEF: int MyInt [ 32 ] [ { int 8 } heap-size ] unit-test +[ ] [ pointer: { int 8 } heap-size pointer: void heap-size assert= ] unit-test + TYPEDEF: char MyChar [ t ] [ pointer: void c-type pointer: MyChar c-type = ] unit-test diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 46c2209db9..04755ea033 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -157,7 +157,7 @@ CONSULT: c-type-protocol c-type-name c-type ; PREDICATE: typedef-word < c-type-word - "c-type" word-prop c-type-name? ; + "c-type" word-prop [ c-type-name? ] [ array? ] bi or ; : typedef ( old new -- ) { diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 02a31976c7..1bfaa007fc 100644 --- a/basis/alien/data/data-docs.factor +++ b/basis/alien/data/data-docs.factor @@ -15,8 +15,6 @@ HELP: { $description "Creates a byte array suitable for holding a value with the given C type." } { $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ; -{ malloc-object } related-words - HELP: memory>byte-array { $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; @@ -28,12 +26,6 @@ HELP: malloc-array { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ; -HELP: malloc-object -{ $values { "type" "a C type" } { "alien" alien } } -{ $description "Allocates an unmanaged memory block large enough to hold a value of a C type." } -{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if the type does not exist or if memory allocation fails." } ; - HELP: malloc-byte-array { $values { "byte-array" byte-array } { "alien" alien } } { $description "Allocates an unmanaged memory block of the same size as the byte array, and copies the contents of the byte array there." } @@ -92,7 +84,6 @@ ARTICLE: "malloc" "Manual memory management" $nl "Allocating a C datum with a fixed address:" { $subsections - malloc-object malloc-byte-array } "The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:" diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index d755ac387b..ab34bf5a4e 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -22,16 +22,25 @@ GENERIC: ( len c-type -- array ) M: word c-array-constructor execute( len -- array ) ; inline +M: pointer + drop void* ; + GENERIC: (c-array) ( len c-type -- array ) M: word (c-array) c-(array)-constructor execute( len -- array ) ; inline +M: pointer (c-array) + drop void* (c-array) ; + GENERIC: ( alien len c-type -- array ) M: word c-direct-array-constructor execute( alien len -- array ) ; inline +M: pointer + drop void* ; + : malloc-array ( n type -- array ) [ heap-size calloc ] [ ] 2bi ; inline @@ -44,12 +53,6 @@ M: word : (c-object) ( type -- array ) heap-size (byte-array) ; inline -: malloc-object ( type -- alien ) - 1 swap heap-size calloc ; inline - -: (malloc-object) ( type -- alien ) - heap-size malloc ; inline - : malloc-byte-array ( byte-array -- alien ) binary-object [ nip malloc dup ] 2keep memcpy ; diff --git a/basis/alien/parser/parser-tests.factor b/basis/alien/parser/parser-tests.factor index 26a71e9623..17f417b48d 100644 --- a/basis/alien/parser/parser-tests.factor +++ b/basis/alien/parser/parser-tests.factor @@ -23,23 +23,43 @@ CONSTANT: eleven 11 [ pointer: int* ] [ "int**" parse-c-type ] unit-test [ pointer: int** ] [ "int***" parse-c-type ] unit-test [ pointer: int*** ] [ "int****" parse-c-type ] unit-test + [ { pointer: int 3 } ] [ "int*[3]" parse-c-type ] unit-test + [ { pointer: void 3 } ] [ "void*[3]" parse-c-type ] unit-test + [ pointer: { int 3 } ] [ "int[3]*" parse-c-type ] unit-test [ c-string ] [ "c-string" parse-c-type ] unit-test [ char2 ] [ "char2" parse-c-type ] unit-test [ pointer: char2 ] [ "char2*" parse-c-type ] unit-test + [ "void[3]" parse-c-type ] must-fail + [ "int[3" parse-c-type ] must-fail + [ "int[3][4" parse-c-type ] must-fail [ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with ] with-file-vocabs FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ; + [ (( arg1 arg2 -- void* )) ] [ \ alien-parser-function-effect-test "declared-effect" word-prop ] unit-test +[ t ] [ \ alien-parser-function-effect-test inline? ] unit-test + +FUNCTION-ALIAS: (alien-parser-function-effect-test) void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ; + +[ (( arg1 arg2 -- void* )) ] [ + \ (alien-parser-function-effect-test) "declared-effect" word-prop +] unit-test + +[ t ] [ \ (alien-parser-function-effect-test) inline? ] unit-test + CALLBACK: void* alien-parser-callback-effect-test ( int *arg1 float arg2 ) ; + [ (( arg1 arg2 -- void* )) ] [ \ alien-parser-callback-effect-test "callback-effect" word-prop ] unit-test +[ t ] [ \ alien-parser-callback-effect-test inline? ] unit-test + ! Reported by mnestic TYPEDEF: int alien-parser-test-int ! reasonably unique name... diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 7d72442819..84db07c5ed 100755 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -12,21 +12,29 @@ SYMBOL: current-library : parse-c-type-name ( name -- word ) dup search [ ] [ no-word ] ?if ; -: parse-array-type ( name -- dims c-type ) +DEFER: (parse-c-type) + +ERROR: bad-array-type ; + +: parse-array-type ( name -- c-type ) "[" split unclip - [ [ "]" ?tail drop parse-word ] map ] dip ; + [ [ "]" ?tail [ bad-array-type ] unless parse-word ] map ] + [ (parse-c-type) ] + bi* prefix ; : (parse-c-type) ( string -- type ) { - { [ dup "void" = ] [ drop void ] } - { [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] } - { [ "*" ?tail ] [ (parse-c-type) ] } - { [ dup search ] [ parse-c-type-name ] } + { [ "*" ?tail ] [ (parse-c-type) ] } + { [ CHAR: ] over member? ] [ parse-array-type ] } + { [ dup search ] [ parse-c-type-name ] } [ dup search [ ] [ no-word ] ?if ] } cond ; +: c-array? ( c-type -- ? ) + { [ array? ] [ first { [ c-type-word? ] [ pointer? ] } 1|| ] } 1&& ; + : valid-c-type? ( c-type -- ? ) - { [ array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ; + { [ c-array? ] [ c-type-word? ] [ pointer? ] [ void? ] } 1|| ; : parse-c-type ( string -- type ) (parse-c-type) dup valid-c-type? [ no-c-type ] unless ; diff --git a/basis/alien/prettyprint/prettyprint-tests.factor b/basis/alien/prettyprint/prettyprint-tests.factor index 3a51471703..09d0250788 100644 --- a/basis/alien/prettyprint/prettyprint-tests.factor +++ b/basis/alien/prettyprint/prettyprint-tests.factor @@ -1,5 +1,6 @@ USING: alien.c-types alien.prettyprint alien.syntax -io.streams.string see tools.test prettyprint ; +io.streams.string see tools.test prettyprint +io.encodings.ascii ; IN: alien.prettyprint.tests CONSTANT: FOO 10 @@ -9,7 +10,7 @@ FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ; [ "USING: alien.c-types alien.syntax ; IN: alien.prettyprint.tests FUNCTION: int function_test - ( float x, int[4][FOO] y, char* z, ushort* w ) ; + ( float x, int[4][FOO] y, char* z, ushort* w ) ; inline " ] [ [ \ function_test see ] with-string-writer ] unit-test @@ -20,11 +21,28 @@ FUNCTION-ALIAS: function-test int function_test [ "USING: alien.c-types alien.syntax ; IN: alien.prettyprint.tests FUNCTION-ALIAS: function-test int function_test - ( float x, int[4][FOO] y, char* z, ushort* w ) ; + ( float x, int[4][FOO] y, char* z, ushort* w ) ; inline " ] [ [ \ function-test see ] with-string-writer ] unit-test +TYPEDEF: c-string[ascii] string-typedef +TYPEDEF: char[1][2][3] array-typedef + +[ "USING: alien.c-types alien.syntax ; +IN: alien.prettyprint.tests +TYPEDEF: c-string[ascii] string-typedef +" ] [ + [ \ string-typedef see ] with-string-writer +] unit-test + +[ "USING: alien.c-types alien.syntax ; +IN: alien.prettyprint.tests +TYPEDEF: char[1][2][3] array-typedef +" ] [ + [ \ array-typedef see ] with-string-writer +] unit-test + C-TYPE: opaque-c-type [ "USING: alien.syntax ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 6c2dc5ca85..259f99a833 100755 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -16,11 +16,11 @@ SYNTAX: BAD-ALIEN suffix! ; SYNTAX: LIBRARY: scan current-library set ; SYNTAX: FUNCTION: - (FUNCTION:) make-function define-declared ; + (FUNCTION:) make-function define-inline ; SYNTAX: FUNCTION-ALIAS: scan-token create-function - (FUNCTION:) (make-function) define-declared ; + (FUNCTION:) (make-function) define-inline ; SYNTAX: CALLBACK: (CALLBACK:) define-inline ; diff --git a/basis/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor index 3a1abb3b2d..eeaccd9347 100644 --- a/basis/bootstrap/image/download/download.factor +++ b/basis/bootstrap/image/download/download.factor @@ -10,13 +10,17 @@ CONSTANT: url URL" http://factorcode.org/images/latest/" url "checksums.txt" >url derive-url http-get nip string-lines [ " " split1 ] { } map>assoc ; +: file-checksum ( image -- checksum ) + md5 checksum-file hex-string ; + +: download-checksum ( image -- checksum ) + download-checksums at ; + : need-new-image? ( image -- ? ) dup exists? - [ - [ md5 checksum-file hex-string ] - [ download-checksums at ] - bi = not - ] [ drop t ] if ; + [ [ file-checksum ] [ download-checksum ] bi = not ] + [ drop t ] + if ; : verify-image ( image -- ) need-new-image? [ "Boot image corrupt" throw ] when ; diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor old mode 100644 new mode 100755 index 68fbf55105..623b169853 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -15,12 +15,7 @@ generalizations ; IN: bootstrap.image : arch ( os cpu -- arch ) - [ dup "winnt" = "winnt" "unix" ? ] dip - { - { "ppc" [ drop "-ppc" append ] } - { "x86.32" [ nip "-x86.32" append ] } - { "x86.64" [ nip "-x86.64" append ] } - } case ; + [ "winnt" = "winnt" "unix" ? ] dip "-" glue ; : my-arch ( -- arch ) os name>> cpu name>> arch ; @@ -35,7 +30,6 @@ IN: bootstrap.image { "winnt-x86.32" "unix-x86.32" "winnt-x86.64" "unix-x86.64" - "linux-ppc" "macosx-ppc" } ; > append ] } - { [ os winnt? ] [ "windows.nt" ] } + { [ os windows? ] [ "windows" ] } } cond append require ] when diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index e3e8b5ddbc..c70cf00df3 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -72,8 +72,7 @@ SYMBOL: bootstrap-time (command-line) parse-command-line ! Set dll paths - os wince? [ "windows.ce" require ] when - os winnt? [ "windows.nt" require ] when + os windows? [ "windows" require ] when "staging" get "deploy-vocab" get or [ "stage2: deployment mode" print diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index da7c1b4294..e364ee9a41 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/basis/cairo/ffi/ffi.factor @@ -1,15 +1,13 @@ -! Copyright (c) 2007 Sampo Vuori -! Copyright (c) 2008 Matthew Willis -! - - -! Adapted from cairo.h, version 1.5.14 -! License: http://factorcode.org/license.txt - +! Copyright (C) 2007 Sampo Vuori. +! Copyright (C) 2008 Matthew Willis. +! Copyright (C) 2010 Anton Gorenko. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.destructors alien.libraries alien.syntax classes.struct combinators kernel system ; - IN: cairo.ffi + +! Adapted from cairo.h, version 1.8.10 + << { { [ os winnt? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] } { [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" cdecl add-library ] } @@ -37,9 +35,8 @@ STRUCT: cairo_matrix_t TYPEDEF: void* cairo_pattern_t -TYPEDEF: void* cairo_destroy_func_t -: cairo-destroy-func ( quot -- callback ) - [ void { pointer: void } cdecl ] dip alien-callback ; inline +CALLBACK: void +cairo_destroy_func_t ( void* data ) ; ! See cairo.h for details STRUCT: cairo_user_data_key_t @@ -70,22 +67,28 @@ ENUM: cairo_status_t CAIRO_STATUS_INVALID_INDEX CAIRO_STATUS_CLIP_NOT_REPRESENTABLE CAIRO_STATUS_TEMP_FILE_ERROR - CAIRO_STATUS_INVALID_STRIDE ; + CAIRO_STATUS_INVALID_STRIDE + CAIRO_STATUS_FONT_TYPE_MISMATCH + CAIRO_STATUS_USER_FONT_IMMUTABLE + CAIRO_STATUS_USER_FONT_ERROR + CAIRO_STATUS_NEGATIVE_COUNT + CAIRO_STATUS_INVALID_CLUSTERS + CAIRO_STATUS_INVALID_SLANT + CAIRO_STATUS_INVALID_WEIGHT ; -TYPEDEF: int cairo_content_t -CONSTANT: CAIRO_CONTENT_COLOR HEX: 1000 -CONSTANT: CAIRO_CONTENT_ALPHA HEX: 2000 -CONSTANT: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 +ENUM: cairo_content_t + { CAIRO_CONTENT_COLOR HEX: 1000 } + { CAIRO_CONTENT_ALPHA HEX: 2000 } + { CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 } ; -TYPEDEF: void* cairo_write_func_t -: cairo-write-func ( quot -- callback ) - [ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline - -TYPEDEF: void* cairo_read_func_t -: cairo-read-func ( quot -- callback ) - [ cairo_status_t { pointer: void c-string int } cdecl ] dip alien-callback ; inline +CALLBACK: cairo_status_t +cairo_write_func_t ( void* closure, uchar* data, uint length ) ; + +CALLBACK: cairo_status_t +cairo_read_func_t ( void* closure, uchar* data, uint length ) ; ! Functions for manipulating state objects + FUNCTION: cairo_t* cairo_create ( cairo_surface_t* target ) ; @@ -116,7 +119,7 @@ FUNCTION: void cairo_push_group ( cairo_t* cr ) ; FUNCTION: void -cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ; +cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ; FUNCTION: cairo_pattern_t* cairo_pop_group ( cairo_t* cr ) ; @@ -125,6 +128,7 @@ FUNCTION: void cairo_pop_group_to_source ( cairo_t* cr ) ; ! Modify state + ENUM: cairo_operator_t CAIRO_OPERATOR_CLEAR @@ -234,6 +238,7 @@ FUNCTION: void cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ; ! Path creation functions + FUNCTION: void cairo_new_path ( cairo_t* cr ) ; @@ -274,6 +279,7 @@ FUNCTION: void cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; ! Painting functions + FUNCTION: void cairo_paint ( cairo_t* cr ) ; @@ -305,6 +311,7 @@ FUNCTION: void cairo_show_page ( cairo_t* cr ) ; ! Insideness testing + FUNCTION: cairo_bool_t cairo_in_stroke ( cairo_t* cr, double x, double y ) ; @@ -312,6 +319,7 @@ FUNCTION: cairo_bool_t cairo_in_fill ( cairo_t* cr, double x, double y ) ; ! Rectangular extents + FUNCTION: void cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; @@ -319,6 +327,7 @@ FUNCTION: void cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ; ! Clipping + FUNCTION: void cairo_reset_clip ( cairo_t* cr ) ; @@ -355,9 +364,28 @@ TYPEDEF: void* cairo_scaled_font_t TYPEDEF: void* cairo_font_face_t STRUCT: cairo_glyph_t - { index ulong } - { x double } - { y double } ; + { index ulong } + { x double } + { y double } ; + +FUNCTION: cairo_glyph_t* +cairo_glyph_allocate ( int num_glyphs ) ; + +FUNCTION: void +cairo_glyph_free ( cairo_glyph_t* glyphs ) ; + +STRUCT: cairo_text_cluster_t + { num_bytes int } + { num_glyphs int } ; + +FUNCTION: cairo_text_cluster_t* +cairo_text_cluster_allocate ( int num_clusters ) ; + +FUNCTION: void +cairo_text_cluster_free ( cairo_text_cluster_t* clusters ) ; + +ENUM: cairo_text_cluster_flags_t + { CAIRO_TEXT_CLUSTER_FLAG_BACKWARD HEX: 00000001 } ; STRUCT: cairo_text_extents_t { x_bearing double } @@ -489,7 +517,10 @@ FUNCTION: void cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ; FUNCTION: void -cairo_text_path ( cairo_t* cr, c-string utf8 ) ; +cairo_show_text_glyphs ( cairo_t* cr, c-string utf8, int utf8_len, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_cluster_t* clusters, int num_clusters, cairo_text_cluster_flags_t cluster_flags ) ; + +FUNCTION: void +cairo_text_path ( cairo_t* cr, c-string utf8 ) ; FUNCTION: void cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ; @@ -521,7 +552,8 @@ ENUM: cairo_font_type_t CAIRO_FONT_TYPE_TOY CAIRO_FONT_TYPE_FT CAIRO_FONT_TYPE_WIN32 - CAIRO_FONT_TYPE_QUARTZ ; + CAIRO_FONT_TYPE_QUARTZ + CAIRO_FONT_TYPE_USER ; FUNCTION: cairo_font_type_t cairo_font_face_get_type ( cairo_font_face_t* font_face ) ; @@ -567,6 +599,9 @@ cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, c-string utf8 FUNCTION: void cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ; +FUNCTION: cairo_status_t +cairo_scaled_font_text_to_glyphs ( cairo_scaled_font_t* scaled_font, double x, double y, c-string utf8, int utf8_len, cairo_glyph_t** glyphs, int* num_glyphs, cairo_text_cluster_t** clusters, int* num_clusters, cairo_text_cluster_flags_t* cluster_flags ) ; + FUNCTION: cairo_font_face_t* cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ; @@ -576,9 +611,73 @@ cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matr FUNCTION: void cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ; +FUNCTION: void +cairo_scaled_font_get_scale_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* scale_matrix ) ; + FUNCTION: void cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ; +! Toy fonts + +FUNCTION: cairo_font_face_t* +cairo_toy_font_face_create ( c-string family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ; + +FUNCTION: c-string +cairo_toy_font_face_get_family ( cairo_font_face_t* font_face ) ; + +FUNCTION: cairo_font_slant_t +cairo_toy_font_face_get_slant ( cairo_font_face_t* font_face ) ; + +FUNCTION: cairo_font_weight_t +cairo_toy_font_face_get_weight ( cairo_font_face_t* font_face ) ; + +! User fonts + +FUNCTION: cairo_font_face_t* +cairo_user_font_face_create ( ) ; + +! User-font method signatures + +CALLBACK: cairo_status_t +cairo_user_scaled_font_init_func_t ( cairo_scaled_font_t* scaled_font, cairo_t* cr, cairo_font_extents_t* extents ) ; + +CALLBACK: cairo_status_t +cairo_user_scaled_font_render_glyph_func_t ( cairo_scaled_font_t* scaled_font, ulong glyph, cairo_t* cr, cairo_text_extents_t* extents ) ; + +CALLBACK: cairo_status_t +cairo_user_scaled_font_text_to_glyphs_func_t ( cairo_scaled_font_t* scaled_font, char* utf8, int utf8_len, cairo_glyph_t** glyphs, int* num_glyphs, cairo_text_cluster_t** clusters, int* num_clusters, cairo_text_cluster_flags_t* cluster_flags ) ; + +CALLBACK: cairo_status_t +cairo_user_scaled_font_unicode_to_glyph_func_t ( cairo_scaled_font_t* scaled_font, ulong unicode, ulong* glyph_index ) ; + +! User-font method setters + +FUNCTION: void +cairo_user_font_face_set_init_func ( cairo_font_face_t* font_face, cairo_user_scaled_font_init_func_t init_func ) ; + +FUNCTION: void +cairo_user_font_face_set_render_glyph_func ( cairo_font_face_t* font_face, cairo_user_scaled_font_render_glyph_func_t render_glyph_func ) ; + +FUNCTION: void +cairo_user_font_face_set_text_to_glyphs_func ( cairo_font_face_t* font_face, cairo_user_scaled_font_text_to_glyphs_func_t text_to_glyphs_func ) ; + +FUNCTION: void +cairo_user_font_face_set_unicode_to_glyph_func ( cairo_font_face_t* font_face, cairo_user_scaled_font_unicode_to_glyph_func_t unicode_to_glyph_func ) ; + +! User-font method getters + +FUNCTION: cairo_user_scaled_font_init_func_t +cairo_user_font_face_get_init_func ( cairo_font_face_t* font_face ) ; + +FUNCTION: cairo_user_scaled_font_render_glyph_func_t +cairo_user_font_face_get_render_glyph_func ( cairo_font_face_t* font_face ) ; + +FUNCTION: cairo_user_scaled_font_text_to_glyphs_func_t +cairo_user_font_face_get_text_to_glyphs_func ( cairo_font_face_t* font_face ) ; + +FUNCTION: cairo_user_scaled_font_unicode_to_glyph_func_t +cairo_user_font_face_get_unicode_to_glyph_func ( cairo_font_face_t* font_face ) ; + ! Query functions FUNCTION: cairo_operator_t @@ -649,9 +748,9 @@ UNION-STRUCT: cairo_path_data_t { header cairo_path_data_t-header } ; STRUCT: cairo_path_t - { status cairo_status_t } - { data cairo_path_data_t* } - { num_data int } ; + { status cairo_status_t } + { data cairo_path_data_t* } + { num_data int } ; FUNCTION: cairo_path_t* cairo_copy_path ( cairo_t* cr ) ; @@ -750,20 +849,25 @@ cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, do FUNCTION: void cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ; +FUNCTION: void +cairo_surface_get_fallback_resolution ( cairo_surface_t* surface, double* x_pixels_per_inch, double* y_pixels_per_inch ) ; + FUNCTION: void cairo_surface_copy_page ( cairo_surface_t* surface ) ; FUNCTION: void cairo_surface_show_page ( cairo_surface_t* surface ) ; +FUNCTION: cairo_bool_t +cairo_surface_has_show_text_glyphs ( cairo_surface_t* surface ) ; + ! Image-surface functions ENUM: cairo_format_t CAIRO_FORMAT_ARGB32 CAIRO_FORMAT_RGB24 CAIRO_FORMAT_A8 - CAIRO_FORMAT_A1 - CAIRO_FORMAT_RGB16_565 ; + CAIRO_FORMAT_A1 ; FUNCTION: cairo_surface_t* cairo_image_surface_create ( cairo_format_t format, int width, int height ) ; @@ -834,7 +938,7 @@ ENUM: cairo_pattern_type_t CAIRO_PATTERN_TYPE_SOLID CAIRO_PATTERN_TYPE_SURFACE CAIRO_PATTERN_TYPE_LINEAR - CAIRO_PATTERN_TYPE_RADIA ; + CAIRO_PATTERN_TYPE_RADIAL ; FUNCTION: cairo_pattern_type_t cairo_pattern_get_type ( cairo_pattern_t* pattern ) ; @@ -898,7 +1002,7 @@ cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* ! Matrix functions FUNCTION: void -cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ; +cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ; FUNCTION: void cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ; diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index e76aace464..c31ddca2c1 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -519,7 +519,7 @@ HELP: since-1970 { $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ; ARTICLE: "calendar" "Calendar" -"The two data types used throughout the calendar library:" +"The " { $vocab-link "calendar" } " vocabulary defines two data types and a set of operations on them:" { $subsections timestamp duration @@ -533,13 +533,12 @@ ARTICLE: "calendar" "Calendar" now gmt } -"Converting between timestamps:" +"Time zones:" { $subsections >local-time >gmt + convert-timezone } -"Converting between timezones:" -{ $subsections convert-timezone } "Timestamps relative to each other:" { $subsections "relative-timestamps" } "Operations on units of time:" @@ -548,9 +547,10 @@ ARTICLE: "calendar" "Calendar" "months" "days" } +"Both " { $link timestamp } "s and " { $link duration } "s implement the " { $link "math.order" } "." +$nl "Meta-data about the calendar:" -{ $subsections "calendar-facts" } -; +{ $subsections "calendar-facts" } ; ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic" "Adding timestamps and durations, or durations and durations:" diff --git a/basis/channels/remote/remote-docs.factor b/basis/channels/remote/remote-docs.factor index c612b4256a..266d774056 100644 --- a/basis/channels/remote/remote-docs.factor +++ b/basis/channels/remote/remote-docs.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup channels concurrency.distributed ; +USING: channels concurrency.distributed help.markup help.syntax +io.servers.connection ; IN: channels.remote HELP: @@ -45,9 +46,9 @@ HELP: publish ARTICLE: { "remote-channels" "remote-channels" } "Remote Channels" "Remote channels are channels that can be accessed by other Factor instances. It uses distributed concurrency to serialize and send data between channels." $nl -"To start a remote node, distributed concurrency must have been started. This can be done using " { $link start-node } "." +"To start a remote node, distributed concurrency must have been started. This can be done using " { $link start-server } "." $nl -{ $snippet "\"myhost.com\" 9001 start-node" } +{ $snippet "\"myhost.com\" 9001 start-server" } $nl "Once the node is started, channels can be published using " { $link publish } " to be accessed remotely. " { $link publish } " returns an id which a remote node " diff --git a/basis/checksums/internet/authors.txt b/basis/checksums/internet/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/checksums/internet/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/checksums/internet/internet-tests.factor b/basis/checksums/internet/internet-tests.factor new file mode 100644 index 0000000000..b01ba28001 --- /dev/null +++ b/basis/checksums/internet/internet-tests.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: checksums checksums.internet tools.test ; + +IN: checksums + +[ B{ 255 255 } ] [ { } internet checksum-bytes ] unit-test +[ B{ 254 255 } ] [ { 1 } internet checksum-bytes ] unit-test +[ B{ 254 253 } ] [ { 1 2 } internet checksum-bytes ] unit-test +[ B{ 251 253 } ] [ { 1 2 3 } internet checksum-bytes ] unit-test + +: test-data ( -- bytes ) + B{ + HEX: 00 HEX: 01 + HEX: f2 HEX: 03 + HEX: f4 HEX: f5 + HEX: f6 HEX: f7 + } ; + +[ B{ 34 13 } ] [ test-data internet checksum-bytes ] unit-test + diff --git a/basis/checksums/internet/internet.factor b/basis/checksums/internet/internet.factor new file mode 100644 index 0000000000..8c609674b1 --- /dev/null +++ b/basis/checksums/internet/internet.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: checksums grouping io.binary kernel math sequences ; + +IN: checksums.internet + +SINGLETON: internet ! RFC 1071 + +INSTANCE: internet checksum + +M: internet checksum-bytes + drop 0 swap 2 [ le> + ] each + [ -16 shift ] [ HEX: ffff bitand ] bi + + [ -16 shift ] keep + bitnot 2 >le ; + diff --git a/basis/checksums/internet/summary.txt b/basis/checksums/internet/summary.txt new file mode 100644 index 0000000000..46ed6e3d54 --- /dev/null +++ b/basis/checksums/internet/summary.txt @@ -0,0 +1 @@ +Internet (RFC 1071) checksum algorithm diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 4ed7d9b446..90f60a4205 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -245,6 +245,8 @@ STRUCT: struct-test-equality-1 STRUCT: struct-test-equality-2 { y int } ; +[ 0 ] [ struct-test-equality-1 new hashcode ] unit-test + [ t ] [ [ struct-test-equality-1 5 >>x @@ -474,3 +476,9 @@ CONSULT: struct-test-delegate struct-test-delegator del>> ; 7 >>a 8 >>b ] unit-test + +SPECIALIZED-ARRAY: void* + +STRUCT: silly-array-field-test { x int*[3] } ; + +[ t ] [ silly-array-field-test x>> void*-array? ] unit-test diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 3699cdb7d1..15a7b72c6c 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -48,13 +48,18 @@ M: struct >c-ptr 2 slot { c-ptr } declare ; inline M: struct equal? - { - [ [ class ] bi@ = ] - [ [ >c-ptr ] [ binary-object ] bi* memory= ] - } 2&& ; inline + over struct? [ + 2dup [ class ] bi@ = [ + 2dup [ >c-ptr ] both? + [ [ >c-ptr ] [ binary-object ] bi* memory= ] + [ [ >c-ptr not ] both? ] + if + ] [ 2drop f ] if + ] [ 2drop f ] if ; inline M: struct hashcode* - binary-object hashcode* ; inline + binary-object over + [ hashcode* ] [ 3drop 0 ] if ; inline : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index b00f39fa1d..9e984d5d00 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2006, 2010 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax io kernel namespaces core-foundation -core-foundation.strings cocoa.messages cocoa cocoa.classes -cocoa.runtime sequences init summary kernel.private -assocs ; +USING: alien alien.c-types alien.syntax io kernel namespaces +core-foundation core-foundation.strings cocoa.messages cocoa +cocoa.classes cocoa.runtime sequences init summary +kernel.private assocs ; IN: cocoa.application : ( str -- alien ) -> autorelease ; diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index b88d3afd7b..3b88a8868c 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -95,16 +95,8 @@ SYNTAX: CLASS: [ [ make-local ] map ] H{ } make-assoc (parse-lambda) ?rewrite-closures first ; -: method-effect ( quadruple -- effect ) - [ third ] [ second void? { } { "x" } ? ] bi ; - -: check-method ( quadruple -- ) - [ fourth infer ] [ method-effect ] bi - 2dup effect<= [ 2drop ] [ effect-error ] if ; - SYNTAX: METHOD: scan-c-type parse-selector parse-method-body [ swap ] 2dip 4array - dup check-method suffix! ; diff --git a/basis/combinators/random/authors.txt b/basis/combinators/random/authors.txt new file mode 100644 index 0000000000..2c5e05bdac --- /dev/null +++ b/basis/combinators/random/authors.txt @@ -0,0 +1 @@ +Jon Harper diff --git a/basis/combinators/random/random-docs.factor b/basis/combinators/random/random-docs.factor new file mode 100644 index 0000000000..2fc0b8c00e --- /dev/null +++ b/basis/combinators/random/random-docs.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2010 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax kernel quotations +combinators.random.private sequences ; +IN: combinators.random + +HELP: call-random +{ $values { "seq" "a sequence of quotations" } } +{ $description "Calls a random quotation from the given sequence of quotations." } ; + +HELP: execute-random +{ $values { "seq" "a sequence of words" } } +{ $description "Executes a random word from the given sequence of quotations." } ; + +HELP: ifp +{ $values + { "p" "a number between 0 and 1" } { "true" quotation } { "false" quotation } +} +{ $description "Calls the " { $snippet "true" } " quotation with probability " { $snippet "p" } +" and the " { $snippet "false" } " quotation with probability (1-" { $snippet "p" } ")." } ; + +HELP: casep +{ $values + { "assoc" "a sequence of probability/quotations pairs with an optional quotation at the end" } +} +{ $description "Calls the different quotations randomly with the given probability. The optional quotation at the end " +"will be given a probability so that the sum of the probabilities is one. Therefore, the sum of the probabilities " +"must be exactly one when no default quotation is given, or between zero and one when it is given. " +"Additionally, all probabilities must be numbers between 0 and 1. " +"These rules are enforced during the macro expansion by throwing " { $link bad-probabilities } " " +"if they are not respected." } +{ $examples + "The following two forms will output 1 with 0.2 probability, 2 with 0.3 probability and 3 with 0.5 probability" + { $code + "USING: combinators.random ;" + "{ { 0.2 [ 1 ] }" + " { 0.3 [ 2 ] }" + " { 0.5 [ 3 ] } } casep ." + } + $nl + { $code + "USING: combinators.random ;" + "{ { 0.2 [ 1 ] }" + " { 0.3 [ 2 ] }" + " { [ 3 ] } } casep ." + } + +} + +{ $see-also casep* } ; + +HELP: casep* +{ $values + { "assoc" "a sequence of probability/word pairs with an optional quotation at the end" } +} +{ $description "Calls the different quotations randomly with the given probability. Unlike " { $link casep } ", " +"the probabilities are interpreted as conditional probabilities. " +"All probabilities must be numbers between 0 and 1. " +"The sequence must end with a pair whose probability is one, or a quotation." +"These rules are enforced during the macro expansion by throwing " { $link bad-probabilities } " " +"if they are not respected." } +{ $examples + "The following two forms will output 1 with 0.5 probability, 2 with 0.25 probability and 3 with 0.25 probability" + { $code + "USING: combinators.random ;" + "{ { 0.5 [ 1 ] }" + " { 0.5 [ 2 ] }" + " { 1 [ 3 ] } } casep* ." + } + $nl + { $code + "USING: combinators.random ;" + "{ { 0.5 [ 1 ] }" + " { 0.5 [ 2 ] }" + " { [ 3 ] } } casep* ." + } + +} +{ $see-also casep } ; + +HELP: unlessp +{ $values + { "p" "a number between 0 and 1" } { "false" quotation } +} +{ $description "Variant of " { $link ifp } " with no " { $snippet "true" } " quotation." } ; + +HELP: whenp +{ $values + { "p" "a number between 0 and 1" } { "true" quotation } +} +{ $description "Variant of " { $link ifp } " with no " { $snippet "false" } " quotation." } ; + +ARTICLE: "combinators.random" "Random combinators" +"The " { $vocab-link "combinators.random" } " vocabulary implements simple combinators to easily express random choices" +" between multiple code paths." +$nl +"For all these combinators, the stack effect of the different given quotations or words must be the same." +$nl +"Variants of if, when and unless:" +{ $subsections + ifp + whenp + unlessp } +"Variants of case:" +{ $subsections + casep + casep* + call-random + execute-random +} ; + +ABOUT: "combinators.random" diff --git a/basis/combinators/random/random-tests.factor b/basis/combinators/random/random-tests.factor new file mode 100644 index 0000000000..32f2874538 --- /dev/null +++ b/basis/combinators/random/random-tests.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2010 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test combinators.random combinators.random.private ; +IN: combinators.random.tests + +[ 1 ] [ 1 [ 1 ] [ 2 ] ifp ] unit-test +[ 2 ] [ 0 [ 1 ] [ 2 ] ifp ] unit-test + +[ 3 ] +[ { { 0 [ 1 ] } + { 0 [ 2 ] } + { 1 [ 3 ] } + [ 4 ] + } casep ] unit-test + +[ 4 ] +[ { { 0 [ 1 ] } + { 0 [ 2 ] } + { 0 [ 3 ] } + [ 4 ] + } casep ] unit-test + +[ 1 1 ] [ 1 { + { 1 [ 1 ] } + { 0 [ 2 ] } + { 0 [ 3 ] } + [ 4 ] + } casep ] unit-test + +[ 1 4 ] [ 1 { + { 0 [ 1 ] } + { 0 [ 2 ] } + { 0 [ 3 ] } + [ 4 ] + } casep ] unit-test + +[ 2 ] [ 0.7 { + { 0.3 [ 1 ] } + { 0.5 [ 2 ] } + [ 2 ] } (casep) ] unit-test + +[ { { 1/3 [ 1 ] } + { 1/3 [ 2 ] } + { 1/3 [ 3 ] } } ] +[ { [ 1 ] [ 2 ] [ 3 ] } call-random>casep ] unit-test + +[ { { 1/2 [ 1 ] } + { 1/4 [ 2 ] } + { 1/4 [ 3 ] } } ] +[ { { 1/2 [ 1 ] } + { 1/2 [ 2 ] } + { 1 [ 3 ] } } direct>conditional ] unit-test + +[ { { 1/2 [ 1 ] } + { 1/4 [ 2 ] } + { [ 3 ] } } ] +[ { { 1/2 [ 1 ] } + { 1/2 [ 2 ] } + { [ 3 ] } } direct>conditional ] unit-test + +[ f ] [ { { 0.6 [ 1 ] } + { 0.6 [ 2 ] } } good-probabilities? ] unit-test +[ f ] [ { { 0.3 [ 1 ] } + { 0.6 [ 2 ] } } good-probabilities? ] unit-test +[ f ] [ { { -0.6 [ 1 ] } + { 1.4 [ 2 ] } } good-probabilities? ] unit-test +[ f ] [ { { -0.6 [ 1 ] } + [ 2 ] } good-probabilities? ] unit-test +[ t ] [ { { 0.6 [ 1 ] } + [ 2 ] } good-probabilities? ] unit-test +[ t ] [ { { 0.6 [ 1 ] } + { 0.4 [ 2 ] } } good-probabilities? ] unit-test diff --git a/basis/combinators/random/random.factor b/basis/combinators/random/random.factor new file mode 100644 index 0000000000..9e6fde9a16 --- /dev/null +++ b/basis/combinators/random/random.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2010 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs combinators combinators.short-circuit +kernel macros math math.order quotations random sequences +summary ; +IN: combinators.random + +: ifp ( p true false -- ) [ 0 1 uniform-random-float > ] 2dip if ; inline +: whenp ( p true -- ) [ ] ifp ; inline +: unlessp ( p false -- ) [ [ ] ] dip ifp ; inline + +quot) ( assoc -- quot ) + dup good-probabilities? [ + [ dup pair? [ prepare-pair ] [ with-drop ] if ] map + cond>quot + ] [ bad-probabilities ] if ; + +MACRO: (casep) ( assoc -- ) (casep>quot) ; + +: casep>quot ( assoc -- quot ) + (casep>quot) [ 0 1 uniform-random-float ] prepend ; + +: (conditional-probabilities) ( seq i -- p ) + [ dup 0 > [ head [ 1 swap - ] [ * ] map-reduce ] [ 2drop 1 ] if ] [ swap nth ] 2bi * ; + +: conditional-probabilities ( seq -- seq' ) + dup length iota [ (conditional-probabilities) ] with map ; + +: (direct>conditional) ( assoc -- assoc' ) + [ keys conditional-probabilities ] [ values ] bi zip ; + +: direct>conditional ( assoc -- assoc' ) + dup last pair? [ (direct>conditional) ] [ + unclip-last [ (direct>conditional) ] [ suffix ] bi* + ] if ; + +: call-random>casep ( seq -- assoc ) + [ length recip ] keep [ 2array ] with map ; + +PRIVATE> + +MACRO: casep ( assoc -- ) casep>quot ; + +MACRO: casep* ( assoc -- ) direct>conditional casep>quot ; + +MACRO: call-random ( seq -- ) call-random>casep casep>quot ; + +MACRO: execute-random ( seq -- ) + [ 1quotation ] map call-random>casep casep>quot ; \ No newline at end of file diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index b17f8250dd..2ff7e7121c 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -87,7 +87,7 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage" "The following command line switches can be passed to a bootstrapped Factor image:" { $table { { $snippet "-e=" { $emphasis "code" } } { "This specifies a code snippet to evaluate. If you want Factor to exit immediately after, also specify " { $snippet "-run=none" } "." } } - { { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } } + { { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui.tools" } " or " { $vocab-link "none" } "." } } { { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } } { { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } } } ; diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor index dc6ba4ad39..21241e6f4a 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor @@ -288,20 +288,20 @@ IN: compiler.cfg.alias-analysis.tests } test-alias-analysis ] unit-test -! We can't make any assumptions about heap-ac between alien -! calls, since they might callback into Factor code +! We can't make any assumptions about heap-ac between +! instructions which can call back into Factor code [ V{ T{ ##peek f 0 D 0 } T{ ##slot-imm f 1 0 1 0 } - T{ ##alien-invoke f { } { } { } 0 0 "free" } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } T{ ##slot-imm f 2 0 1 0 } } ] [ V{ T{ ##peek f 0 D 0 } T{ ##slot-imm f 1 0 1 0 } - T{ ##alien-invoke f { } { } { } 0 0 "free" } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } T{ ##slot-imm f 2 0 1 0 } } test-alias-analysis ] unit-test @@ -311,7 +311,7 @@ IN: compiler.cfg.alias-analysis.tests T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } T{ ##set-slot-imm f 1 0 1 0 } - T{ ##alien-invoke f { } { } { } 0 0 "free" } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } T{ ##slot-imm f 2 0 1 0 } } ] [ @@ -319,7 +319,7 @@ IN: compiler.cfg.alias-analysis.tests T{ ##peek f 0 D 0 } T{ ##peek f 1 D 1 } T{ ##set-slot-imm f 1 0 1 0 } - T{ ##alien-invoke f { } { } { } 0 0 "free" } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } T{ ##slot-imm f 2 0 1 0 } } test-alias-analysis ] unit-test @@ -330,7 +330,7 @@ IN: compiler.cfg.alias-analysis.tests T{ ##peek f 1 D 1 } T{ ##peek f 2 D 2 } T{ ##set-slot-imm f 1 0 1 0 } - T{ ##alien-invoke f { } { } { } 0 0 "free" } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } T{ ##set-slot-imm f 2 0 1 0 } } ] [ @@ -339,7 +339,7 @@ IN: compiler.cfg.alias-analysis.tests T{ ##peek f 1 D 1 } T{ ##peek f 2 D 2 } T{ ##set-slot-imm f 1 0 1 0 } - T{ ##alien-invoke f { } { } { } 0 0 "free" } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } T{ ##set-slot-imm f 2 0 1 0 } } test-alias-analysis ] unit-test @@ -348,14 +348,101 @@ IN: compiler.cfg.alias-analysis.tests V{ T{ ##peek f 0 D 0 } T{ ##slot-imm f 1 0 1 0 } - T{ ##alien-invoke f { } { } { } 0 0 "free" } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } T{ ##set-slot-imm f 1 0 1 0 } } ] [ V{ T{ ##peek f 0 D 0 } T{ ##slot-imm f 1 0 1 0 } - T{ ##alien-invoke f { } { } { } 0 0 "free" } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } T{ ##set-slot-imm f 1 0 1 0 } } test-alias-analysis ] unit-test + +! We can't eliminate stores on any alias class across a GC-ing +! instruction +[ + V{ + T{ ##allot f 0 } + T{ ##slot-imm f 1 0 1 0 } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } + T{ ##copy f 2 1 any-rep } + } +] [ + V{ + T{ ##allot f 0 } + T{ ##slot-imm f 1 0 1 0 } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } + T{ ##slot-imm f 2 0 1 0 } + } test-alias-analysis +] unit-test + +[ + V{ + T{ ##allot f 0 } + T{ ##peek f 1 D 1 } + T{ ##set-slot-imm f 1 0 1 0 } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } + T{ ##copy f 2 1 any-rep } + } +] [ + V{ + T{ ##allot f 0 } + T{ ##peek f 1 D 1 } + T{ ##set-slot-imm f 1 0 1 0 } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } + T{ ##slot-imm f 2 0 1 0 } + } test-alias-analysis +] unit-test + +[ + V{ + T{ ##allot f 0 } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##set-slot-imm f 1 0 1 0 } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } + T{ ##set-slot-imm f 2 0 1 0 } + } +] [ + V{ + T{ ##allot f 0 } + T{ ##peek f 1 D 1 } + T{ ##peek f 2 D 2 } + T{ ##set-slot-imm f 1 0 1 0 } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } + T{ ##set-slot-imm f 2 0 1 0 } + } test-alias-analysis +] unit-test + +[ + V{ + T{ ##allot f 0 } + T{ ##slot-imm f 1 0 1 0 } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } + } +] [ + V{ + T{ ##allot f 0 } + T{ ##slot-imm f 1 0 1 0 } + T{ ##alien-invoke f { } { } { } { } 0 0 "free" } + T{ ##set-slot-imm f 1 0 1 0 } + } test-alias-analysis +] unit-test + +! Make sure that gc-map-insns which are also vreg-insns are +! handled properly +[ + V{ + T{ ##allot f 0 } + T{ ##alien-indirect f { } { } { { 2 double-rep 0 } } { } 0 0 "free" } + T{ ##set-slot-imm f 2 0 1 0 } + } +] [ + V{ + T{ ##allot f 0 } + T{ ##alien-indirect f { } { } { { 2 double-rep 0 } } { } 0 0 "free" } + T{ ##set-slot-imm f 2 0 1 0 } + } test-alias-analysis +] unit-test diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 5ba0bd1300..6fff3f0216 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -218,7 +218,7 @@ GENERIC: analyze-aliases ( insn -- insn' ) M: insn analyze-aliases ; -M: vreg-insn analyze-aliases +: def-acs ( insn -- insn' ) ! If an instruction defines a value with a non-integer ! representation it means that the value will be boxed ! anywhere its used as a tagged pointer. Boxing allocates @@ -229,6 +229,9 @@ M: vreg-insn analyze-aliases [ set-heap-ac ] [ set-new-ac ] if ] each-def-rep ; +M: vreg-insn analyze-aliases + def-acs ; + M: ##phi analyze-aliases dup dst>> set-heap-ac ; @@ -286,6 +289,29 @@ M: ##compare analyze-aliases analyze-aliases ] when ; +: clear-live-slots ( -- ) + heap-ac get ac>vregs [ live-slots get at clear-assoc ] each ; + +: clear-recent-stores ( -- ) + recent-stores get values [ clear-assoc ] each ; + +M: gc-map-insn analyze-aliases + ! Can't use call-next-method here because of a limitation, gah + def-acs + clear-recent-stores ; + +M: factor-call-insn analyze-aliases + def-acs + clear-recent-stores + clear-live-slots ; + +GENERIC: eliminate-dead-stores ( insn -- ? ) + +M: ##set-slot-imm eliminate-dead-stores + insn#>> dead-stores get in? not ; + +M: insn eliminate-dead-stores drop t ; + : reset-alias-analysis ( -- ) recent-stores get clear-assoc vregs>acs get clear-assoc @@ -298,20 +324,6 @@ M: ##compare analyze-aliases \ ##vm-field set-new-ac \ ##alien-global set-new-ac ; -M: factor-call-insn analyze-aliases - call-next-method - heap-ac get ac>vregs [ - [ live-slots get at clear-assoc ] - [ recent-stores get at clear-assoc ] bi - ] each ; - -GENERIC: eliminate-dead-stores ( insn -- ? ) - -M: ##set-slot-imm eliminate-dead-stores - insn#>> dead-stores get in? not ; - -M: insn eliminate-dead-stores drop t ; - : alias-analysis-step ( insns -- insns' ) reset-alias-analysis [ local-live-in [ set-heap-ac ] each ] diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 41882bc78f..9773109584 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -35,11 +35,8 @@ M: ##unbox compute-stack-frame* drop vm-frame-required ; M: ##box-long-long compute-stack-frame* drop vm-frame-required ; M: ##callback-inputs compute-stack-frame* drop vm-frame-required ; M: ##callback-outputs compute-stack-frame* drop vm-frame-required ; -M: ##unary-float-function compute-stack-frame* drop vm-frame-required ; -M: ##binary-float-function compute-stack-frame* drop vm-frame-required ; M: ##call compute-stack-frame* drop frame-required ; -M: ##alien-callback compute-stack-frame* drop frame-required ; M: ##spill compute-stack-frame* drop frame-required ; M: ##reload compute-stack-frame* drop frame-required ; diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index c191628774..d5502ab3ba 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -54,8 +54,8 @@ IN: compiler.cfg.builder.alien (caller-parameters) ] with-param-regs* ; -: prepare-caller-return ( params -- reg-outputs ) - return>> [ { } ] [ base-type load-return ] if-void ; +: prepare-caller-return ( params -- reg-outputs dead-outputs ) + return>> [ { } ] [ base-type load-return ] if-void { } ; : caller-stack-frame ( params -- cleanup stack-size ) [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup @@ -173,24 +173,22 @@ M: #alien-assembly emit-node : needs-frame-pointer ( -- ) cfg get t >>frame-pointer? drop ; +: emit-callback-body ( nodes -- ) + [ last #return? t assert= ] [ but-last emit-nodes ] bi ; + M: #alien-callback emit-node - params>> dup xt>> dup + dup params>> xt>> dup [ needs-frame-pointer begin-word { - [ callee-parameters ##callback-inputs ] - [ box-parameters ] - [ - [ - make-kill-block - quot>> ##alien-callback - ] emit-trivial-block - ] - [ callee-return ##callback-outputs ] - [ callback-stack-cleanup ] + [ params>> callee-parameters ##callback-inputs ] + [ params>> box-parameters ] + [ child>> emit-callback-body ] + [ params>> callee-return ##callback-outputs ] + [ params>> callback-stack-cleanup ] } cleave end-word diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 5d2c5e2e3c..5f2b75f0e0 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -161,13 +161,6 @@ IN: compiler.cfg.builder.tests { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder ] each -: count-insns ( quot insn-check -- ? ) - [ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip - count ; inline - -: contains-insn? ( quot insn-check -- ? ) - count-insns 0 > ; inline - [ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test [ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index 29498affc2..e4de7d9880 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -53,8 +53,8 @@ M: insn visit-insn drop ; : (collect-copies) ( cfg -- ) [ phis get clear-assoc - instructions>> [ visit-insn ] each - ] each-basic-block ; + [ visit-insn ] each + ] simple-analysis ; : collect-copies ( cfg -- ) H{ } clone copies set diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index b985fbb27a..db41b0c18d 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel namespaces sequences +USING: accessors arrays assocs kernel namespaces sequences compiler.cfg.instructions compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.predecessors hash-sets sets ; FROM: namespaces => set ; @@ -99,6 +99,19 @@ M: ##write-barrier live-insn? src>> live-vreg? ; M: ##write-barrier-imm live-insn? src>> live-vreg? ; +: filter-alien-outputs ( outputs -- live-outputs dead-outputs ) + [ first live-vreg? ] partition + [ first3 2array nip ] map ; + +M: alien-call-insn live-insn? + dup reg-outputs>> filter-alien-outputs [ >>reg-outputs ] [ >>dead-outputs ] bi* + drop t ; + +M: ##callback-inputs live-insn? + [ filter-alien-outputs drop ] change-reg-outputs + [ filter-alien-outputs drop ] change-stack-outputs + drop t ; + M: flushable-insn live-insn? defs-vregs [ live-vreg? ] any? ; M: insn live-insn? drop t ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index fd0a0be7d9..28036241a5 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words sequences quotations namespaces io vectors -arrays hashtables classes.tuple accessors prettyprint +arrays hashtables classes.tuple math accessors prettyprint prettyprint.config assocs prettyprint.backend prettyprint.custom prettyprint.sections parser compiler.tree.builder compiler.tree.optimizer cpu.architecture compiler.cfg.builder @@ -125,3 +125,10 @@ M: rs-loc pprint* \ R pprint-loc ; bi append ] map concat ] map concat >hashtable representations set ; + +: count-insns ( quot insn-check -- ? ) + [ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip + count ; inline + +: contains-insn? ( quot insn-check -- ? ) + count-insns 0 > ; inline diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 99e87b277b..04443db45d 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -4,7 +4,7 @@ USING: accessors assocs arrays classes combinators compiler.units fry generalizations sequences.generalizations generic kernel locals namespaces quotations sequences sets slots words compiler.cfg.instructions compiler.cfg.instructions.syntax -compiler.cfg.rpo ; +compiler.cfg.rpo compiler.cfg ; FROM: namespaces => set ; FROM: sets => members ; IN: compiler.cfg.def-use @@ -91,17 +91,17 @@ SYMBOLS: defs insns ; : compute-defs ( cfg -- ) H{ } clone [ '[ - dup instructions>> [ + [ basic-block get ] dip [ _ set-def-of ] with each - ] each-basic-block + ] simple-analysis ] keep defs set ; : compute-insns ( cfg -- ) H{ } clone [ '[ - instructions>> [ + [ dup _ set-def-of ] each - ] each-basic-block + ] simple-analysis ] keep insns set ; diff --git a/basis/compiler/cfg/dependence/dependence.factor b/basis/compiler/cfg/dependence/dependence.factor index d2e4a11c51..54f308324a 100644 --- a/basis/compiler/cfg/dependence/dependence.factor +++ b/basis/compiler/cfg/dependence/dependence.factor @@ -57,6 +57,7 @@ UNION: slot-insn UNION: memory-insn ##load-memory ##load-memory-imm ##store-memory ##store-memory-imm + ##write-barrier ##write-barrier-imm alien-call-insn slot-insn ; diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor index 2b731bdd90..a0bb29cdf0 100644 --- a/basis/compiler/cfg/finalization/finalization.factor +++ b/basis/compiler/cfg/finalization/finalization.factor @@ -2,15 +2,16 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.representations compiler.cfg.scheduling compiler.cfg.gc-checks -compiler.cfg.save-contexts compiler.cfg.ssa.destruction -compiler.cfg.build-stack-frame compiler.cfg.linear-scan -compiler.cfg.stacks.uninitialized ; +compiler.cfg.write-barrier compiler.cfg.save-contexts +compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame +compiler.cfg.linear-scan compiler.cfg.stacks.uninitialized ; IN: compiler.cfg.finalization : finalize-cfg ( cfg -- cfg' ) select-representations schedule-instructions insert-gc-checks + eliminate-write-barriers dup compute-uninitialized-sets insert-save-contexts destruct-ssa diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor index a047fc4c9d..44ede70c97 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor @@ -277,7 +277,7 @@ V{ } 0 test-bb V{ - T{ ##alien-invoke f "malloc" f T{ gc-map } } + T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } } T{ ##allot f 1 64 byte-array } T{ ##branch } } 1 test-bb @@ -299,7 +299,7 @@ V{ ! The GC check should come after the alien-invoke [ V{ - T{ ##alien-invoke f "malloc" f T{ gc-map } } + T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } } T{ ##check-nursery-branch f 64 cc<= 3 4 } } ] [ 0 get successors>> first instructions>> ] unit-test @@ -311,9 +311,9 @@ V{ } 0 test-bb V{ - T{ ##alien-invoke f "malloc" f T{ gc-map } } + T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } } T{ ##allot f 1 64 byte-array } - T{ ##alien-invoke f "malloc" f T{ gc-map } } + T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } } T{ ##allot f 2 64 byte-array } T{ ##branch } } 1 test-bb @@ -334,7 +334,7 @@ V{ [ V{ - T{ ##alien-invoke f "malloc" f T{ gc-map } } + T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } } T{ ##check-nursery-branch f 64 cc<= 3 4 } } ] [ @@ -346,7 +346,7 @@ V{ [ V{ T{ ##allot f 1 64 byte-array } - T{ ##alien-invoke f "malloc" f T{ gc-map } } + T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } } T{ ##check-nursery-branch f 64 cc<= 5 6 } } ] [ diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 5ce7124b4e..c51d41443a 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -256,17 +256,6 @@ FOLDABLE-INSN: ##sqrt def: dst/double-rep use: src/double-rep ; -! libc intrinsics -FOLDABLE-INSN: ##unary-float-function -def: dst/double-rep -use: src/double-rep -literal: func ; - -FOLDABLE-INSN: ##binary-float-function -def: dst/double-rep -use: src1/double-rep src2/double-rep -literal: func ; - ! Single/double float conversion FOLDABLE-INSN: ##single>double-float def: dst/double-rep @@ -673,21 +662,18 @@ literal: boxer gc-map ; ! { vreg rep stack#/reg } VREG-INSN: ##alien-invoke -literal: reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map ; +literal: reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map ; VREG-INSN: ##alien-indirect use: src/int-rep -literal: reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map ; +literal: reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map ; VREG-INSN: ##alien-assembly -literal: reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map ; +literal: reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot gc-map ; VREG-INSN: ##callback-inputs literal: reg-outputs stack-outputs ; -INSN: ##alien-callback -literal: quot ; - VREG-INSN: ##callback-outputs literal: reg-inputs ; @@ -886,8 +872,6 @@ alien-call-insn ! will be in a register. UNION: clobber-insn hairy-clobber-insn -##unary-float-function -##binary-float-function ##unbox ##box ##box-long-long ; diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 480b46f9b3..b4a571038c 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -9,9 +9,3 @@ IN: compiler.cfg.intrinsics.float : emit-float-unordered-comparison ( cc -- ) '[ _ ^^compare-float-unordered ] binary-op ; inline - -: emit-unary-float-function ( func -- ) - '[ _ ^^unary-float-function ] unary-op ; - -: emit-binary-float-function ( func -- ) - '[ _ ^^binary-float-function ] binary-op ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index bf8ba96c34..475edb41a4 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -123,31 +123,6 @@ IN: compiler.cfg.intrinsics { math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] } } enable-intrinsics ; -: enable-float-functions ( -- ) - { - { math.libm:facos [ drop "acos" emit-unary-float-function ] } - { math.libm:fasin [ drop "asin" emit-unary-float-function ] } - { math.libm:fatan [ drop "atan" emit-unary-float-function ] } - { math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] } - { math.libm:fcos [ drop "cos" emit-unary-float-function ] } - { math.libm:fsin [ drop "sin" emit-unary-float-function ] } - { math.libm:ftan [ drop "tan" emit-unary-float-function ] } - { math.libm:fcosh [ drop "cosh" emit-unary-float-function ] } - { math.libm:fsinh [ drop "sinh" emit-unary-float-function ] } - { math.libm:ftanh [ drop "tanh" emit-unary-float-function ] } - { math.libm:fexp [ drop "exp" emit-unary-float-function ] } - { math.libm:flog [ drop "log" emit-unary-float-function ] } - { math.libm:flog10 [ drop "log10" emit-unary-float-function ] } - { math.libm:fpow [ drop "pow" emit-binary-float-function ] } - { math.libm:facosh [ drop "acosh" emit-unary-float-function ] } - { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] } - { math.libm:fatanh [ drop "atanh" emit-unary-float-function ] } - { math.libm:fsqrt [ drop "sqrt" emit-unary-float-function ] } - { math.floats.private:float-min [ drop "fmin" emit-binary-float-function ] } - { math.floats.private:float-max [ drop "fmax" emit-binary-float-function ] } - { math.private:float-mod [ drop "fmod" emit-binary-float-function ] } - } enable-intrinsics ; - : enable-min/max ( -- ) { { math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] } diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index f102a6ae9c..89c03b34f3 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -62,8 +62,8 @@ M: live-interval handle M: sync-point handle ( sync-point -- ) [ n>> deactivate-intervals ] - [ handle-sync-point ] [ n>> activate-intervals ] + [ handle-sync-point ] tri ; : smallest-heap ( heap1 heap2 -- heap ) diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index cab4438ec9..365d4e2f21 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -39,6 +39,11 @@ SYMBOL: pending-interval-assoc drop leader vreg rep-of lookup-spill-slot ] unless ; +ERROR: not-spilled-error vreg ; + +: vreg>spill-slot ( vreg -- spill-slot ) + dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ; + : vregs>regs ( vregs -- assoc ) [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ; @@ -144,7 +149,7 @@ M: vreg-insn assign-registers-in-insn M: gc-map-insn assign-registers-in-insn [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ] - [ gc-map>> [ [ vreg>reg ] map ] change-gc-roots drop ] + [ gc-map>> [ [ vreg>spill-slot ] map ] change-gc-roots drop ] bi ; M: insn assign-registers-in-insn drop ; @@ -158,20 +163,22 @@ M: insn assign-registers-in-insn drop ; } cleave ; :: assign-registers-in-block ( bb -- ) - bb [ - [ - bb begin-block + bb kill-block?>> [ + bb [ [ - { - [ insn#>> 1 - prepare-insn ] - [ insn#>> prepare-insn ] - [ assign-registers-in-insn ] - [ , ] - } cleave - ] each - bb compute-live-out - ] V{ } make - ] change-instructions drop ; + bb begin-block + [ + { + [ insn#>> 1 - prepare-insn ] + [ insn#>> prepare-insn ] + [ assign-registers-in-insn ] + [ , ] + } cleave + ] each + bb compute-live-out + ] V{ } make + ] change-instructions drop + ] unless ; : assign-registers ( live-intervals cfg -- ) [ init-assignment ] dip diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index fbe0cd4507..41545981c2 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -171,18 +171,20 @@ M: clobber-insn compute-sync-points* M: insn compute-sync-points* drop ; : compute-live-intervals-step ( bb -- ) - { - [ block-from from set ] - [ block-to to set ] - [ handle-live-out ] - [ - instructions>> [ - [ compute-live-intervals* ] - [ compute-sync-points* ] - bi - ] each - ] - } cleave ; + dup kill-block?>> [ drop ] [ + { + [ block-from from set ] + [ block-to to set ] + [ handle-live-out ] + [ + instructions>> [ + [ compute-live-intervals* ] + [ compute-sync-points* ] + bi + ] each + ] + } cleave + ] if ; : init-live-intervals ( -- ) H{ } clone live-intervals set diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 9d3c91ca18..564c2978f5 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -99,7 +99,9 @@ SYMBOL: temp 2dup compute-mappings perform-mappings ; : resolve-block-data-flow ( bb -- ) - dup successors>> [ resolve-edge-data-flow ] with each ; + dup kill-block?>> [ drop ] [ + dup successors>> [ resolve-edge-data-flow ] with each + ] if ; : resolve-data-flow ( cfg -- ) needs-predecessors diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor index b86f04b8b0..7099d3a06e 100644 --- a/basis/compiler/cfg/liveness/liveness-tests.factor +++ b/basis/compiler/cfg/liveness/liveness-tests.factor @@ -127,7 +127,7 @@ V{ T{ ##unbox f 37 29 "alien_offset" int-rep } T{ ##unbox f 38 28 "to_double" double-rep } T{ ##unbox f 39 36 "to_cell" int-rep } - T{ ##alien-invoke f V{ } V{ { 37 int-rep 0 } { 38 double-rep 4 } { 39 int-rep 12 } } { { 40 int-rep EAX } } 0 16 "CFRunLoopRunInMode" f T{ gc-map } } + T{ ##alien-invoke f V{ } V{ { 37 int-rep 0 } { 38 double-rep 4 } { 39 int-rep 12 } } { { 40 int-rep EAX } } { } 0 16 "CFRunLoopRunInMode" f T{ gc-map } } T{ ##box f 41 40 "from_signed_cell" int-rep T{ gc-map } } T{ ##replace f 41 D 0 } T{ ##branch } diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 5881cd78ea..6a62b6f7e7 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -9,8 +9,7 @@ compiler.cfg.ssa.construction compiler.cfg.alias-analysis compiler.cfg.value-numbering compiler.cfg.copy-prop -compiler.cfg.dce -compiler.cfg.write-barrier ; +compiler.cfg.dce ; IN: compiler.cfg.optimizer : optimize-cfg ( cfg -- cfg' ) @@ -23,5 +22,4 @@ IN: compiler.cfg.optimizer alias-analysis value-numbering copy-propagation - eliminate-dead-code - eliminate-write-barriers ; + eliminate-dead-code ; diff --git a/basis/compiler/cfg/representations/coalescing/coalescing.factor b/basis/compiler/cfg/representations/coalescing/coalescing.factor index 6e31e82201..2caa485045 100644 --- a/basis/compiler/cfg/representations/coalescing/coalescing.factor +++ b/basis/compiler/cfg/representations/coalescing/coalescing.factor @@ -11,10 +11,10 @@ SYMBOL: components : init-components ( cfg components -- ) '[ - instructions>> [ + [ defs-vregs [ _ add-atom ] each ] each - ] each-basic-block ; + ] simple-analysis ; GENERIC# visit-insn 1 ( insn disjoint-set -- ) @@ -28,10 +28,10 @@ M: insn visit-insn 2drop ; : merge-components ( cfg components -- ) '[ - instructions>> [ + [ _ visit-insn ] each - ] each-basic-block ; + ] simple-analysis ; : compute-components ( cfg -- ) diff --git a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor index fe06d4c7de..0b8c5e7873 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts-tests.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts-tests.factor @@ -4,26 +4,8 @@ compiler.cfg.save-contexts kernel namespaces tools.test cpu.x86.assembler.operands cpu.architecture ; IN: compiler.cfg.save-contexts.tests -0 vreg-counter set-global H{ } clone representations set -V{ - T{ ##unary-float-function f 2 3 "sqrt" } - T{ ##branch } -} 0 test-bb - -0 get insert-save-context - -[ - V{ - T{ ##save-context f 1 2 } - T{ ##unary-float-function f 2 3 "sqrt" } - T{ ##branch } - } -] [ - 0 get instructions>> -] unit-test - V{ T{ ##add f 1 2 3 } T{ ##branch } diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor index 57691f1a4e..c14f4d46e6 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts.factor @@ -1,20 +1,22 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.rpo cpu.architecture kernel sequences vectors ; +compiler.cfg.rpo cpu.architecture kernel sequences vectors +combinators.short-circuit ; IN: compiler.cfg.save-contexts ! Insert context saves. GENERIC: needs-save-context? ( insn -- ? ) -M: ##unary-float-function needs-save-context? drop t ; -M: ##binary-float-function needs-save-context? drop t ; M: gc-map-insn needs-save-context? drop t ; M: insn needs-save-context? drop f ; : bb-needs-save-context? ( insn -- ? ) - instructions>> [ needs-save-context? ] any? ; + { + [ kill-block?>> not ] + [ instructions>> [ needs-save-context? ] any? ] + } 1&& ; GENERIC: modifies-context? ( insn -- ? ) diff --git a/basis/compiler/cfg/ssa/construction/construction-tests.factor b/basis/compiler/cfg/ssa/construction/construction-tests.factor index 54b02b7450..a011bf7bec 100644 --- a/basis/compiler/cfg/ssa/construction/construction-tests.factor +++ b/basis/compiler/cfg/ssa/construction/construction-tests.factor @@ -10,6 +10,16 @@ IN: compiler.cfg.ssa.construction.tests 0 vreg-counter set-global 0 basic-block set-global ; +: test-ssa ( -- ) + cfg new 0 get >>entry + dup cfg set + construct-ssa + drop ; + +: clean-up-phis ( insns -- insns' ) + [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ; + +! Test 1 reset-counters V{ @@ -38,12 +48,6 @@ V{ 1 3 edge 2 3 edge -: test-ssa ( -- ) - cfg new 0 get >>entry - dup cfg set - construct-ssa - drop ; - [ ] [ test-ssa ] unit-test [ @@ -69,9 +73,6 @@ V{ } ] [ 2 get instructions>> ] unit-test -: clean-up-phis ( insns -- insns' ) - [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ; - [ V{ T{ ##phi f 6 H{ { 1 4 } { 2 5 } } } @@ -83,6 +84,7 @@ V{ clean-up-phis ] unit-test +! Test 2 reset-counters V{ } 0 test-bb @@ -110,4 +112,89 @@ V{ } 6 test-bb ] [ 4 get instructions>> clean-up-phis -] unit-test \ No newline at end of file +] unit-test + +! Test 3 +reset-counters + +V{ + T{ ##branch } +} 0 test-bb + +V{ + T{ ##load-integer f 3 3 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##load-integer f 3 4 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##branch } +} 3 test-bb + +V{ + T{ ##return } +} 4 test-bb + +0 { 1 2 3 } edges +1 4 edge +2 4 edge +3 4 edge + +[ ] [ test-ssa ] unit-test + +[ V{ } ] [ 4 get instructions>> [ ##phi? ] filter ] unit-test + +! Test 4 +reset-counters + +V{ + T{ ##branch } +} 0 test-bb + +V{ + T{ ##branch } +} 1 test-bb + +V{ + T{ ##load-integer f 0 4 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##load-integer f 0 4 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##branch } +} 4 test-bb + +V{ + T{ ##branch } +} 5 test-bb + +V{ + T{ ##branch } +} 6 test-bb + +V{ + T{ ##return } +} 7 test-bb + +0 { 1 6 } edges +1 { 2 3 4 } edges +2 5 edge +3 5 edge +4 5 edge +5 7 edge +6 7 edge + +[ ] [ test-ssa ] unit-test + +[ V{ } ] [ 5 get instructions>> [ ##phi? ] filter ] unit-test + +[ V{ } ] [ 7 get instructions>> [ ##phi? ] filter ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor index 70e088e500..5793225349 100644 --- a/basis/compiler/cfg/ssa/construction/construction.factor +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel accessors sequences fry assocs -sets math combinators +sets math combinators deques dlists compiler.cfg compiler.cfg.rpo compiler.cfg.def-use -compiler.cfg.liveness compiler.cfg.registers compiler.cfg.dominance compiler.cfg.instructions @@ -15,12 +14,18 @@ compiler.cfg.ssa.construction.tdmsc ; FROM: namespaces => set ; IN: compiler.cfg.ssa.construction -! The phi placement algorithm is implemented in -! compiler.cfg.ssa.construction.tdmsc. +! Iterated dominance frontiers are computed using the DJ Graph +! method in compiler.cfg.ssa.construction.tdmsc. ! The renaming algorithm is based on "Practical Improvements to -! the Construction and Destruction of Static Single Assignment Form", -! however we construct pruned SSA, not semi-pruned SSA. +! the Construction and Destruction of Static Single Assignment +! Form". + +! We construct pruned SSA without computing live sets, by +! building a dependency graph for phi instructions, marking the +! transitive closure of a vertex as live if it is referenced by +! some non-phi instruction. Thanks to Cameron Zwarich for the +! trick. ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683 @@ -50,31 +55,32 @@ M: vreg-insn compute-insn-defs [ compute-insn-defs ] with each ] simple-analysis ; -! Maps basic blocks to sequences of vregs -SYMBOL: inserting-phi-nodes +! Maps basic blocks to sequences of ##phi instructions +SYMBOL: inserting-phis -: insert-phi-node-later ( vreg bb -- ) - 2dup live-in key? [ - [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep - inserting-phi-nodes get push-at - ] [ 2drop ] if ; +: insert-phi-later ( vreg bb -- ) + [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep + inserting-phis get push-at ; -: compute-phi-nodes-for ( vreg bbs -- ) - keys merge-set [ insert-phi-node-later ] with each ; +: compute-phis-for ( vreg bbs -- ) + keys merge-set [ insert-phi-later ] with each ; -: compute-phi-nodes ( -- ) - H{ } clone inserting-phi-nodes set - defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ; +: compute-phis ( -- ) + H{ } clone inserting-phis set + defs-multi get defs get '[ _ at compute-phis-for ] assoc-each ; -: insert-phi-nodes-in ( phis bb -- ) - [ append ] change-instructions drop ; +! Maps vregs to ##phi instructions +SYMBOL: phis -: insert-phi-nodes ( -- ) - inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ; +! Worklist of used vregs, to calculate used phis +SYMBOL: used-vregs +! Maps vregs to renaming stacks SYMBOLS: stacks pushed ; : init-renaming ( -- ) + H{ } clone phis set + used-vregs set H{ } clone stacks set ; : gen-name ( vreg -- vreg' ) @@ -84,8 +90,12 @@ SYMBOLS: stacks pushed ; [ conjoin stacks get push-at ] if ; +: (top-name) ( vreg -- vreg' ) + stacks get at [ f ] [ last ] if-empty ; + : top-name ( vreg -- vreg' ) - stacks get at last ; + (top-name) + dup [ dup used-vregs get push-front ] when ; RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ] @@ -98,17 +108,22 @@ M: vreg-insn rename-insn [ ssa-rename-insn-defs ] bi ; -M: ##phi rename-insn - ssa-rename-insn-defs ; +: rename-phis ( bb -- ) + inserting-phis get at [ + [ + [ ssa-rename-insn-defs ] + [ dup dst>> phis get set-at ] bi + ] each + ] when* ; : rename-insns ( bb -- ) instructions>> [ rename-insn ] each ; : rename-successor-phi ( phi bb -- ) - swap inputs>> [ top-name ] change-at ; + swap inputs>> [ (top-name) ] change-at ; : rename-successor-phis ( succ bb -- ) - [ inserting-phi-nodes get at ] dip + [ inserting-phis get at ] dip '[ _ rename-successor-phi ] each ; : rename-successors-phis ( bb -- ) @@ -119,26 +134,56 @@ M: ##phi rename-insn : rename-in-block ( bb -- ) H{ } clone pushed set - [ rename-insns ] - [ rename-successors-phis ] - [ - pushed get - [ dom-children [ rename-in-block ] each ] dip - pushed set - ] tri + { + [ rename-phis ] + [ rename-insns ] + [ rename-successors-phis ] + [ + pushed get + [ dom-children [ rename-in-block ] each ] dip + pushed set + ] + } cleave pop-stacks ; : rename ( cfg -- ) init-renaming entry>> rename-in-block ; +! Live phis +SYMBOL: live-phis + +: live-phi? ( ##phi -- ? ) + dst>> live-phis get key? ; + +: compute-live-phis ( -- ) + H{ } clone live-phis set + used-vregs get [ + phis get at [ + [ + dst>> + [ live-phis get conjoin ] + [ phis get delete-at ] + bi + ] + [ inputs>> [ nip used-vregs get push-front ] assoc-each ] bi + ] when* + ] slurp-deque ; + +: insert-phis-in ( phis bb -- ) + [ [ live-phi? ] filter! ] dip + [ append ] change-instructions drop ; + +: insert-phis ( -- ) + inserting-phis get + [ swap insert-phis-in ] assoc-each ; + PRIVATE> : construct-ssa ( cfg -- cfg' ) { - [ compute-live-sets ] [ compute-merge-sets ] - [ compute-defs compute-phi-nodes insert-phi-nodes ] - [ rename ] + [ compute-defs compute-phis ] + [ rename compute-live-phis insert-phis ] [ ] } cleave ; diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index bd5a84afc7..197093e5ae 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -103,12 +103,9 @@ M: ##phi prepare-insn [ dst>> ] [ inputs>> values ] bi [ maybe-eliminate-copy ] with each ; -: prepare-block ( bb -- ) - instructions>> [ prepare-insn ] each ; - : prepare-coalescing ( cfg -- ) init-coalescing - [ prepare-block ] each-basic-block ; + [ [ prepare-insn ] each ] simple-analysis ; : process-copies ( -- ) copies get [ maybe-eliminate-copy ] assoc-each ; diff --git a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor index d301b14996..ffbbf8739f 100644 --- a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor +++ b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor @@ -38,13 +38,12 @@ M: insn record-insn SYMBOLS: def-indices kill-indices ; -: compute-local-live-ranges ( bb -- ) +: compute-local-live-ranges ( insns -- ) H{ } clone local-def-indices set H{ } clone local-kill-indices set - [ instructions>> [ swap record-insn ] each-index ] - [ [ local-def-indices get ] dip def-indices get set-at ] - [ [ local-kill-indices get ] dip kill-indices get set-at ] - tri ; + [ swap record-insn ] each-index + local-def-indices get basic-block get def-indices get set-at + local-kill-indices get basic-block get kill-indices get set-at ; PRIVATE> @@ -53,7 +52,7 @@ PRIVATE> H{ } clone def-indices set H{ } clone kill-indices set - [ compute-local-live-ranges ] each-basic-block ; + [ compute-local-live-ranges ] simple-analysis ; : def-index ( vreg bb -- n ) def-indices get at at ; diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor new file mode 100644 index 0000000000..b11ffa8716 --- /dev/null +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -0,0 +1,154 @@ +USING: compiler.cfg.instructions compiler.cfg.write-barrier +tools.test ; +IN: compiler.cfg.write-barrier.tests + +! Do need a write barrier on a random store. +[ + V{ + T{ ##peek f 1 } + T{ ##set-slot f 2 1 3 } + T{ ##write-barrier f 1 3 } + } +] [ + V{ + T{ ##peek f 1 } + T{ ##set-slot f 2 1 3 } + T{ ##write-barrier f 1 3 } + } write-barriers-step +] unit-test + +[ + V{ + T{ ##peek f 1 } + T{ ##set-slot-imm f 2 1 } + T{ ##write-barrier-imm f 1 } + } +] [ + V{ + T{ ##peek f 1 } + T{ ##set-slot-imm f 2 1 } + T{ ##write-barrier-imm f 1 } + } write-barriers-step +] unit-test + +! Don't need a write barrier on freshly allocated objects. +[ + V{ + T{ ##allot f 1 } + T{ ##set-slot f 2 1 3 } + } +] [ + V{ + T{ ##allot f 1 } + T{ ##set-slot f 2 1 3 } + T{ ##write-barrier f 1 3 } + } write-barriers-step +] unit-test + +[ + V{ + T{ ##allot f 1 } + T{ ##set-slot-imm f 2 1 } + } +] [ + V{ + T{ ##allot f 1 } + T{ ##set-slot-imm f 2 1 } + T{ ##write-barrier-imm f 1 } + } write-barriers-step +] unit-test + +! Do need a write barrier if there's a subroutine call between +! the allocation and the store. +[ + V{ + T{ ##allot f 1 } + T{ ##box } + T{ ##set-slot f 2 1 3 } + T{ ##write-barrier f 1 3 } + } +] [ + V{ + T{ ##allot f 1 } + T{ ##box } + T{ ##set-slot f 2 1 3 } + T{ ##write-barrier f 1 3 } + } write-barriers-step +] unit-test + +[ + V{ + T{ ##allot f 1 } + T{ ##box } + T{ ##set-slot-imm f 2 1 } + T{ ##write-barrier-imm f 1 } + } +] [ + V{ + T{ ##allot f 1 } + T{ ##box } + T{ ##set-slot-imm f 2 1 } + T{ ##write-barrier-imm f 1 } + } write-barriers-step +] unit-test + +! ##copy instructions +[ + V{ + T{ ##copy f 2 1 } + T{ ##set-slot-imm f 3 1 } + T{ ##write-barrier-imm f 2 } + } +] [ + V{ + T{ ##copy f 2 1 } + T{ ##set-slot-imm f 3 1 } + T{ ##write-barrier-imm f 2 } + } write-barriers-step +] unit-test + +[ + V{ + T{ ##copy f 2 1 } + T{ ##set-slot-imm f 3 2 } + T{ ##write-barrier-imm f 1 } + } +] [ + V{ + T{ ##copy f 2 1 } + T{ ##set-slot-imm f 3 2 } + T{ ##write-barrier-imm f 1 } + } write-barriers-step +] unit-test + +[ + V{ + T{ ##copy f 2 1 } + T{ ##copy f 3 2 } + T{ ##set-slot-imm f 3 1 } + T{ ##write-barrier-imm f 2 } + } +] [ + V{ + T{ ##copy f 2 1 } + T{ ##copy f 3 2 } + T{ ##set-slot-imm f 3 1 } + T{ ##write-barrier-imm f 2 } + } write-barriers-step +] unit-test + +[ + V{ + T{ ##copy f 2 1 } + T{ ##copy f 3 2 } + T{ ##set-slot-imm f 4 1 } + T{ ##write-barrier-imm f 3 } + } +] [ + V{ + T{ ##copy f 2 1 } + T{ ##copy f 3 2 } + T{ ##set-slot-imm f 4 1 } + T{ ##write-barrier-imm f 3 } + } write-barriers-step +] unit-test diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index a34bf6c07f..6f8e437aa9 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -6,23 +6,39 @@ sequences sets ; FROM: namespaces => set ; IN: compiler.cfg.write-barrier +! This pass must run after GC check insertion and scheduling. + SYMBOL: fresh-allocations SYMBOL: mutated-objects +SYMBOL: copies + +: resolve-copy ( src -- dst ) + copies get ?at drop ; + GENERIC: eliminate-write-barrier ( insn -- ? ) +: fresh-allocation ( vreg -- ) + fresh-allocations get conjoin ; + M: ##allot eliminate-write-barrier - dst>> fresh-allocations get conjoin t ; + dst>> fresh-allocation t ; + +: mutated-object ( vreg -- ) + resolve-copy mutated-objects get conjoin ; M: ##set-slot eliminate-write-barrier - obj>> mutated-objects get conjoin t ; + obj>> mutated-object t ; M: ##set-slot-imm eliminate-write-barrier - obj>> mutated-objects get conjoin t ; + obj>> mutated-object t ; : needs-write-barrier? ( insn -- ? ) - { [ fresh-allocations get key? not ] [ mutated-objects get key? ] } 1&& ; + resolve-copy { + [ fresh-allocations get key? not ] + [ mutated-objects get key? ] + } 1&& ; M: ##write-barrier eliminate-write-barrier src>> needs-write-barrier? ; @@ -30,14 +46,18 @@ M: ##write-barrier eliminate-write-barrier M: ##write-barrier-imm eliminate-write-barrier src>> needs-write-barrier? ; +M: gc-map-insn eliminate-write-barrier + fresh-allocations get clear-assoc ; + M: ##copy eliminate-write-barrier - "Run copy propagation first" throw ; + [ src>> resolve-copy ] [ dst>> ] bi copies get set-at t ; M: insn eliminate-write-barrier drop t ; : write-barriers-step ( insns -- insns' ) H{ } clone fresh-allocations set H{ } clone mutated-objects set + H{ } clone copies set [ eliminate-write-barrier ] filter! ; : eliminate-write-barriers ( cfg -- cfg ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 1d7f9eb14e..6e7e2e0fab 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -170,8 +170,6 @@ CODEGEN: ##div-float %div-float CODEGEN: ##min-float %min-float CODEGEN: ##max-float %max-float CODEGEN: ##sqrt %sqrt -CODEGEN: ##unary-float-function %unary-float-function -CODEGEN: ##binary-float-function %binary-float-function CODEGEN: ##single>double-float %single>double-float CODEGEN: ##double>single-float %double>single-float CODEGEN: ##integer>float %integer>float @@ -293,5 +291,4 @@ CODEGEN: ##alien-invoke %alien-invoke CODEGEN: ##alien-indirect %alien-indirect CODEGEN: ##alien-assembly %alien-assembly CODEGEN: ##callback-inputs %callback-inputs -CODEGEN: ##alien-callback %alien-callback CODEGEN: ##callback-outputs %callback-outputs diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index d2c51c2302..65e67e66d2 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -45,6 +45,8 @@ FUNCTION: void ffi_test_0 ; FUNCTION: int ffi_test_1 ; [ 3 ] [ ffi_test_1 ] unit-test +[ ] [ \ ffi_test_1 def>> [ drop ] append compile-call ] unit-test + FUNCTION: int ffi_test_2 int x int y ; [ 5 ] [ 2 3 ffi_test_2 ] unit-test [ "hi" 3 ffi_test_2 ] must-fail @@ -821,3 +823,25 @@ TUPLE: some-tuple x ; aa-indirect-1 >>x ] compile-call ] unit-test + +! Write barrier elimination was being done before scheduling and +! GC check insertion, and didn't take subroutine calls into +! account. Oops... +: write-barrier-elim-in-wrong-place ( -- obj ) + ! A callback used below + void { } cdecl [ compact-gc ] alien-callback + ! Allocate an object A in the nursery + 1 f + ! Subroutine call promotes the object to tenured + swap void { } cdecl alien-indirect + ! Allocate another object B in the nursery, store it into + ! the first + 1 f over set-first + ! Now object A's card should be marked and minor GC should + ! promote B to aging + minor-gc + ! Do stuff + [ 100 [ ] times ] infer. + ; + +[ { { f } } ] [ write-barrier-elim-in-wrong-place ] unit-test diff --git a/basis/compiler/tests/linkage-errors.factor b/basis/compiler/tests/linkage-errors.factor index fc59f6552e..94c0a1d5aa 100644 --- a/basis/compiler/tests/linkage-errors.factor +++ b/basis/compiler/tests/linkage-errors.factor @@ -1,5 +1,5 @@ USING: tools.test namespaces assocs alien.syntax kernel -compiler.errors accessors alien ; +compiler.errors accessors alien alien.c-types ; FROM: alien.libraries => add-library ; IN: compiler.tests.linkage-errors diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 23b615f1ae..c3fd37c48a 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -5,7 +5,8 @@ quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors compiler.tree.builder compiler.tree.optimizer sequences.deep compiler.test definitions generic.single shuffle math.order -compiler.cfg.debugger classes.struct alien.syntax alien.data ; +compiler.cfg.debugger classes.struct alien.syntax alien.data +alien.c-types ; IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) @@ -291,6 +292,9 @@ PREDICATE: list < improper-list [ list instance? ] compile-call ] unit-test +! type function bustage +[ T{ cons } 7 ] [ cons tuple-layout [ [ ] [ length ] bi ] compile-call ] unit-test + ! Regression : interval-inference-bug ( obj -- obj x ) dup "a" get { array-capacity } declare >= diff --git a/basis/compiler/tests/redefine25.factor b/basis/compiler/tests/redefine25.factor new file mode 100644 index 0000000000..bf25a7ece0 --- /dev/null +++ b/basis/compiler/tests/redefine25.factor @@ -0,0 +1,34 @@ +USING: tools.test compiler.units classes.mixin definitions +kernel kernel.private ; +IN: compiler.tests.redefine25 + +MIXIN: empty-mixin + +: empty-mixin-test-1 ( a -- ? ) empty-mixin? ; + +TUPLE: a-superclass ; + +: empty-mixin-test-2 ( a -- ? ) { a-superclass } declare empty-mixin? ; + +TUPLE: empty-mixin-member < a-superclass ; + +[ f ] [ empty-mixin-member new empty-mixin? ] unit-test +[ f ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test +[ f ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test + +[ ] [ + [ + \ empty-mixin-member \ empty-mixin add-mixin-instance + ] with-compilation-unit +] unit-test + +[ t ] [ empty-mixin-member new empty-mixin? ] unit-test +[ t ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test +[ t ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test + +[ ] [ + [ + \ empty-mixin forget + \ empty-mixin-member forget + ] with-compilation-unit +] unit-test diff --git a/basis/compiler/tests/x87-regression.factor b/basis/compiler/tests/x87-regression.factor new file mode 100644 index 0000000000..9692f787f2 --- /dev/null +++ b/basis/compiler/tests/x87-regression.factor @@ -0,0 +1,10 @@ +IN: compiler.tests.x87-regression +USING: math.floats.env alien.syntax alien.c-types compiler.test +tools.test kernel math ; + +LIBRARY: libm +FUNCTION: double sqrt ( double x ) ; + +[ { } ] [ + 4.0 [ [ 100 [ dup sqrt drop ] times ] collect-fp-exceptions nip ] compile-call +] unit-test diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 024a7bacca..d173550450 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -20,10 +20,6 @@ M: callable (build-tree) infer-quot-here ; : check-no-compile ( word -- ) dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ; -: check-effect ( word effect -- ) - swap required-stack-effect 2dup effect<= - [ 2drop ] [ effect-error ] if ; - : inline-recursive? ( word -- ? ) [ "inline" word-prop ] [ "recursive" word-prop ] bi and ; @@ -33,7 +29,7 @@ M: callable (build-tree) infer-quot-here ; M: word (build-tree) [ check-no-compile ] [ word-body infer-quot-here ] - [ current-effect check-effect ] tri ; + [ required-stack-effect check-effect ] tri ; : build-tree-with ( in-stack word/quot -- nodes ) [ diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index a3a19b8f4d..314e7ad1db 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -188,7 +188,7 @@ M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; -M: #alien-callback check-stack-flow* drop ; +M: #alien-callback check-stack-flow* child>> check-stack-flow ; M: #declare check-stack-flow* drop ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 05f9092ee1..88e7895c89 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -519,3 +519,30 @@ cell-bits 32 = [ 14 ndrop ] cleaned-up-tree nodes>quot ] unit-test + +USING: alien alien.c-types ; + +[ t ] [ + [ int { } cdecl [ 2 2 + ] alien-callback ] + { + } inlined? +] unit-test + +[ t ] [ + [ double { double double } cdecl [ + ] alien-callback ] + \ + inlined? +] unit-test + +[ f ] [ + [ double { double double } cdecl [ + ] alien-callback ] + \ float+ inlined? +] unit-test + +[ f ] [ + [ char { char char } cdecl [ + ] alien-callback ] + \ fixnum+fast inlined? +] unit-test + +[ t ] [ + [ void { } cdecl [ ] alien-callback void { } cdecl alien-indirect ] + \ >c-ptr inlined? +] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index b69f053898..616a848366 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -182,4 +182,7 @@ M: #recursive cleanup* [ cleanup ] change-child dup label>> calls>> empty? [ flatten-recursive ] when ; +M: #alien-callback cleanup* + [ cleanup ] change-child ; + M: node cleanup* ; diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor index 69c48c5f94..596cf7fd20 100644 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/basis/compiler/tree/combinators/combinators.factor @@ -1,46 +1,47 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs fry kernel accessors sequences compiler.utilities -arrays stack-checker.inlining namespaces compiler.tree -math.order ; +USING: assocs combinators combinators.short-circuit fry kernel +locals accessors sequences compiler.utilities arrays +stack-checker.inlining namespaces compiler.tree math.order ; IN: compiler.tree.combinators -: each-node ( ... nodes quot: ( ... node -- ... ) -- ... ) - dup dup '[ - _ [ - dup #branch? [ - children>> [ _ each-node ] each - ] [ - dup #recursive? [ - child>> _ each-node - ] [ drop ] if - ] if +:: each-node ( ... nodes quot: ( ... node -- ... ) -- ... ) + nodes [ + quot + [ + { + { [ dup #branch? ] [ children>> [ quot each-node ] each ] } + { [ dup #recursive? ] [ child>> quot each-node ] } + { [ dup #alien-callback? ] [ child>> quot each-node ] } + [ drop ] + } cond ] bi ] each ; inline recursive -: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes ) - dup dup '[ - @ - dup #branch? [ - [ [ _ map-nodes ] map ] change-children - ] [ - dup #recursive? [ - [ _ map-nodes ] change-child - ] when - ] if +:: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes ) + nodes [ + quot call + { + { [ dup #branch? ] [ [ [ quot map-nodes ] map ] change-children ] } + { [ dup #recursive? ] [ [ quot map-nodes ] change-child ] } + { [ dup #alien-callback? ] [ [ quot map-nodes ] change-child ] } + [ ] + } cond ] map-flat ; inline recursive -: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? ) - dup dup '[ - _ keep swap [ drop t ] [ - dup #branch? [ - children>> [ _ contains-node? ] any? - ] [ - dup #recursive? [ - child>> _ contains-node? - ] [ drop f ] if - ] if - ] if +:: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? ) + nodes [ + { + quot + [ + { + { [ dup #branch? ] [ children>> [ quot contains-node? ] any? ] } + { [ dup #recursive? ] [ child>> quot contains-node? ] } + { [ dup #alien-callback? ] [ child>> quot contains-node? ] } + [ drop f ] + } cond + ] + } 1|| ] any? ; inline recursive : select-children ( seq flags -- seq' ) diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor index 5582f4dc6f..46da6232df 100644 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -117,3 +117,6 @@ M: #terminate remove-dead-code* M: #alien-node remove-dead-code* maybe-drop-dead-outputs ; + +M: #alien-callback remove-dead-code* + [ (remove-dead-code) ] change-child ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 7350a35de9..06b5cc927c 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -4,7 +4,7 @@ USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays prettyprint prettyprint.backend prettyprint.custom prettyprint.sections math words combinators -combinators.short-circuit io sorting hints +combinators.short-circuit io sorting hints sets compiler.tree compiler.tree.recursive compiler.tree.normalization @@ -22,6 +22,7 @@ compiler.tree.identities compiler.tree.dead-code compiler.tree.modular-arithmetic ; FROM: fry => _ ; +FROM: namespaces => set ; RENAME: _ match => __ IN: compiler.tree.debugger @@ -128,7 +129,8 @@ M: #alien-indirect node>quot params>> , \ #alien-indirect , ; M: #alien-assembly node>quot params>> , \ #alien-assembly , ; -M: #alien-callback node>quot params>> , \ #alien-callback , ; +M: #alien-callback node>quot + [ params>> , ] [ child>> nodes>quot , ] bi \ #alien-callback , ; M: node node>quot drop ; @@ -222,7 +224,6 @@ SYMBOL: node-count ] with-scope ; : inlined? ( quot seq/word -- ? ) - [ cleaned-up-tree ] dip - dup word? [ 1array ] when - '[ dup #call? [ word>> _ member? ] [ drop f ] if ] - contains-node? not ; + dup word? [ 1array ] when swap + [ cleaned-up-tree [ dup #call? [ word>> , ] [ drop ] if ] each-node ] V{ } make + intersect empty? ; diff --git a/basis/compiler/tree/escape-analysis/nodes/nodes.factor b/basis/compiler/tree/escape-analysis/nodes/nodes.factor index 4c9dc1ade7..6fcfa16261 100644 --- a/basis/compiler/tree/escape-analysis/nodes/nodes.factor +++ b/basis/compiler/tree/escape-analysis/nodes/nodes.factor @@ -13,7 +13,7 @@ SYMBOL: next-node : each-with-next ( ... seq quot: ( ... elt -- ... ) -- ... ) dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline -: (escape-analysis) ( node -- ) +: (escape-analysis) ( nodes -- ) [ [ node-defs-values introduce-values ] [ escape-analysis* ] diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index 9634bdf259..ecdd10fee7 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -100,4 +100,5 @@ M: #alien-node escape-analysis* [ out-d>> unknown-allocations ] bi ; -M: #alien-callback escape-analysis* drop ; +M: #alien-callback escape-analysis* + child>> (escape-analysis) ; diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index 7912fce1f6..bfacae6ad5 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -109,8 +109,13 @@ M: #call-recursive normalize* M: node normalize* ; : normalize ( nodes -- nodes' ) - dup count-introductions make-values - H{ } clone rename-map set - [ (normalize) ] [ nip ] 2bi - [ #introduce prefix ] unless-empty - rename-node-values ; + [ + dup count-introductions make-values + H{ } clone rename-map set + [ (normalize) ] [ nip ] 2bi + [ #introduce prefix ] unless-empty + rename-node-values + ] with-scope ; + +M: #alien-callback normalize* + [ normalize ] change-child ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 09750d9d3f..baa241f9c5 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -319,10 +319,9 @@ generic-comparison-ops [ ] [ 2drop object-info ] if ] "outputs" set-word-prop -{ facos fasin fatan fatan2 fcos fsin ftan fcosh fsinh ftanh fexp -flog fpow fsqrt facosh fasinh fatanh } [ - { float } "default-output-classes" set-word-prop -] each +! Unlike the other words in math.libm, fsqrt is not inline +! since it has an intrinsic, so we need to give it outputs here. +\ fsqrt { float } "default-output-classes" set-word-prop ! Find a less repetitive way of doing this \ float-min { float float } "input-classes" set-word-prop diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor index c3f5312601..1827881e9a 100644 --- a/basis/compiler/tree/propagation/nodes/nodes.factor +++ b/basis/compiler/tree/propagation/nodes/nodes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences accessors kernel assocs compiler.tree @@ -16,7 +16,7 @@ GENERIC: annotate-node ( node -- ) GENERIC: propagate-around ( node -- ) -: (propagate) ( node -- ) +: (propagate) ( nodes -- ) [ [ compute-copy-equiv ] [ propagate-around ] bi ] each ; : extract-value-info ( values -- assoc ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index e738a70fc3..35c6ef8d2a 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,12 +9,18 @@ compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays system sorting math.libm math.floats.private math.integers.private math.intervals quotations effects alien alien.data sets -strings.private ; +strings.private vocabs ; FROM: math => float ; SPECIALIZED-ARRAY: double SPECIALIZED-ARRAY: void* IN: compiler.tree.propagation.tests +[ { } ] [ + all-words [ + "input-classes" word-prop [ class? ] all? not + ] filter +] unit-test + [ V{ } ] [ [ ] final-classes ] unit-test [ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index ce169233c1..d6fcc9cca4 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -93,7 +93,7 @@ M: #declare propagate-before recover ; : predicate-output-infos/class ( info class -- info ) - [ class>> ] dip compare-classes + [ class>> ] dip evaluate-class-predicate dup +incomparable+ eq? [ drop object-info ] [ ] if ; : predicate-output-infos ( info class -- info ) @@ -153,4 +153,6 @@ M: #call propagate-after M: #alien-node propagate-before propagate-alien-invoke ; +M: #alien-callback propagate-around child>> (propagate) ; + M: #return annotate-node dup in-d>> (annotate-node) ; diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index 4c4220f238..967d5c9a33 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test kernel combinators.short-circuit math sequences accessors +USING: tools.test kernel combinators.short-circuit math sequences accessors make compiler.tree compiler.tree.builder compiler.tree.combinators @@ -12,22 +12,24 @@ IN: compiler.tree.recursive.tests [ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test : label-is-loop? ( nodes word -- ? ) - [ - { - [ drop #recursive? ] - [ drop label>> loop?>> ] - [ swap label>> word>> eq? ] - } 2&& - ] curry contains-node? ; + swap [ + [ + dup { + [ #recursive? ] + [ label>> loop?>> ] + } 1&& [ label>> word>> , ] [ drop ] if + ] each-node + ] V{ } make member? ; : label-is-not-loop? ( nodes word -- ? ) - [ - { - [ drop #recursive? ] - [ drop label>> loop?>> not ] - [ swap label>> word>> eq? ] - } 2&& - ] curry contains-node? ; + swap [ + [ + dup { + [ #recursive? ] + [ label>> loop?>> not ] + } 1&& [ label>> word>> , ] [ drop ] if + ] each-node + ] V{ } make member? ; : loop-test-1 ( a -- ) dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor index 70c4fb44d9..ccd4b47643 100644 --- a/basis/compiler/tree/recursive/recursive.factor +++ b/basis/compiler/tree/recursive/recursive.factor @@ -61,6 +61,9 @@ M: #recursive node-call-graph M: #branch node-call-graph children>> [ (build-call-graph) ] with each ; +M: #alien-callback node-call-graph + child>> (build-call-graph) ; + M: node node-call-graph 2drop ; SYMBOLS: not-loops recursive-nesting ; diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor index a1d1b4db61..d75b6ae6cf 100644 --- a/basis/compiler/tree/tree.factor +++ b/basis/compiler/tree/tree.factor @@ -154,10 +154,11 @@ TUPLE: #alien-assembly < #alien-node in-d out-d ; : #alien-assembly ( params -- node ) \ #alien-assembly new-alien-node ; -TUPLE: #alien-callback < node params ; +TUPLE: #alien-callback < node params child ; -: #alien-callback ( params -- node ) +: #alien-callback ( params child -- node ) \ #alien-callback new + swap >>child swap >>params ; : node, ( node -- ) stack-visitor get push ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index e6d42f0289..6f70035fed 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -5,7 +5,7 @@ compiler.tree.cleanup compiler.tree.escape-analysis compiler.tree.tuple-unboxing compiler.tree.checker compiler.tree.def-use kernel accessors sequences math math.private sorting math.order binary-search sequences.private -slots.private ; +slots.private alien alien.c-types ; IN: compiler.tree.tuple-unboxing.tests : test-unboxing ( quot -- ) @@ -35,6 +35,7 @@ TUPLE: empty-tuple ; [ 1 cons boa over [ "A" throw ] when car>> ] [ [ <=> ] sort ] [ [ <=> ] with search ] + [ cons boa car>> void { } cdecl [ ] alien-callback ] } [ [ ] swap [ test-unboxing ] curry unit-test ] each ! A more complicated example diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index 177a00b8c3..57470209b6 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -42,6 +42,7 @@ $nl parallel-cleave parallel-spread parallel-napply -} ; +} +"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjuction with the above combinators to limit the maximum number of concurrent operations." ; ABOUT: "concurrency.combinators" diff --git a/basis/concurrency/distributed/distributed-docs.factor b/basis/concurrency/distributed/distributed-docs.factor index 8ea7153b0b..80e07027ce 100644 --- a/basis/concurrency/distributed/distributed-docs.factor +++ b/basis/concurrency/distributed/distributed-docs.factor @@ -1,22 +1,9 @@ USING: help.markup help.syntax concurrency.messaging threads ; IN: concurrency.distributed -HELP: local-node -{ $var-description "A variable containing the node the current thread is running on." } ; - -HELP: start-node -{ $values { "port" "a port number between 0 and 65535" } } -{ $description "Starts a node server for receiving messages from remote Factor instances." } ; - ARTICLE: "concurrency.distributed.example" "Distributed Concurrency Example" -"For a Factor instance to be able to send and receive distributed " -"concurrency messages it must first have " { $link start-node } " called." -$nl -"In one factor instance call " { $link start-node } " with the port 9000, " -"and in another with the port 9001." -$nl "In this example the Factor instance associated with port 9000 will run " -"a thread that sits receiving messages and printing the received message " +"a thread that receives and prints messages " "in the listener. The code to start the thread is: " { $examples { $unchecked-example @@ -50,12 +37,10 @@ $nl " or " { $link reply } " call." ; ARTICLE: "concurrency.distributed" "Distributed message passing" -"The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing, inspired by Erlang and Termite." -{ $subsections start-node } +"The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing, inspired by Erlang and Termite." $nl "Instances of " { $link thread } " can be sent to remote threads, at which point they are converted to objects holding the thread ID and the current node's host name:" { $subsections remote-thread } "The " { $vocab-link "serialize" } " vocabulary is used to convert Factor objects to byte arrays for transfer over a socket." { $subsections "concurrency.distributed.example" } ; - ABOUT: "concurrency.distributed" diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor index 1a46d0e38f..3a6693c440 100644 --- a/basis/concurrency/distributed/distributed-tests.factor +++ b/basis/concurrency/distributed/distributed-tests.factor @@ -1,33 +1,39 @@ USING: tools.test concurrency.distributed kernel io.files -io.files.temp io.directories arrays io.sockets system +io.files.temp io.directories arrays io.sockets system calendar combinators threads math sequences concurrency.messaging -continuations accessors prettyprint ; +continuations accessors prettyprint io.servers.connection ; FROM: concurrency.messaging => receive send ; IN: concurrency.distributed.tests -: test-node ( -- addrspec ) +CONSTANT: test-ip "127.0.0.1" + +: test-node-server ( -- threaded-server ) { { [ os unix? ] [ "distributed-concurrency-test" temp-file ] } - { [ os windows? ] [ "127.0.0.1" 1238 ] } + { [ os windows? ] [ test-ip 0 ] } + } cond ; + +: test-node-client ( -- addrspec ) + { + { [ os unix? ] [ "distributed-concurrency-test" temp-file ] } + { [ os windows? ] [ test-ip insecure-port ] } } cond ; + [ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test -[ ] [ test-node dup (start-node) ] unit-test +test-node-server [ + [ ] [ + [ + receive first2 [ 3 + ] dip send + "thread-a" unregister-remote-thread + ] "Thread A" spawn + "thread-a" register-remote-thread + ] unit-test -[ ] [ - [ - receive first2 [ 3 + ] dip send - "thread-a" unregister-remote-thread - ] "Thread A" spawn - "thread-a" register-remote-thread -] unit-test - -[ 8 ] [ - 5 self 2array - test-node "thread-a" send - - receive -] unit-test - -[ ] [ test-node stop-node ] unit-test + [ 8 ] [ + 5 self 2array + test-node-client "thread-a" send + 100 seconds receive-timeout + ] unit-test +] with-threaded-server \ No newline at end of file diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor index 229cea8548..f18f5279ea 100644 --- a/basis/concurrency/distributed/distributed.factor +++ b/basis/concurrency/distributed/distributed.factor @@ -22,8 +22,6 @@ PRIVATE> : get-remote-thread ( name -- thread ) dup registered-remote-threads at [ ] [ threads at ] ?if ; -SYMBOL: local-node - : handle-node-client ( -- ) deserialize [ first2 get-remote-thread send ] [ stop-this-server ] if* ; @@ -34,12 +32,6 @@ SYMBOL: local-node "concurrency.distributed" >>name [ handle-node-client ] >>handler ; -: (start-node) ( addrspec addrspec -- ) - local-node set-global start-server* ; - -: start-node ( port -- ) - host-name over (start-node) ; - TUPLE: remote-thread node id ; C: remote-thread @@ -52,8 +44,7 @@ M: remote-thread send ( message thread -- ) send-remote-message ; M: thread (serialize) ( obj -- ) - id>> [ local-node get-global ] dip - (serialize) ; + id>> [ insecure-addr ] dip (serialize) ; : stop-node ( node -- ) f swap send-remote-message ; diff --git a/basis/concurrency/semaphores/semaphores-docs.factor b/basis/concurrency/semaphores/semaphores-docs.factor index 343adb00c9..a922431d48 100644 --- a/basis/concurrency/semaphores/semaphores-docs.factor +++ b/basis/concurrency/semaphores/semaphores-docs.factor @@ -2,7 +2,7 @@ IN: concurrency.semaphores USING: help.markup help.syntax kernel quotations calendar ; HELP: semaphore -{ $class-description "The class of counting semaphores." } ; +{ $class-description "The class of counting semaphores. New instances can be created by calling " { $link } "." } ; HELP: { $values { "n" "a non-negative integer" } { "semaphore" semaphore } } @@ -29,19 +29,39 @@ HELP: with-semaphore { $values { "semaphore" semaphore } { "quot" quotation } } { $description "Calls the quotation with the semaphore held." } ; -ARTICLE: "concurrency.semaphores" "Counting semaphores" -"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $vocab-link "concurrency.locks" } ", since locks can be thought of as semaphores with an initial count of 1." -$nl +ARTICLE: "concurrency.semaphores.examples" "Semaphore examples" "A use-case would be a batch processing server which runs a large number of jobs which perform calculations but then need to fire off expensive external processes or perform heavy network I/O. While for most of the time, the threads can all run in parallel, it might be desired that the expensive operation is not run by more than 10 threads at once, to avoid thrashing swap space or saturating the network. This can be accomplished with a counting semaphore:" { $code "SYMBOL: expensive-section" - "10 expensive-section set-global" - "requests [" + "requests" + "10 '[" " ..." - " expensive-section [ do-expensive-stuff ] with-semaphore" + " _ [ do-expensive-stuff ] with-semaphore" " ..." "] parallel-map" } +"Here is a concrete example which fetches content from 5 different web sites, making no more than 3 requests at a time:" +{ $code + """USING: concurrency.combinators concurrency.semaphores +fry http.client kernel urls ; + +{ + URL" http://www.apple.com" + URL" http://www.google.com" + URL" http://www.ibm.com" + URL" http://www.hp.com" + URL" http://www.oracle.com" +} +2 '[ + _ [ + http-get nip + ] with-semaphore +] parallel-map""" +} ; + +ARTICLE: "concurrency.semaphores" "Counting semaphores" +"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $vocab-link "concurrency.locks" } ", since locks can be thought of as semaphores with an initial count of 1." +{ $subsections "concurrency.semaphores.examples" } "Creating semaphores:" { $subsections semaphore diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index d40450e298..4f6e2677f3 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -292,8 +292,6 @@ HOOK: %div-float cpu ( dst src1 src2 -- ) HOOK: %min-float cpu ( dst src1 src2 -- ) HOOK: %max-float cpu ( dst src1 src2 -- ) HOOK: %sqrt cpu ( dst src -- ) -HOOK: %unary-float-function cpu ( dst src func -- ) -HOOK: %binary-float-function cpu ( dst src1 src2 func -- ) HOOK: %single>double-float cpu ( dst src -- ) HOOK: %double>single-float cpu ( dst src -- ) @@ -602,16 +600,14 @@ HOOK: %save-context cpu ( temp1 temp2 -- ) HOOK: %c-invoke cpu ( symbols dll gc-map -- ) -HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- ) +HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map -- ) -HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- ) +HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map -- ) -HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- ) +HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot gc-map -- ) HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- ) -HOOK: %alien-callback cpu ( quot -- ) - HOOK: %callback-outputs cpu ( reg-inputs -- ) HOOK: stack-cleanup cpu ( stack-size return abi -- n ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 3808fb47ba..0f93e5e4a4 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -148,6 +148,13 @@ M: x86.32 %store-reg-param ( vreg rep reg -- ) { double-rep [ drop \ FLDL double-rep store-float-return ] } } case ; +M: x86.32 %discard-reg-param ( rep reg -- ) + drop { + { int-rep [ ] } + { float-rep [ ST0 FSTP ] } + { double-rep [ ST0 FSTP ] } + } case ; + :: call-unbox-func ( src func -- ) EAX src tagged-rep %copy 4 save-vm-ptr @@ -186,25 +193,10 @@ M: x86.32 %begin-callback ( -- ) 4 stack@ 0 MOV "begin_callback" f f %c-invoke ; -M: x86.32 %alien-callback ( quot -- ) - [ EAX ] dip %load-reference - EAX quot-entry-point-offset [+] CALL ; - M: x86.32 %end-callback ( -- ) 0 save-vm-ptr "end_callback" f f %c-invoke ; -M:: x86.32 %unary-float-function ( dst src func -- ) - src double-rep 0 %store-stack-param - func "libm" load-library f %c-invoke - dst double-rep %load-return ; - -M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) - src1 double-rep 0 %store-stack-param - src2 double-rep 8 %store-stack-param - func "libm" load-library f %c-invoke - dst double-rep %load-return ; - : funny-large-struct-return? ( return abi -- ? ) #! MINGW ABI incompatibility disaster [ large-struct? ] [ mingw eq? os windows? not or ] bi* and ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor old mode 100644 new mode 100755 index fdcf5ca25f..95481712ca --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -64,9 +64,6 @@ IN: bootstrap.x86 ds-reg ctx-reg context-datastack-offset [+] MOV rs-reg ctx-reg context-retainstack-offset [+] MOV ; -: jit-scrub-return ( n -- ) - ESP swap [+] 0 MOV ; - [ ! ctx-reg is preserved across the call because it is non-volatile ! in the C ABI @@ -115,24 +112,28 @@ IN: bootstrap.x86 ! Windows-specific setup ctx-reg jit-update-seh - ! Clear x87 stack, but preserve rounding mode and exception flags - ESP 2 SUB - ESP [] FNSTCW - FNINIT - ESP [] FLDCW - ESP 2 ADD - ! Load arguments EAX ESP stack-frame-size [+] MOV EDX ESP stack-frame-size 4 + [+] MOV ! Unwind stack frames ESP EDX MOV - 0 jit-scrub-return jit-jump-quot ] \ unwind-native-frames define-sub-primitive +[ + ESP 2 SUB + ESP [] FNSTCW + FNINIT + AX ESP [] MOV + ESP 2 ADD +] \ fpu-state define-sub-primitive + +[ + ESP stack-frame-size [+] FLDCW +] \ set-fpu-state define-sub-primitive + [ ! Load callstack object temp3 ds-reg [] MOV @@ -251,11 +252,9 @@ IN: bootstrap.x86 ! Contexts : jit-switch-context ( reg -- ) - -4 jit-scrub-return - - ! Save ds, rs registers - jit-load-vm - jit-save-context + ! Reset return value since its bogus right now, to avoid + ! confusing the GC + ESP -4 [+] 0 MOV ! Make the new context the current one ctx-reg swap MOV @@ -277,6 +276,10 @@ IN: bootstrap.x86 EDX ds-reg -4 [+] MOV ds-reg 8 SUB + ! Save ds, rs registers + jit-load-vm + jit-save-context + ! Make the new context active EAX jit-switch-context @@ -292,23 +295,30 @@ IN: bootstrap.x86 [ jit-set-context ] \ (set-context) define-sub-primitive +: jit-save-quot-and-param ( -- ) + EDX ds-reg MOV + ds-reg 8 SUB ; + +: jit-push-param ( -- ) + EAX EDX -4 [+] MOV + ds-reg 4 ADD + ds-reg [] EAX MOV ; + : jit-start-context ( -- ) ! Create the new context in return-reg jit-load-vm + jit-save-context ESP [] vm-reg MOV "new_context" jit-call - ! Save pointer to quotation and parameter - EDX ds-reg MOV - ds-reg 8 SUB + jit-save-quot-and-param ! Make the new context active + jit-load-vm + jit-save-context EAX jit-switch-context - ! Push parameter - EAX EDX -4 [+] MOV - ds-reg 4 ADD - ds-reg [] EAX MOV + jit-push-param ! Windows-specific setup jit-install-seh @@ -334,7 +344,20 @@ IN: bootstrap.x86 jit-set-context ] \ (set-context-and-delete) define-sub-primitive +: jit-start-context-and-delete ( -- ) + jit-load-vm + jit-load-context + ESP [] vm-reg MOV + ESP 4 [+] ctx-reg MOV + "reset_context" jit-call + + jit-save-quot-and-param + ctx-reg jit-switch-context + jit-push-param + + EAX EDX [] MOV + jit-jump-quot ; + [ - jit-delete-current-context - jit-start-context + jit-start-context-and-delete ] \ (start-context-and-delete) define-sub-primitive diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index fad1a747e6..f4a2d05f8d 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -95,6 +95,9 @@ M:: x86.64 %load-reg-param ( vreg rep reg -- ) M:: x86.64 %store-reg-param ( vreg rep reg -- ) reg vreg rep %copy ; +M: x86.64 %discard-reg-param ( rep reg -- ) + 2drop ; + M:: x86.64 %unbox ( dst src func rep -- ) param-reg-0 src tagged-rep %copy param-reg-1 %mov-vm-ptr @@ -116,30 +119,10 @@ M: x86.64 %begin-callback ( -- ) param-reg-1 0 MOV "begin_callback" f f %c-invoke ; -M: x86.64 %alien-callback ( quot -- ) - [ param-reg-0 ] dip %load-reference - param-reg-0 quot-entry-point-offset [+] CALL ; - M: x86.64 %end-callback ( -- ) param-reg-0 %mov-vm-ptr "end_callback" f f %c-invoke ; -: float-function-param ( i src -- ) - [ float-regs cdecl param-regs at nth ] dip double-rep %copy ; - -M:: x86.64 %unary-float-function ( dst src func -- ) - 0 src float-function-param - func "libm" load-library f %c-invoke - dst double-rep %load-return ; - -M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) - ! src1 might equal dst; otherwise it will be a spill slot - ! src2 is always a spill slot - 0 src1 float-function-param - 1 src2 float-function-param - func "libm" load-library f %c-invoke - dst double-rep %load-return ; - M: x86.64 %prepare-var-args ( -- ) RAX RAX XOR ; M: x86.64 stack-cleanup 3drop 0 ; diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor old mode 100644 new mode 100755 index 308546131a..f3de6b900e --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -62,9 +62,6 @@ IN: bootstrap.x86 ds-reg ctx-reg context-datastack-offset [+] MOV rs-reg ctx-reg context-retainstack-offset [+] MOV ; -: jit-scrub-return ( n -- ) - RSP swap [+] 0 MOV ; - [ ! ctx-reg is preserved across the call because it is non-volatile ! in the C ABI @@ -102,15 +99,8 @@ IN: bootstrap.x86 \ (call) define-combinator-primitive [ - ! Clear x87 stack, but preserve rounding mode and exception flags - RSP 2 SUB - RSP [] FNSTCW - FNINIT - RSP [] FLDCW - ! Unwind stack frames RSP arg2 MOV - 0 jit-scrub-return ! Load VM pointer into vm-reg, since we're entering from ! C code @@ -124,6 +114,21 @@ IN: bootstrap.x86 jit-jump-quot ] \ unwind-native-frames define-sub-primitive +[ + RSP 2 SUB + RSP [] FNSTCW + FNINIT + AX RSP [] MOV + RSP 2 ADD +] \ fpu-state define-sub-primitive + +[ + RSP 2 SUB + RSP [] arg1 16-bit-version-of MOV + RSP [] FLDCW + RSP 2 ADD +] \ set-fpu-state define-sub-primitive + [ ! Load callstack object arg4 ds-reg [] MOV @@ -228,10 +233,9 @@ IN: bootstrap.x86 ! Contexts : jit-switch-context ( reg -- ) - -8 jit-scrub-return - - ! Save ds, rs registers - jit-save-context + ! Reset return value since its bogus right now, to avoid + ! confusing the GC + RSP -8 [+] 0 MOV ! Make the new context the current one ctx-reg swap MOV @@ -257,6 +261,7 @@ IN: bootstrap.x86 : jit-set-context ( -- ) jit-pop-context-and-param + jit-save-context arg1 jit-switch-context RSP 8 ADD jit-push-param ; @@ -269,16 +274,17 @@ IN: bootstrap.x86 ds-reg 16 SUB ; : jit-start-context ( -- ) - ! Create the new context in return-reg + ! Create the new context in return-reg. Have to save context + ! twice, first before calling new_context() which may GC, + ! and again after popping the two parameters from the stack. + jit-save-context arg1 vm-reg MOV "new_context" jit-call jit-pop-quot-and-param - + jit-save-context return-reg jit-switch-context - jit-push-param - jit-jump-quot ; [ jit-start-context ] \ (start-context) define-sub-primitive @@ -294,7 +300,17 @@ IN: bootstrap.x86 jit-set-context ] \ (set-context-and-delete) define-sub-primitive +: jit-start-context-and-delete ( -- ) + jit-load-context + arg1 vm-reg MOV + arg2 ctx-reg MOV + "reset_context" jit-call + + jit-pop-quot-and-param + ctx-reg jit-switch-context + jit-push-param + jit-jump-quot ; + [ - jit-delete-current-context - jit-start-context + jit-start-context-and-delete ] \ (start-context-and-delete) define-sub-primitive diff --git a/basis/cpu/x86/sse/sse.factor b/basis/cpu/x86/sse/sse.factor index 4d667b8821..afcc877953 100644 --- a/basis/cpu/x86/sse/sse.factor +++ b/basis/cpu/x86/sse/sse.factor @@ -919,6 +919,5 @@ M: x86 %vector>scalar %copy ; M: x86 %scalar>vector %copy ; enable-float-intrinsics -enable-float-functions enable-float-min/max enable-fsqrt diff --git a/basis/cpu/x86/x86-tests.factor b/basis/cpu/x86/x86-tests.factor new file mode 100644 index 0000000000..31e0f23ebd --- /dev/null +++ b/basis/cpu/x86/x86-tests.factor @@ -0,0 +1,10 @@ +IN: cpu.x86.tests +USING: cpu.x86.features tools.test math.libm kernel.private math +compiler.cfg.instructions compiler.cfg.debugger kernel ; + +[ ] [ + [ { float } declare fsqrt ] + [ ##sqrt? ] contains-insn? + sse2? + assert= +] unit-test diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 6442044d35..a13b44197d 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -631,6 +631,8 @@ HOOK: %load-reg-param cpu ( vreg rep reg -- ) HOOK: %store-reg-param cpu ( vreg rep reg -- ) +HOOK: %discard-reg-param cpu ( rep reg -- ) + : %load-return ( dst rep -- ) dup return-reg %load-reg-param ; @@ -641,24 +643,25 @@ HOOK: %prepare-var-args cpu ( -- ) HOOK: %cleanup cpu ( n -- ) -:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot -- ) +:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot -- ) stack-inputs [ first3 %store-stack-param ] each reg-inputs [ first3 %store-reg-param ] each %prepare-var-args quot call cleanup %cleanup - reg-outputs [ first3 %load-reg-param ] each ; inline + reg-outputs [ first3 %load-reg-param ] each + dead-outputs [ first2 %discard-reg-param ] each ; inline -M: x86 %alien-invoke ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- ) +M: x86 %alien-invoke ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map -- ) '[ _ _ _ %c-invoke ] emit-alien-insn ; -M:: x86 %alien-indirect ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- ) - reg-inputs stack-inputs reg-outputs cleanup stack-size [ +M:: x86 %alien-indirect ( src reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map -- ) + reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [ src ?spill-slot CALL gc-map gc-map-here ] emit-alien-insn ; -M: x86 %alien-assembly ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- ) +M: x86 %alien-assembly ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot gc-map -- ) '[ _ _ gc-map set call( -- ) ] emit-alien-insn ; HOOK: %begin-callback cpu ( -- ) diff --git a/basis/cpu/x86/x87/x87.factor b/basis/cpu/x86/x87/x87.factor index 8f267b4265..445b913bc9 100644 --- a/basis/cpu/x86/x87/x87.factor +++ b/basis/cpu/x86/x87/x87.factor @@ -99,5 +99,4 @@ M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- ) [ [ FUCOMI ] compare-op ] (%compare-float-branch) ; enable-float-intrinsics -enable-float-functions enable-fsqrt diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 13af6d1090..66c9f32f7f 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -27,7 +27,7 @@ HELP: dispose-statements { $description "Disposes an associative list of statements." } ; HELP: statement -{ $description "A " { $snippet "statement" } " stores the information about a statemen, such as the SQL statement text, the in/out parameters, and type information." } ; +{ $description "A " { $snippet "statement" } " stores the information about a statement, such as the SQL statement text, the in/out parameters, and type information." } ; HELP: result-set { $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use." diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor index 0935fb6c91..2035137eee 100644 --- a/basis/db/sqlite/lib/lib.factor +++ b/basis/db/sqlite/lib/lib.factor @@ -165,7 +165,7 @@ ERROR: sqlite-sql-error < sql-error n string ; } case ; : sqlite-row ( handle -- seq ) - dup sqlite-#columns [ sqlite-column ] with map ; + dup sqlite-#columns [ sqlite-column ] with { } map-integers ; : sqlite-step-has-more-rows? ( prepared -- ? ) { diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor old mode 100644 new mode 100755 index eca34c2526..9159b7f46c --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -136,7 +136,7 @@ PREDICATE: vm-error < array { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } - [ second 0 16 between? ] + [ second 0 17 between? ] } cond ; : vm-errors ( error -- n errors ) diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 4a280ef584..4d42f71dc0 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -93,6 +93,17 @@ CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ; [ a>> ] [ b>> ] [ c>> ] tri ] unit-test +TUPLE: slot-protocol-test-4 { x read-only } ; + +TUPLE: slot-protocol-test-5 { a-read-only-slot read-only } ; + +CONSULT: slot-protocol-test-5 slot-protocol-test-4 x>> ; + +[ "hey" ] [ + "hey" slot-protocol-test-5 boa slot-protocol-test-4 boa + a-read-only-slot>> +] unit-test + GENERIC: do-me ( x -- ) M: f do-me drop ; diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index ebd6a05b48..cdd58afc9e 100644 --- a/basis/delegate/delegate.factor +++ b/basis/delegate/delegate.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs classes.tuple definitions effects generic generic.standard hashtables kernel lexer math parser generic.parser sequences sets slots words words.symbol fry -compiler.units ; +compiler.units make ; IN: delegate ERROR: broadcast-words-must-have-no-outputs group ; @@ -22,13 +22,16 @@ GENERIC: group-words ( group -- words ) M: standard-generic group-words dup "combination" word-prop #>> 2array 1array ; -: slot-group-words ( slots -- words ) +: slot-words, ( slot-spec -- ) + [ name>> reader-word 0 2array , ] [ - name>> - [ reader-word 0 2array ] - [ writer-word 0 2array ] bi - 2array - ] map concat ; + dup read-only>> [ drop ] [ + name>> writer-word 0 2array , + ] if + ] bi ; + +: slot-group-words ( slots -- words ) + [ [ slot-words, ] each ] { } make ; M: tuple-class group-words all-slots slot-group-words ; diff --git a/basis/editors/jedit/jedit.factor b/basis/editors/jedit/jedit.factor index e34f0ce175..89393e5c45 100644 --- a/basis/editors/jedit/jedit.factor +++ b/basis/editors/jedit/jedit.factor @@ -1,14 +1,18 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays definitions io kernel math -namespaces parser prettyprint sequences strings words -editors io.files io.sockets io.streams.byte-array io.binary -math.parser io.encodings.ascii io.encodings.binary -io.encodings.utf8 io.files.private io.pathnames ; +USING: arrays editors io io.binary io.encodings.ascii +io.encodings.binary io.encodings.utf8 io.files io.files.private +io.pathnames io.sockets io.streams.byte-array kernel locals +math.parser namespaces prettyprint sequences ; IN: editors.jedit -: jedit-server-info ( -- port auth ) - home ".jedit/server" append-path ascii [ +: jedit-server-file ( -- server-files ) + home ".jedit/server" append-path + home "Library/jEdit/server" append-path 2array + [ exists? ] find nip ; + +: jedit-server-info ( server-file -- port auth ) + ascii [ readln drop readln string>number readln string>number @@ -24,11 +28,12 @@ IN: editors.jedit "null});\n" write ] with-byte-writer ; -: send-jedit-request ( request -- ) - jedit-server-info "localhost" rot binary [ - 4 >be write - dup length 2 >be write - write +:: send-jedit-request ( request -- ) + jedit-server-file jedit-server-info :> ( port auth ) + "localhost" port binary [ + auth 4 >be write + request length 2 >be write + request write ] with-client ; : jedit-location ( file line -- ) diff --git a/basis/ftp/server/server-tests.factor b/basis/ftp/server/server-tests.factor index 2572f36cb0..2954db0f8b 100644 --- a/basis/ftp/server/server-tests.factor +++ b/basis/ftp/server/server-tests.factor @@ -1,12 +1,12 @@ USING: calendar ftp.server io.encodings.ascii io.files io.files.unique namespaces threads tools.test kernel io.servers.connection ftp.client accessors urls -io.pathnames io.directories sequences fry io.backend ; +io.pathnames io.directories sequences fry io.backend +continuations ; FROM: ftp.client => ftp-get ; IN: ftp.server.tests -: test-file-contents ( -- string ) - "Files are so boring anymore." ; +CONSTANT: test-file-contents "Files are so boring anymore." : create-test-file ( -- path ) test-file-contents @@ -15,28 +15,24 @@ IN: ftp.server.tests : test-ftp-server ( quot -- ) '[ - current-temporary-directory get 0 - - [ start-server* ] - [ - sockets>> first addr>> port>> + current-temporary-directory get + 0 [ + insecure-port swap >>port "ftp" >>protocol "localhost" >>host create-test-file >>path - _ call - ] - [ stop-server ] tri - ] with-unique-directory drop ; inline + @ + ] with-threaded-server + ] cleanup-unique-directory ; inline [ t ] [ - [ - unique-directory [ + [ [ ftp-get ] [ path>> file-name ascii file-contents ] bi - ] with-directory + ] cleanup-unique-working-directory ] test-ftp-server test-file-contents = ] unit-test @@ -44,8 +40,8 @@ IN: ftp.server.tests [ "/" >>path - unique-directory [ + [ [ ftp-get ] [ path>> file-name ascii file-contents ] bi - ] with-directory + ] cleanup-unique-working-directory ] test-ftp-server test-file-contents = ] must-fail diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 2a3e82265b..e6a47c3ffd 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs byte-arrays calendar classes combinators +USING: accessors calendar calendar.format classes combinators combinators.short-circuit concurrency.promises continuations -destructors ftp io io.backend io.directories io.encodings -io.encodings.binary tools.files io.encodings.utf8 io.files -io.files.info io.pathnames io.servers.connection io.sockets -io.streams.duplex io.streams.string io.timeouts kernel make math -math.bitwise math.parser namespaces sequences splitting threads -unicode.case logging calendar.format strings io.files.links -io.files.types io.encodings.8-bit.latin1 simple-tokenizer ; +destructors ftp io io.directories io.encodings +io.encodings.8-bit.latin1 io.encodings.binary io.encodings.utf8 +io.files io.files.info io.files.types io.pathnames +io.servers.connection io.sockets io.streams.string io.timeouts +kernel logging math math.bitwise math.parser namespaces +sequences simple-tokenizer splitting strings threads +tools.files unicode.case ; IN: ftp.server SYMBOL: server @@ -49,6 +49,17 @@ C: ftp-disconnect [ but-last-slice [ "-" (send-response) ] with each ] [ first " " (send-response) ] 2bi ; +: make-path-relative? ( path -- ? ) + { + [ absolute-path? ] + [ drop server get serving-directory>> ] + } 1&& ; + +: fixup-relative-path ( string -- string' ) + dup make-path-relative? [ + [ server get serving-directory>> ] dip append-relative-path + ] when ; + : server-response ( string n -- ) 2dup number>string swap ":" glue \ server-response DEBUG log-message @@ -115,14 +126,18 @@ ERROR: type-error type ; ] recover ; : random-local-server ( -- server ) - remote-address get class new 0 >>port binary ; + remote-address get class new binary ; : port>bytes ( port -- hi lo ) [ -8 shift ] keep [ 8 bits ] bi@ ; +: display-directory ( -- string ) + current-directory get server get serving-directory>> swap ?head drop + [ "/" ] when-empty ; + : handle-PWD ( obj -- ) drop - current-directory get "\"" dup surround 257 server-response ; + display-directory get "\"" dup surround 257 server-response ; : handle-SYST ( obj -- ) drop @@ -167,8 +182,9 @@ GENERIC: handle-passive-command ( stream obj -- ) M: ftp-list handle-passive-command ( stream obj -- ) drop start-directory [ - utf8 encode-output - [ current-directory get directory. ] with-string-writer string-lines + utf8 encode-output [ + current-directory get directory. + ] with-string-writer string-lines harvest [ ftp-send ] each ] with-output-stream finish-directory ; @@ -225,6 +241,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- ) : handle-RETR ( obj -- ) tokenized>> second + fixup-relative-path dup can-serve-file? [ fulfill-client ] [ @@ -261,6 +278,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- ) : handle-MDTM ( obj -- ) tokenized>> 1 swap ?nth [ + fixup-relative-path dup file-info dup directory? [ drop not-a-plain-file ] [ @@ -283,6 +301,7 @@ ERROR: no-directory-permissions ; : handle-CWD ( obj -- ) tokenized>> 1 swap ?nth [ + fixup-relative-path dup can-serve-directory? [ set-current-directory directory-change-success @@ -346,11 +365,9 @@ M: ftp-server handle-client* ( server -- ) "ftp.server" >>name 5 minutes >>timeout ; -: ftpd ( directory port -- ) +: ftpd ( directory port -- server ) start-server ; -: ftpd-main ( path -- ) 2100 ftpd ; - -MAIN: ftpd-main - ! sudo tcpdump -i en1 -A -s 10000 tcp port 21 +! [2010-09-04T22:07:58-05:00] DEBUG server-response: 500:Unrecognized command: EPRT |2|0:0:0:0:0:0:0:1|59359| + diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index a187300960..deecef8848 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -49,7 +49,7 @@ IN: furnace.chloe-tags } cleave [ a-url ] [code] ; CHLOE: atom - [ compile-children>string ] [ compile-a-url ] bi + [ compile-children>xml-string ] [ compile-a-url ] bi [ add-atom-feed ] [code] ; CHLOE: write-atom drop [ write-atom-feeds ] [code] ; @@ -73,7 +73,7 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ; CHLOE: a [ [ a-attrs ] - [ compile-children>string ] bi + [ compile-children>xml-string ] bi [ [XML <-> XML] second swap >>attrs ] [xml-code] ] compile-with-scope ; @@ -120,7 +120,7 @@ CHLOE: form [ [ compile-form-attrs ] [ hidden-fields ] - [ compile-children>string ] tri + [ compile-children>xml-string ] tri [ [XML
<-><->
XML] second swap >>attrs diff --git a/basis/help/apropos/apropos.factor b/basis/help/apropos/apropos.factor index 1fdbef3cb1..933761871d 100644 --- a/basis/help/apropos/apropos.factor +++ b/basis/help/apropos/apropos.factor @@ -28,11 +28,11 @@ M: more-completions article-name seq>> length max-completions - number>string " more results" append ; M: more-completions article-content - seq>> sort-values keys \ $completions prefix ; + seq>> [ second >lower ] sort-with keys \ $completions prefix ; -: (apropos) ( str candidates title -- element ) +: (apropos) ( completions title -- element ) [ - [ completions ] dip '[ + '[ _ 1array \ $heading prefix , [ max-completions short head keys \ $completions prefix , ] [ dup length max-completions > [ more-completions boa <$link> , ] [ drop ] if ] @@ -40,22 +40,16 @@ M: more-completions article-content ] unless-empty ] { } make ; -: word-candidates ( words -- candidates ) - [ dup name>> >lower ] { } map>assoc ; - -: vocab-candidates ( -- candidates ) - all-vocabs-recursive no-roots no-prefixes - [ dup vocab-name >lower ] { } map>assoc ; - -: help-candidates ( seq -- candidates ) - [ [ >link ] [ article-title >lower ] bi ] { } map>assoc - sort-values ; +: articles-matching ( str -- seq ) + articles get + [ [ >link ] [ title>> ] bi* ] { } assoc-map-as + completions ; : $apropos ( str -- ) first - [ all-words word-candidates "Words" (apropos) ] - [ vocab-candidates "Vocabularies" (apropos) ] - [ articles get keys help-candidates "Help articles" (apropos) ] + [ words-matching "Words" (apropos) ] + [ vocabs-matching "Vocabularies" (apropos) ] + [ articles-matching "Help articles" (apropos) ] tri 3array print-element ; TUPLE: apropos search ; diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 948b52a345..eeaeaf7c41 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings.utf8 io.encodings.binary io.files io.files.temp io.directories html.streams help kernel @@ -26,6 +26,7 @@ IN: help.html { CHAR: , "__comma__" } { CHAR: @ "__at__" } { CHAR: # "__hash__" } + { CHAR: % "__percent__" } } at [ % ] [ , ] ?if ] [ number>string "__" "__" surround % ] if ; @@ -112,11 +113,15 @@ MEMO: load-index ( name -- index ) TUPLE: result title href ; +: partition-exact ( string results -- results' ) + [ title>> = ] with partition append ; + : offline-apropos ( string index -- results ) - load-index swap >lower + load-index over >lower '[ [ drop _ ] dip >lower subseq? ] assoc-filter [ swap result boa ] { } assoc>map - [ title>> ] sort-with ; + [ title>> ] sort-with + partition-exact ; : article-apropos ( string -- results ) "articles.idx" offline-apropos ; diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index 5a2a55bfd0..f4f30ea33f 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -25,6 +25,19 @@ GENERIC: render* ( value name renderer -- xml ) : render ( name renderer -- ) render>xml write-xml ; + + +: render-string ( name renderer -- ) + render>xml write-nested ; + SINGLETON: label M: label render* diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 6b98874703..fbce1e81d7 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -73,7 +73,7 @@ MACRO: make-css ( pairs -- str ) span-css-style [ swap [XML ><-> XML] ] unless-empty ; inline -: emit-html ( quot stream -- ) +: emit-html ( stream quot -- ) dip data>> push ; inline : image-path ( path -- images-path ) diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index a3032aba96..2aca1c98aa 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -150,8 +150,8 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags" { $code "" - " class=\"link-button\"" + " t:for=\"id\"" + " class=\"link-button\">" " Delete" "" } diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 8003d71d36..780b55462c 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -5,6 +5,9 @@ splitting furnace accessors html.templates.chloe.compiler ; IN: html.templates.chloe.tests +! So that changes to code are reflected +[ ] [ reset-cache ] unit-test + : run-template ( quot -- string ) with-string-writer [ "\r\n\t" member? not ] filter "?>" split1 nip ; inline @@ -170,3 +173,24 @@ TUPLE: person first-name last-name ; "test13" test-template call-template ] run-template ] [ error>> T{ unknown-chloe-tag f "this-tag-does-not-exist" } = ] must-fail-with + +[ "Hello <world> &escaping test;" "Hello &escaping test;" ] [ + [ + title set + [ + begin-form + "&escaping test;" "a-value" set-value + "test14" test-template call-template + ] run-template + title get box> + ] with-scope +] unit-test + +[ + [ + title set + [ + "test15" test-template call-template + ] run-template + ] with-scope +] [ error>> tag-not-allowed-here? ] must-fail-with diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 92e4a8dc49..74409e6d8e 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -70,7 +70,15 @@ DEFER: compile-element name>string [write] ">" [write] ; +SYMBOL: string-context? + +ERROR: tag-not-allowed-here ; + +: check-tag ( -- ) + string-context? get [ tag-not-allowed-here ] when ; + : compile-tag ( tag -- ) + check-tag { [ main>> tag-stack get push ] [ compile-start-tag ] @@ -87,13 +95,20 @@ ERROR: unknown-chloe-tag tag ; [ unknown-chloe-tag ] ?if ; +: compile-string ( string -- ) + string-context? get [ escape-string ] unless [write] ; + +: compile-misc ( object -- ) + check-tag + [ write-xml ] [code-with] ; + : compile-element ( element -- ) { { [ dup chloe-tag? ] [ compile-chloe-tag ] } { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] } - { [ dup string? ] [ escape-string [write] ] } + { [ dup string? ] [ compile-string ] } { [ dup comment? ] [ drop ] } - [ [ write-xml ] [code-with] ] + [ compile-misc ] } cond ; : with-compiler ( quot -- quot' ) @@ -118,9 +133,14 @@ ERROR: unknown-chloe-tag tag ; : process-children ( tag quot -- ) [ [ compile-children ] compile-quot ] [ % ] bi* ; inline -: compile-children>string ( tag -- ) +: compile-children>xml-string ( tag -- ) [ with-string-writer ] process-children ; +: compile-children>string ( tag -- ) + t string-context? [ + compile-children>xml-string + ] with-variable ; + : compile-with-scope ( quot -- ) compile-quot [ with-scope ] [code] ; inline diff --git a/basis/html/templates/chloe/components/components.factor b/basis/html/templates/chloe/components/components.factor index d69dc08537..3c1446b060 100644 --- a/basis/html/templates/chloe/components/components.factor +++ b/basis/html/templates/chloe/components/components.factor @@ -1,17 +1,23 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences kernel parser fry quotations -classes.tuple classes.singleton +classes.tuple classes.singleton namespaces html.components html.templates.chloe.compiler html.templates.chloe.syntax ; IN: html.templates.chloe.components - + +: render-quot ( -- quot ) + string-context? get + [ render-string ] + [ render ] + ? ; + GENERIC: component-tag ( tag class -- ) M: singleton-class component-tag ( tag class -- ) [ "name" required-attr compile-attr ] - [ literalize [ render ] [code-with] ] + [ literalize render-quot [code-with] ] bi* ; : compile-component-attrs ( tag class -- ) @@ -23,7 +29,7 @@ M: singleton-class component-tag ( tag class -- ) M: tuple-class component-tag ( tag class -- ) [ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi - [ render ] [code] ; + render-quot [code] ; SYNTAX: COMPONENT: scan-word diff --git a/basis/html/templates/chloe/test/test14.xml b/basis/html/templates/chloe/test/test14.xml new file mode 100644 index 0000000000..1ebf48c051 --- /dev/null +++ b/basis/html/templates/chloe/test/test14.xml @@ -0,0 +1,6 @@ + + + + Hello <world> + + diff --git a/basis/html/templates/chloe/test/test15.xml b/basis/html/templates/chloe/test/test15.xml new file mode 100644 index 0000000000..2be3068d64 --- /dev/null +++ b/basis/html/templates/chloe/test/test15.xml @@ -0,0 +1,6 @@ + + + + This is not allowed + + diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index aebae701ed..fd48d81ecd 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -29,13 +29,20 @@ M: template-error error. : call-template ( template -- ) [ call-template* ] [ \ template-error boa rethrow ] recover ; +ERROR: no-boilerplate ; + +M: no-boilerplate error. + drop + "get-title and set-title can only be used from within" print + "a with-boilerplate form" print ; + SYMBOL: title : set-title ( string -- ) - title get >box ; + title get [ >box ] [ no-boilerplate ] if* ; : get-title ( -- string ) - title get value>> ; + title get [ value>> ] [ no-boilerplate ] if* ; : write-title ( -- ) get-title write ; diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 496754ba77..69e84001be 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math math.parser namespaces make -sequences strings splitting calendar continuations accessors vectors -math.order hashtables byte-arrays destructors -io io.sockets io.streams.string io.files io.timeouts -io.pathnames io.encodings io.encodings.string io.encodings.ascii -io.encodings.utf8 io.encodings.binary io.encodings.iana io.crlf -io.streams.duplex fry ascii urls urls.encoding present locals -http http.parsers http.client.post-data mime.types ; +USING: assocs combinators.short-circuit kernel math math.parser +namespaces make sequences strings splitting calendar +continuations accessors vectors math.order hashtables +byte-arrays destructors io io.sockets io.streams.string io.files +io.timeouts io.pathnames io.encodings io.encodings.string +io.encodings.ascii io.encodings.utf8 io.encodings.binary +io.encodings.iana io.crlf io.streams.duplex fry ascii urls +urls.encoding present locals http http.parsers +http.client.post-data mime.types ; IN: http.client ERROR: too-many-redirects ; @@ -21,8 +22,19 @@ ERROR: too-many-redirects ; [ "HTTP/" write version>> write crlf ] tri ; +: default-port? ( url -- ? ) + { + [ port>> not ] + [ [ port>> ] [ protocol>> protocol-port ] bi = ] + } 1|| ; + +: unparse-host ( url -- string ) + dup default-port? [ host>> ] [ + [ host>> ] [ port>> number>string ] bi ":" glue + ] if ; + : set-host-header ( request header -- request header ) - over url>> host>> "host" pick set-at ; + over url>> unparse-host "host" pick set-at ; : set-cookie-header ( header cookies -- header ) unparse-cookie "cookie" pick set-at ; diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 0c396ff4e9..7be7c43399 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -3,7 +3,7 @@ multiline io.streams.string io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.encodings.string io.encodings.ascii kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls hashtables accessors namespaces xml.data -io.encodings.8-bit.latin1 ; +io.encodings.8-bit.latin1 random ; IN: http.tests [ "text/plain" "UTF-8" ] [ "text/plain" parse-content-type ] unit-test @@ -14,6 +14,15 @@ IN: http.tests [ "application/octet-stream" f ] [ "application/octet-stream" parse-content-type ] unit-test +[ "localhost" f ] [ "localhost" parse-host ] unit-test +[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test + +[ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } } unparse-host ] unit-test +[ "localhost" ] [ T{ url { protocol "http" } { host "localhost" } { port 80 } } unparse-host ] unit-test +[ "localhost" ] [ T{ url { protocol "https" } { host "localhost" } { port 443 } } unparse-host ] unit-test +[ "localhost:8080" ] [ T{ url { protocol "http" } { host "localhost" } { port 8080 } } unparse-host ] unit-test +[ "localhost:8443" ] [ T{ url { protocol "https" } { host "localhost" } { port 8443 } } unparse-host ] unit-test + : lf>crlf ( string -- string' ) "\n" split "\r\n" join ; STRING: read-request-test-1 @@ -80,15 +89,32 @@ Host: www.sex.com ] with-string-reader ] unit-test +STRING: read-request-test-2' +HEAD /bar HTTP/1.1 +Host: www.sex.com:101 + +; + +[ + T{ request + { url T{ url { host "www.sex.com" } { port 101 } { path "/bar" } } } + { method "HEAD" } + { version "1.1" } + { header H{ { "host" "www.sex.com:101" } } } + { cookies V{ } } + { redirects 10 } + } +] [ + read-request-test-2' lf>crlf [ + read-request + ] with-string-reader +] unit-test + STRING: read-request-test-3 GET nested HTTP/1.0 ; -[ read-request-test-3 lf>crlf [ read-request ] with-string-reader ] -[ "Bad request: URL" = ] -must-fail-with - STRING: read-request-test-4 GET /blah HTTP/1.0 Host: "www.amazon.com" @@ -205,8 +231,8 @@ test-db [ 0 >>insecure f >>secure - dup start-server* - sockets>> first addr>> port>> + start-server + servers>> random addr>> port>> ] with-scope "port" set ; [ ] [ diff --git a/basis/http/server/server-docs.factor b/basis/http/server/server-docs.factor index 6f03a2ea96..7e8d230971 100644 --- a/basis/http/server/server-docs.factor +++ b/basis/http/server/server-docs.factor @@ -46,7 +46,7 @@ HELP: { $description "Creates a new HTTP server with default parameters." } ; HELP: httpd -{ $values { "port" integer } } +{ $values { "port" integer } { "http-server" http-server } } { $description "Starts an HTTP server on the specified port number." } { $notes "For more flexibility, use " { $link } " and fill in the tuple slots before calling " { $link start-server } "." } ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 942142883a..9e4a8ac4bf 100644 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -49,12 +49,19 @@ ERROR: no-boundary ; ";" split1 nip "=" split1 nip [ no-boundary ] unless* ; +SYMBOL: request-limit + +request-limit [ 64 1024 * ] initialize + SYMBOL: upload-limit +upload-limit [ 200,000,000 ] initialize + : read-multipart-data ( request -- mime-parts ) [ "content-type" header ] [ "content-length" header string>number ] bi - upload-limit get min limited-input + unlimited-input + upload-limit get [ min ] when* limited-input binary decode-input parse-multipart-form-data parse-multipart ; @@ -75,8 +82,9 @@ SYMBOL: upload-limit ] when ; : extract-host ( request -- request ) - [ ] [ url>> ] [ "host" header dup [ url-decode ] when ] tri - >>host drop ; + [ ] [ url>> ] [ "host" header parse-host ] tri + [ >>host ] [ >>port ] bi* + drop ; : extract-cookies ( request -- request ) dup "cookie" header [ parse-cookie >>cookies ] when* ; @@ -275,14 +283,10 @@ LOG: httpd-benchmark DEBUG TUPLE: http-server < threaded-server ; -SYMBOL: request-limit - -request-limit [ 64 1024 * ] initialize - M: http-server handle-client* drop [ - request-limit get limited-input ?refresh-all + request-limit get limited-input [ read-request ] ?benchmark [ do-request ] ?benchmark [ do-response ] ?benchmark @@ -294,7 +298,7 @@ M: http-server handle-client* "http" protocol-port >>insecure "https" protocol-port >>secure ; -: httpd ( port -- ) +: httpd ( port -- http-server ) swap >>insecure f >>secure diff --git a/basis/images/images.factor b/basis/images/images.factor index 6cbcdb9508..99f0bb91b9 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -125,6 +125,9 @@ TUPLE: image dim component-order component-type upside-down? bitmap ; : bytes-per-pixel ( image -- n ) [ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ; + +: bytes-per-image ( image -- n ) + [ dim>> product ] [ bytes-per-pixel ] bi * ; mx set-global ; - -! M: bsd (monitor) ( path recursive? mailbox -- ) -! swap [ "Recursive kqueue monitors not supported" throw ] when -! ; diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor index 5a3dab4dcc..2cf406a941 100644 --- a/basis/io/backend/unix/multiplexers/select/select.factor +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -51,7 +51,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ; M:: select-mx wait-for-events ( nanos mx -- ) mx - [ init-fdsets nanos 1000 /i dup [ make-timeval ] when select multiplexer-error drop ] + [ init-fdsets nanos dup [ 1000 /i make-timeval ] when select multiplexer-error drop ] [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ] [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ] tri ; diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor old mode 100644 new mode 100755 index 972b2a5b07..fd9fed0472 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -25,25 +25,25 @@ TUPLE: fd < disposable fd ; fd new-disposable swap >>fd ; M: fd dispose - dup disposed>> [ drop ] [ + [ { [ cancel-operation ] [ t >>disposed drop ] [ unregister-disposable ] [ fd>> close-file ] } cleave - ] if ; + ] unless-disposed ; M: fd handle-fd dup check-disposed fd>> ; M: fd cancel-operation ( fd -- ) - dup disposed>> [ drop ] [ + [ fd>> mx get-global [ remove-input-callbacks [ t swap resume-with ] each ] [ remove-output-callbacks [ t swap resume-with ] each ] 2bi - ] if ; + ] unless-disposed ; M: unix tell-handle ( handle -- n ) fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor deleted file mode 100755 index 69a86c7ec3..0000000000 --- a/basis/io/backend/windows/nt/nt.factor +++ /dev/null @@ -1,148 +0,0 @@ -USING: alien alien.c-types alien.data alien.syntax arrays assocs -combinators continuations destructors io io.backend io.ports -io.timeouts io.backend.windows io.files.windows -io.files.windows.nt io.files io.pathnames io.buffers -io.streams.c io.streams.null libc kernel math namespaces -sequences threads windows windows.errors windows.kernel32 -strings splitting ascii system accessors locals classes.struct -combinators.short-circuit ; -IN: io.backend.windows.nt - -! Global variable with assoc mapping overlapped to threads -SYMBOL: pending-overlapped - -TUPLE: io-callback port thread ; - -C: io-callback - -: (make-overlapped) ( -- overlapped-ext ) - OVERLAPPED malloc-struct &free ; - -: make-overlapped ( port -- overlapped-ext ) - [ (make-overlapped) ] dip - handle>> ptr>> [ >>offset ] when* ; - -M: winnt FileArgs-overlapped ( port -- overlapped ) - make-overlapped ; - -: ( handle existing -- handle ) - f 1 CreateIoCompletionPort dup win32-error=0/f ; - -SYMBOL: master-completion-port - -: ( -- handle ) - INVALID_HANDLE_VALUE f ; - -M: winnt add-completion ( win32-handle -- ) - handle>> master-completion-port get-global drop ; - -: eof? ( error -- ? ) - { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ; - -: twiddle-thumbs ( overlapped port -- bytes-transferred ) - [ - drop - [ self ] dip >c-ptr pending-overlapped get-global set-at - "I/O" suspend { - { [ dup integer? ] [ ] } - { [ dup array? ] [ - first dup eof? - [ drop 0 ] [ n>win32-error-string throw ] if - ] } - } cond - ] with-timeout ; - -:: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? ) - nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout - master-completion-port get-global - { int void* pointer: OVERLAPPED } - [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters - :> ( error? bytes key overlapped ) - bytes overlapped error? ; - -: resume-callback ( result overlapped -- ) - >c-ptr pending-overlapped get-global delete-at* drop resume-with ; - -: handle-overlapped ( nanos -- ? ) - wait-for-overlapped [ - [ - [ drop GetLastError 1array ] dip resume-callback t - ] [ drop f ] if* - ] [ resume-callback t ] if ; - -M: win32-handle cancel-operation - [ check-disposed ] [ handle>> CancelIo drop ] bi ; - -M: winnt io-multiplex ( nanos -- ) - handle-overlapped [ 0 io-multiplex ] when ; - -M: winnt init-io ( -- ) - master-completion-port set-global - H{ } clone pending-overlapped set-global ; - -ERROR: invalid-file-size n ; - -: handle>file-size ( handle -- n ) - 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; - -ERROR: seek-before-start n ; - -: set-seek-ptr ( n handle -- ) - [ dup 0 < [ seek-before-start ] when ] dip ptr<< ; - -M: winnt tell-handle ( handle -- n ) ptr>> ; - -M: winnt seek-handle ( n seek-type handle -- ) - swap { - { seek-absolute [ set-seek-ptr ] } - { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] } - { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] } - [ bad-seek-type ] - } case ; - -: file-error? ( n -- eof? ) - zero? [ - GetLastError { - { [ dup expected-io-error? ] [ drop f ] } - { [ dup eof? ] [ drop t ] } - [ n>win32-error-string throw ] - } cond - ] [ f ] if ; - -: wait-for-file ( FileArgs n port -- n ) - swap file-error? - [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ; - -: update-file-ptr ( n port -- ) - handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; - -: finish-write ( n port -- ) - [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; - -M: winnt (wait-to-write) - [ - [ make-FileArgs dup setup-write WriteFile ] - [ wait-for-file ] - [ finish-write ] - tri - ] with-destructors ; - -: finish-read ( n port -- ) - [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ; - -M: winnt (wait-to-read) ( port -- ) - [ - [ make-FileArgs dup setup-read ReadFile ] - [ wait-for-file ] - [ finish-read ] - tri - ] with-destructors ; - -: console-app? ( -- ? ) GetConsoleWindow >boolean ; - -M: winnt init-stdio - console-app? - [ init-c-stdio ] - [ null-reader null-writer null-writer set-stdio ] if ; - -winnt set-io-backend diff --git a/basis/io/backend/windows/privileges/privileges-tests.factor b/basis/io/backend/windows/privileges/privileges-tests.factor deleted file mode 100644 index a66b2aad7a..0000000000 --- a/basis/io/backend/windows/privileges/privileges-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: io.backend.windows.privileges tools.test ; -IN: io.backend.windows.privileges.tests - -[ [ ] with-privileges ] must-infer diff --git a/basis/io/backend/windows/privileges/privileges.factor b/basis/io/backend/windows/privileges/privileges.factor deleted file mode 100644 index 58806cc4df..0000000000 --- a/basis/io/backend/windows/privileges/privileges.factor +++ /dev/null @@ -1,15 +0,0 @@ -USING: io.backend kernel continuations sequences -system vocabs.loader combinators fry ; -IN: io.backend.windows.privileges - -HOOK: set-privilege io-backend ( name ? -- ) - -: with-privileges ( seq quot -- ) - [ '[ _ [ t set-privilege ] each @ ] ] - [ drop '[ _ [ f set-privilege ] each ] ] - 2bi [ ] cleanup ; inline - -{ - { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] } - { [ os wince? ] [ "io.backend.windows.ce.privileges" require ] } -} cond diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor old mode 100644 new mode 100755 index 0e0a803679..7f9c42d13b --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -1,55 +1,8 @@ -! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. +! Copyright (C) 2004, 2010 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays destructors io io.backend -io.buffers io.files io.ports io.binary io.timeouts system -strings kernel math namespaces sequences windows.errors -windows.kernel32 windows.shell32 windows.types splitting -continuations math.bitwise accessors init sets assocs -classes.struct classes literals ; +USING: io.backend namespaces system vocabs.loader ; IN: io.backend.windows -TUPLE: win32-handle < disposable handle ; +"io.files.windows" require -: set-inherit ( handle ? -- ) - [ handle>> HANDLE_FLAG_INHERIT ] dip - >BOOLEAN SetHandleInformation win32-error=0/f ; - -: new-win32-handle ( handle class -- win32-handle ) - new-disposable swap >>handle - dup f set-inherit ; - -: ( handle -- win32-handle ) - win32-handle new-win32-handle ; - -M: win32-handle dispose* ( handle -- ) - handle>> CloseHandle win32-error=0/f ; - -TUPLE: win32-file < win32-handle ptr ; - -: ( handle -- win32-file ) - win32-file new-win32-handle ; - -M: win32-file dispose - dup disposed>> [ drop ] [ - [ cancel-operation ] [ call-next-method ] bi - ] if ; - -HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) -HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) -HOOK: add-completion io-backend ( port -- ) - -: opened-file ( handle -- win32-file ) - dup invalid-handle? - |dispose - dup add-completion ; - -CONSTANT: share-mode - flags{ - FILE_SHARE_READ - FILE_SHARE_WRITE - FILE_SHARE_DELETE - } - -: default-security-attributes ( -- obj ) - SECURITY_ATTRIBUTES - SECURITY_ATTRIBUTES heap-size >>nLength ; +winnt set-io-backend diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor index 804a2f4a8d..3871f9be41 100644 --- a/basis/io/directories/directories-docs.factor +++ b/basis/io/directories/directories-docs.factor @@ -46,17 +46,21 @@ HELP: directory-files { $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } } { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; -HELP: directory-tree-files -{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } } -{ $description "Outputs a sequence of all files and subdirectories inside the directory named by " { $snippet "path" } " or recursively inside its subdirectories." } ; - HELP: with-directory-files { $values { "path" "a pathname string" } { "quot" quotation } } -{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; - -HELP: with-directory-tree-files -{ $values { "path" "a pathname string" } { "quot" quotation } } -{ $description "Calls the quotation with the recursive directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; +{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } +{ $examples + "Print all files in your home directory which are larger than a megabyte:" + { $code + """USING: io.directoies io.files.info io.pathnames ; +home [ + [ + dup link-info size>> 20 2^ > + [ print ] [ drop ] if + ] each +] with-directory-files""" + } +} ; HELP: with-directory-entries { $values { "path" "a pathname string" } { "quot" quotation } } diff --git a/basis/io/directories/directories-tests.factor b/basis/io/directories/directories-tests.factor index 742a927b4b..b703421b45 100644 --- a/basis/io/directories/directories-tests.factor +++ b/basis/io/directories/directories-tests.factor @@ -22,24 +22,6 @@ IN: io.directories.tests ] with-directory-files ] unit-test -[ { "classes/tuple/tuple.factor" } ] [ - "resource:core" [ - "." directory-tree-files [ "classes/tuple/tuple.factor" = ] filter - ] with-directory -] unit-test - -[ { "classes/tuple" } ] [ - "resource:core" [ - "." directory-tree-files [ "classes/tuple" = ] filter - ] with-directory -] unit-test - -[ { "classes/tuple/tuple.factor" } ] [ - "resource:core" [ - [ "classes/tuple/tuple.factor" = ] filter - ] with-directory-tree-files -] unit-test - [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test [ ] [ "blahblah" temp-file make-directory ] unit-test [ t ] [ "blahblah" temp-file file-info directory? ] unit-test diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor index d12adc5f41..c164f01800 100644 --- a/basis/io/directories/directories.factor +++ b/basis/io/directories/directories.factor @@ -37,30 +37,16 @@ HOOK: (directory-entries) os ( path -- seq ) normalize-path (directory-entries) [ name>> { "." ".." } member? not ] filter ; - + : directory-files ( path -- seq ) directory-entries [ name>> ] map ; -: directory-tree-files ( path -- seq ) - dup directory-entries - [ - dup type>> +directory+ = - [ name>> - [ append-path directory-tree-files ] - [ [ prepend-path ] curry map ] - [ prefix ] tri - ] [ nip name>> 1array ] if - ] with map concat ; - : with-directory-entries ( path quot -- ) '[ "" directory-entries @ ] with-directory ; inline : with-directory-files ( path quot -- ) '[ "" directory-files @ ] with-directory ; inline -: with-directory-tree-files ( path quot -- ) - '[ "" directory-tree-files @ ] with-directory ; inline - ! Touching files HOOK: touch-file io-backend ( path -- ) diff --git a/basis/io/directories/hierarchy/hierarchy-docs.factor b/basis/io/directories/hierarchy/hierarchy-docs.factor index b45fe49d9b..232cad1291 100644 --- a/basis/io/directories/hierarchy/hierarchy-docs.factor +++ b/basis/io/directories/hierarchy/hierarchy-docs.factor @@ -1,6 +1,14 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax quotations io.pathnames ; IN: io.directories.hierarchy +HELP: directory-tree-files +{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } } +{ $description "Outputs a sequence of all files and subdirectories inside the directory named by " { $snippet "path" } " or recursively inside its subdirectories." } ; + +HELP: with-directory-tree-files +{ $values { "path" "a pathname string" } { "quot" quotation } } +{ $description "Calls the quotation with the recursive directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; + HELP: delete-tree { $values { "path" "a pathname string" } } { $description "Deletes a file or directory, recursing into subdirectories." } @@ -31,6 +39,11 @@ $nl { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." } { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." } } +"Listing directory trees recursively:" +{ $subsections + directory-tree-files + with-directory-tree-files +} "Deleting directory trees recursively:" { $subsections delete-tree } "Copying directory trees recursively:" diff --git a/basis/io/directories/hierarchy/hierarchy-tests.factor b/basis/io/directories/hierarchy/hierarchy-tests.factor new file mode 100644 index 0000000000..fdf05684cc --- /dev/null +++ b/basis/io/directories/hierarchy/hierarchy-tests.factor @@ -0,0 +1,21 @@ +USING: io.directories io.directories.hierarchy kernel +sequences tools.test ; +IN: io.directories.hierarchy.tests + +[ { "classes/tuple/tuple.factor" } ] [ + "resource:core" [ + "." directory-tree-files [ "classes/tuple/tuple.factor" = ] filter + ] with-directory +] unit-test + +[ { "classes/tuple" } ] [ + "resource:core" [ + "." directory-tree-files [ "classes/tuple" = ] filter + ] with-directory +] unit-test + +[ { "classes/tuple/tuple.factor" } ] [ + "resource:core" [ + [ "classes/tuple/tuple.factor" = ] filter + ] with-directory-tree-files +] unit-test diff --git a/basis/io/directories/hierarchy/hierarchy.factor b/basis/io/directories/hierarchy/hierarchy.factor index 4a2955ccaf..d39fbc39a2 100644 --- a/basis/io/directories/hierarchy/hierarchy.factor +++ b/basis/io/directories/hierarchy/hierarchy.factor @@ -1,10 +1,24 @@ ! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences combinators fry io.directories -io.pathnames io.files.info io.files.types io.files.links -io.backend ; +USING: accessors arrays kernel sequences combinators fry +io.directories io.pathnames io.files.info io.files.types +io.files.links io.backend ; IN: io.directories.hierarchy +: directory-tree-files ( path -- seq ) + dup directory-entries + [ + dup type>> +directory+ = + [ name>> + [ append-path directory-tree-files ] + [ [ prepend-path ] curry map ] + [ prefix ] tri + ] [ nip name>> 1array ] if + ] with map concat ; + +: with-directory-tree-files ( path quot -- ) + '[ "" directory-tree-files @ ] with-directory ; inline + : delete-tree ( path -- ) dup link-info directory? [ [ [ [ delete-tree ] each ] with-directory-files ] @@ -28,4 +42,3 @@ DEFER: copy-tree-into : copy-trees-into ( files to -- ) '[ _ copy-tree-into ] each ; - diff --git a/basis/io/files/info/info-docs.factor b/basis/io/files/info/info-docs.factor index aaeb92d9c2..17c4c63491 100644 --- a/basis/io/files/info/info-docs.factor +++ b/basis/io/files/info/info-docs.factor @@ -24,7 +24,18 @@ HELP: file-system-info { $values { "path" "a pathname string" } { "file-system-info" file-system-info } } -{ $description "Returns a platform-specific object describing the file-system that contains the path. The cross-platform slot is " { $slot "free-space" } "." } ; +{ $description "Returns a platform-specific object describing the file-system that contains the path. The cross-platform slot is " { $slot "free-space" } "." } +{ $examples + { $unchecked-example + "USING: io.files.info io.pathnames math prettyprint ;" + "IN: scratchpad" + "" + ": gb ( m -- n ) 30 2^ * ;" + "" + "home file-system-info free-space>> 100 gb < ." + "f" + } +} ; ARTICLE: "io.files.info" "File system meta-data" "File meta-data:" diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 8ec5753e11..aca23d8347 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -51,8 +51,8 @@ frequency pass-number ; [ second >>mount-point ] [ third >>type ] [ fourth csv first >>options ] - [ 4 swap nth >>frequency ] - [ 5 swap nth >>pass-number ] + [ 4 swap ?nth [ 0 ] unless* >>frequency ] + [ 5 swap ?nth [ 0 ] unless* >>pass-number ] } cleave ; : parse-mtab ( -- array ) diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 2971a15b4b..bf055f327b 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays math io.backend io.files.info -io.files.windows io.files.windows.nt kernel windows.kernel32 +io.files.windows kernel windows.kernel32 windows.time windows.types windows accessors alien.c-types combinators generalizations system alien.strings io.encodings.utf16n sequences splitting windows.errors fry diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 7652bfcfd0..79dddba4ec 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -3,7 +3,7 @@ USING: arrays combinators continuations fry io io.backend io.directories io.directories.hierarchy io.files io.pathnames kernel locals math math.bitwise math.parser namespaces random -sequences system vocabs.loader ; +sequences system vocabs.loader random.data ; IN: io.files.unique HOOK: (touch-unique-file) io-backend ( path -- ) @@ -25,22 +25,15 @@ SYMBOL: unique-retries : unique-directory ( -- path ) [ current-temporary-directory get - random-name append-path + random-file-name append-path dup make-directory ] unique-retries get retry ; diff --git a/basis/io/files/unique/windows/windows.factor b/basis/io/files/unique/windows/windows.factor index 2c722426dc..f4b88ff21e 100644 --- a/basis/io/files/unique/windows/windows.factor +++ b/basis/io/files/unique/windows/windows.factor @@ -1,6 +1,5 @@ -USING: kernel system windows.kernel32 io.backend.windows -io.files.windows io.ports windows destructors environment -io.files.unique ; +USING: destructors environment io.files.unique io.files.windows +system windows.kernel32 ; IN: io.files.unique.windows M: windows (touch-unique-file) ( path -- ) diff --git a/basis/io/files/windows/nt/authors.txt b/basis/io/files/windows/nt/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/files/windows/nt/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor deleted file mode 100644 index 10c5710f7d..0000000000 --- a/basis/io/files/windows/nt/nt.factor +++ /dev/null @@ -1,66 +0,0 @@ -USING: continuations destructors io.buffers io.files io.backend -io.timeouts io.ports io.pathnames io.files.private -io.backend.windows io.files.windows io.encodings.utf16n windows -windows.kernel32 kernel libc math threads system environment -alien.c-types alien.arrays alien.strings sequences combinators -combinators.short-circuit ascii splitting alien strings assocs -namespaces make accessors tr windows.time windows.shell32 -windows.errors specialized-arrays classes.struct ; -SPECIALIZED-ARRAY: ushort -IN: io.files.windows.nt - -M: winnt cwd - MAX_UNICODE_PATH dup - [ GetCurrentDirectory win32-error=0/f ] keep - utf16n alien>string ; - -M: winnt cd - SetCurrentDirectory win32-error=0/f ; - -CONSTANT: unicode-prefix "\\\\?\\" - -M: winnt root-directory? ( path -- ? ) - { - { [ dup empty? ] [ drop f ] } - { [ dup [ path-separator? ] all? ] [ drop t ] } - { [ dup trim-tail-separators { [ length 2 = ] - [ second CHAR: : = ] } 1&& ] [ drop t ] } - { [ dup unicode-prefix head? ] - [ trim-tail-separators length unicode-prefix length 2 + = ] } - [ drop f ] - } cond ; - -: prepend-prefix ( string -- string' ) - dup unicode-prefix head? [ - unicode-prefix prepend - ] unless ; - -TR: normalize-separators "/" "\\" ; - -M: winnt normalize-path ( string -- string' ) - absolute-path - normalize-separators - prepend-prefix ; - -M: winnt CreateFile-flags ( DWORD -- DWORD ) - FILE_FLAG_OVERLAPPED bitor ; - - - [ GetFileAttributesEx win32-error=0/f ] keep - [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ; - -PRIVATE> - -M: winnt open-append - [ dup windows-file-size ] [ drop 0 ] recover - [ (open-append) ] dip >>ptr ; - -M: winnt home - { - [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ] - [ "USERPROFILE" os-env ] - [ my-documents ] - } 0|| ; diff --git a/basis/io/files/windows/nt/platforms.txt b/basis/io/files/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/files/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/files/windows/nt/nt-tests.factor b/basis/io/files/windows/windows-tests.factor similarity index 91% rename from basis/io/files/windows/nt/nt-tests.factor rename to basis/io/files/windows/windows-tests.factor index a142bb844e..d7d9080057 100644 --- a/basis/io/files/windows/nt/nt-tests.factor +++ b/basis/io/files/windows/windows-tests.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: io.files io.pathnames kernel tools.test io.backend -io.files.windows.nt splitting sequences io.pathnames.private ; -IN: io.files.windows.nt.tests +io.files.windows splitting sequences io.pathnames.private ; +IN: io.files.windows.tests [ f ] [ "\\foo" absolute-path? ] unit-test [ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index 4fc2057a74..024b278b4b 100644 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -1,15 +1,216 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types io.binary io.backend io.files -io.files.types io.buffers io.encodings.utf16n io.ports -io.backend.windows kernel math splitting fry alien.strings -windows windows.kernel32 windows.time windows.types calendar -combinators math.functions sequences namespaces make words -system destructors accessors math.bitwise continuations -windows.errors arrays byte-arrays generalizations alien.data -literals ; +USING: accessors alien alien.c-types alien.data alien.strings +alien.syntax arrays assocs classes.struct combinators +combinators.short-circuit continuations destructors environment +io io.backend io.binary io.buffers +io.encodings.utf16n io.files io.files.private io.files.types +io.pathnames io.ports io.streams.c io.streams.null io.timeouts +kernel libc literals locals make math math.bitwise namespaces +sequences specialized-arrays system +threads tr windows windows.errors windows.handles +windows.kernel32 windows.shell32 windows.time windows.types ; +SPECIALIZED-ARRAY: ushort IN: io.files.windows +HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) +HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) +HOOK: add-completion io-backend ( port -- port ) +HOOK: open-append os ( path -- win32-file ) + +TUPLE: win32-file < win32-handle ptr ; + +: ( handle -- win32-file ) + win32-file new-win32-handle ; + +M: win32-file dispose + [ cancel-operation ] [ call-next-method ] bi ; + +: opened-file ( handle -- win32-file ) + check-invalid-handle |dispose add-completion ; + +CONSTANT: share-mode + flags{ + FILE_SHARE_READ + FILE_SHARE_WRITE + FILE_SHARE_DELETE + } + +: default-security-attributes ( -- obj ) + SECURITY_ATTRIBUTES + SECURITY_ATTRIBUTES heap-size >>nLength ; + +TUPLE: FileArgs + hFile lpBuffer nNumberOfBytesToRead + lpNumberOfBytesRet lpOverlapped ; + +C: FileArgs + +: make-FileArgs ( port -- ) + { + [ handle>> check-disposed ] + [ handle>> handle>> ] + [ buffer>> ] + [ buffer>> buffer-length ] + [ drop DWORD ] + [ FileArgs-overlapped ] + } cleave ; + +! Global variable with assoc mapping overlapped to threads +SYMBOL: pending-overlapped + +TUPLE: io-callback port thread ; + +C: io-callback + +: (make-overlapped) ( -- overlapped-ext ) + OVERLAPPED malloc-struct &free ; + +: make-overlapped ( port -- overlapped-ext ) + [ (make-overlapped) ] dip + handle>> ptr>> [ >>offset ] when* ; + +M: winnt FileArgs-overlapped ( port -- overlapped ) + make-overlapped ; + +: ( handle existing -- handle ) + f 1 CreateIoCompletionPort dup win32-error=0/f ; + +SYMBOL: master-completion-port + +: ( -- handle ) + INVALID_HANDLE_VALUE f ; + +M: winnt add-completion ( win32-handle -- win32-handle ) + dup handle>> master-completion-port get-global drop ; + +: eof? ( error -- ? ) + { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ; + +: twiddle-thumbs ( overlapped port -- bytes-transferred ) + [ + drop + [ self ] dip >c-ptr pending-overlapped get-global set-at + "I/O" suspend { + { [ dup integer? ] [ ] } + { [ dup array? ] [ + first dup eof? + [ drop 0 ] [ n>win32-error-string throw ] if + ] } + } cond + ] with-timeout ; + +:: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? ) + nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout + master-completion-port get-global + { int void* pointer: OVERLAPPED } + [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters + :> ( error? bytes key overlapped ) + bytes overlapped error? ; + +: resume-callback ( result overlapped -- ) + >c-ptr pending-overlapped get-global delete-at* drop resume-with ; + +: handle-overlapped ( nanos -- ? ) + wait-for-overlapped [ + [ + [ drop GetLastError 1array ] dip resume-callback t + ] [ drop f ] if* + ] [ resume-callback t ] if ; + +M: win32-handle cancel-operation + [ handle>> CancelIo win32-error=0/f ] unless-disposed ; + +M: winnt io-multiplex ( nanos -- ) + handle-overlapped [ 0 io-multiplex ] when ; + +M: winnt init-io ( -- ) + master-completion-port set-global + H{ } clone pending-overlapped set-global ; + +ERROR: invalid-file-size n ; + +: handle>file-size ( handle -- n ) + 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; + +ERROR: seek-before-start n ; + +: set-seek-ptr ( n handle -- ) + [ dup 0 < [ seek-before-start ] when ] dip ptr<< ; + +M: winnt tell-handle ( handle -- n ) ptr>> ; + +M: winnt seek-handle ( n seek-type handle -- ) + swap { + { seek-absolute [ set-seek-ptr ] } + { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] } + { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] } + [ bad-seek-type ] + } case ; + +: file-error? ( n -- eof? ) + zero? [ + GetLastError { + { [ dup expected-io-error? ] [ drop f ] } + { [ dup eof? ] [ drop t ] } + [ n>win32-error-string throw ] + } cond + ] [ f ] if ; + +: wait-for-file ( FileArgs n port -- n ) + swap file-error? + [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ; + +: update-file-ptr ( n port -- ) + handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; + +: finish-write ( n port -- ) + [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; + +: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> buffer-end ] + [ lpBuffer>> buffer-capacity ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +: setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> buffer@ ] + [ lpBuffer>> buffer-length ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +M: winnt (wait-to-write) + [ + [ make-FileArgs dup setup-write WriteFile ] + [ wait-for-file ] + [ finish-write ] + tri + ] with-destructors ; + +: finish-read ( n port -- ) + [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ; + +M: winnt (wait-to-read) ( port -- ) + [ + [ make-FileArgs dup setup-read ReadFile ] + [ wait-for-file ] + [ finish-read ] + tri + ] with-destructors ; + +: console-app? ( -- ? ) GetConsoleWindow >boolean ; + +M: winnt init-stdio + console-app? + [ init-c-stdio ] + [ null-reader null-writer null-writer set-stdio ] if ; + : open-file ( path access-mode create-mode flags -- handle ) [ [ share-mode default-security-attributes ] 2dip @@ -51,42 +252,6 @@ IN: io.files.windows [ [ handle>> ] dip d>w/w ] dip SetFilePointer INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ; -HOOK: open-append os ( path -- win32-file ) - -TUPLE: FileArgs - hFile lpBuffer nNumberOfBytesToRead - lpNumberOfBytesRet lpOverlapped ; - -C: FileArgs - -: make-FileArgs ( port -- ) - { - [ handle>> check-disposed ] - [ handle>> handle>> ] - [ buffer>> ] - [ buffer>> buffer-length ] - [ drop DWORD ] - [ FileArgs-overlapped ] - } cleave ; - -: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) - { - [ hFile>> ] - [ lpBuffer>> buffer-end ] - [ lpBuffer>> buffer-capacity ] - [ lpNumberOfBytesRet>> ] - [ lpOverlapped>> ] - } cleave ; - -: setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) - { - [ hFile>> ] - [ lpBuffer>> buffer@ ] - [ lpBuffer>> buffer-length ] - [ lpNumberOfBytesRet>> ] - [ lpOverlapped>> ] - } cleave ; - M: windows (file-reader) ( path -- stream ) open-read ; @@ -101,7 +266,7 @@ SYMBOLS: +read-only+ +hidden+ +system+ +sparse-file+ +reparse-point+ +compressed+ +offline+ +not-content-indexed+ +encrypted+ ; -: win32-file-attribute ( n attr symbol -- ) +: win32-file-attribute ( n symbol attr -- ) rot mask? [ , ] [ drop ] if ; : win32-file-attributes ( n -- seq ) @@ -130,3 +295,59 @@ SYMBOLS: +read-only+ +hidden+ +system+ : (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- ) [ timestamp>FILETIME ] tri@ SetFileTime win32-error=0/f ; + +M: winnt cwd + MAX_UNICODE_PATH dup + [ GetCurrentDirectory win32-error=0/f ] keep + utf16n alien>string ; + +M: winnt cd + SetCurrentDirectory win32-error=0/f ; + +CONSTANT: unicode-prefix "\\\\?\\" + +M: winnt root-directory? ( path -- ? ) + { + { [ dup empty? ] [ drop f ] } + { [ dup [ path-separator? ] all? ] [ drop t ] } + { [ dup trim-tail-separators { [ length 2 = ] + [ second CHAR: : = ] } 1&& ] [ drop t ] } + { [ dup unicode-prefix head? ] + [ trim-tail-separators length unicode-prefix length 2 + = ] } + [ drop f ] + } cond ; + +: prepend-prefix ( string -- string' ) + dup unicode-prefix head? [ + unicode-prefix prepend + ] unless ; + +TR: normalize-separators "/" "\\" ; + +M: winnt normalize-path ( string -- string' ) + absolute-path + normalize-separators + prepend-prefix ; + +M: winnt CreateFile-flags ( DWORD -- DWORD ) + FILE_FLAG_OVERLAPPED bitor ; + + + [ GetFileAttributesEx win32-error=0/f ] keep + [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ; + +PRIVATE> + +M: winnt open-append + [ dup windows-file-size ] [ drop 0 ] recover + [ (open-append) ] dip >>ptr ; + +M: winnt home + { + [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ] + [ "USERPROFILE" os-env ] + [ my-documents ] + } 0|| ; \ No newline at end of file diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index dfbbd33d2e..24d1d8e7b8 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -272,6 +272,6 @@ M: output-process-error error. { { [ os unix? ] [ "io.launcher.unix" require ] } - { [ os winnt? ] [ "io.launcher.windows.nt" require ] } + { [ os windows? ] [ "io.launcher.windows" require ] } [ ] } cond diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index fef6b076ba..4f6615ca5b 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -3,7 +3,8 @@ USING: io.files io.files.temp io.directories io.pathnames tools.test io.launcher arrays io namespaces continuations math io.encodings.binary io.encodings.ascii accessors kernel sequences io.encodings.utf8 destructors io.streams.duplex locals -concurrency.promises threads unix.process calendar unix ; +concurrency.promises threads unix.process calendar unix +unix.process debugger.unix io.timeouts io.launcher.unix ; [ ] [ [ "launcher-test-1" temp-file delete-file ] ignore-errors @@ -138,3 +139,22 @@ concurrency.promises threads unix.process calendar unix ; s 3 seconds ?promise-timeout 0 = ] ] unit-test + +! Make sure that subprocesses don't inherit our signal mask + +! First, ensure that the Factor VM ignores SIGPIPE +: send-sigpipe ( pid -- ) + "SIGPIPE" signal-names index 1 + + kill io-error ; + +[ ] [ current-process-handle send-sigpipe ] unit-test + +! Spawn a process +[ T{ signal f 13 } ] [ + "sleep 1000" run-detached + 1 seconds sleep + [ handle>> send-sigpipe ] + [ 2 seconds swap set-timeout ] + [ wait-for-process ] + tri +] unit-test diff --git a/basis/io/launcher/windows/nt/authors.txt b/basis/io/launcher/windows/nt/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/launcher/windows/nt/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor deleted file mode 100755 index c97c411d2c..0000000000 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ /dev/null @@ -1,196 +0,0 @@ -USING: io.launcher tools.test calendar accessors environment -namespaces kernel system arrays io io.files io.encodings.ascii -sequences parser assocs hashtables math continuations eval -io.files.temp io.directories io.pathnames splitting ; -IN: io.launcher.windows.nt.tests - -[ ] [ - - "notepad" >>command - 1/2 seconds >>timeout - "notepad" set -] unit-test - -[ f ] [ "notepad" get process-running? ] unit-test - -[ f ] [ "notepad" get process-started? ] unit-test - -[ ] [ "notepad" [ run-detached ] change ] unit-test - -[ "notepad" get wait-for-process ] must-fail - -[ t ] [ "notepad" get killed>> ] unit-test - -[ f ] [ "notepad" get process-running? ] unit-test - -[ - - "notepad" >>command - 1/2 seconds >>timeout - try-process -] must-fail - -[ - - "notepad" >>command - 1/2 seconds >>timeout - try-output-process -] must-fail - -: console-vm ( -- path ) - vm ".exe" ?tail [ ".com" append ] when ; - -[ ] [ - - console-vm "-quiet" "-run=hello-world" 3array >>command - "out.txt" temp-file >>stdout - try-process -] unit-test - -[ "Hello world" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ "( scratchpad ) " ] [ - - console-vm "-run=listener" 2array >>command - +closed+ >>stdin - +stdout+ >>stderr - ascii [ lines last ] with-process-reader -] unit-test - -: launcher-test-path ( -- str ) - "resource:basis/io/launcher/windows/nt/test" ; - -[ ] [ - launcher-test-path [ - - console-vm "-script" "stderr.factor" 3array >>command - "out.txt" temp-file >>stdout - "err.txt" temp-file >>stderr - try-process - ] with-directory -] unit-test - -[ "output" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ "error" ] [ - "err.txt" temp-file ascii file-lines first -] unit-test - -[ ] [ - launcher-test-path [ - - console-vm "-script" "stderr.factor" 3array >>command - "out.txt" temp-file >>stdout - +stdout+ >>stderr - try-process - ] with-directory -] unit-test - -[ "outputerror" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ "output" ] [ - launcher-test-path [ - - console-vm "-script" "stderr.factor" 3array >>command - "err2.txt" temp-file >>stderr - ascii stream-lines first - ] with-directory -] unit-test - -[ "error" ] [ - "err2.txt" temp-file ascii file-lines first -] unit-test - -[ t ] [ - launcher-test-path [ - - console-vm "-script" "env.factor" 3array >>command - ascii stream-contents - ] with-directory eval( -- alist ) - - os-envs = -] unit-test - -[ t ] [ - launcher-test-path [ - - console-vm "-script" "env.factor" 3array >>command - +replace-environment+ >>environment-mode - os-envs >>environment - ascii stream-contents - ] with-directory eval( -- alist ) - - os-envs = -] unit-test - -[ "B" ] [ - launcher-test-path [ - - console-vm "-script" "env.factor" 3array >>command - { { "A" "B" } } >>environment - ascii stream-contents - ] with-directory eval( -- alist ) - - "A" swap at -] unit-test - -[ f ] [ - launcher-test-path [ - - console-vm "-script" "env.factor" 3array >>command - { { "USERPROFILE" "XXX" } } >>environment - +prepend-environment+ >>environment-mode - ascii stream-contents - ] with-directory eval( -- alist ) - - "USERPROFILE" swap at "XXX" = -] unit-test - -2 [ - [ ] [ - - "cmd.exe /c dir" >>command - "dir.txt" temp-file >>stdout - try-process - ] unit-test - - [ ] [ "dir.txt" temp-file delete-file ] unit-test -] times - -[ "append-test" temp-file delete-file ] ignore-errors - -[ "Hello appender\r\nHello appender\r\n" ] [ - 2 [ - launcher-test-path [ - - console-vm "-script" "append.factor" 3array >>command - "append-test" temp-file >>stdout - try-process - ] with-directory - ] times - - "append-test" temp-file ascii file-contents -] unit-test - -[ "( scratchpad ) " ] [ - console-vm "-run=listener" 2array - ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream -] unit-test - -[ ] [ - console-vm "-run=listener" 2array - ascii [ "USE: system 0 exit" print ] with-process-writer -] unit-test - -[ ] [ - - console-vm "-run=listener" 2array >>command - "vocab:io/launcher/windows/nt/test/input.txt" >>stdin - try-process -] unit-test diff --git a/basis/io/launcher/windows/nt/nt.factor b/basis/io/launcher/windows/nt/nt.factor deleted file mode 100644 index 959bf93119..0000000000 --- a/basis/io/launcher/windows/nt/nt.factor +++ /dev/null @@ -1,110 +0,0 @@ -! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays continuations destructors io -io.backend.windows libc io.ports io.pipes windows.types math -windows.kernel32 windows namespaces make io.launcher kernel -sequences windows.errors assocs splitting system strings -io.launcher.windows io.files.windows io.backend io.files -io.files.private combinators shuffle accessors locals ; -IN: io.launcher.windows.nt - -: duplicate-handle ( handle -- handle' ) - GetCurrentProcess ! source process - swap handle>> ! handle - GetCurrentProcess ! target process - f [ ! target handle - DUPLICATE_SAME_ACCESS ! desired access - TRUE ! inherit handle - 0 ! options - DuplicateHandle win32-error=0/f - ] keep *void* &dispose ; - -! /dev/null simulation -: null-input ( -- pipe ) - (pipe) [ in>> &dispose ] [ out>> dispose ] bi ; - -: null-output ( -- pipe ) - (pipe) [ in>> dispose ] [ out>> &dispose ] bi ; - -: null-pipe ( mode -- pipe ) - { - { GENERIC_READ [ null-input ] } - { GENERIC_WRITE [ null-output ] } - } case ; - -! The below code is based on the example given in -! http://msdn2.microsoft.com/en-us/library/ms682499.aspx - -: redirect-default ( obj access-mode create-mode -- handle ) - 3drop f ; - -: redirect-closed ( obj access-mode create-mode -- handle ) - drop nip null-pipe ; - -:: redirect-file ( path access-mode create-mode -- handle ) - path normalize-path - access-mode - share-mode - default-security-attributes - create-mode - FILE_ATTRIBUTE_NORMAL ! flags and attributes - f ! template file - CreateFile dup invalid-handle? &dispose ; - -: redirect-append ( path access-mode create-mode -- handle ) - [ path>> ] 2dip - drop OPEN_ALWAYS - redirect-file - dup 0 FILE_END set-file-pointer ; - -: redirect-handle ( handle access-mode create-mode -- handle ) - 2drop ; - -: redirect-stream ( stream access-mode create-mode -- handle ) - [ underlying-handle ] 2dip redirect-handle ; - -: redirect ( obj access-mode create-mode -- handle ) - { - { [ pick not ] [ redirect-default ] } - { [ pick +closed+ eq? ] [ redirect-closed ] } - { [ pick string? ] [ redirect-file ] } - { [ pick appender? ] [ redirect-append ] } - { [ pick win32-file? ] [ redirect-handle ] } - [ redirect-stream ] - } cond - dup [ dup t set-inherit handle>> ] when ; - -: redirect-stdout ( process args -- handle ) - drop - stdout>> - GENERIC_WRITE - CREATE_ALWAYS - redirect - STD_OUTPUT_HANDLE GetStdHandle or ; - -: redirect-stderr ( process args -- handle ) - over stderr>> +stdout+ eq? [ - nip - lpStartupInfo>> hStdOutput>> - ] [ - drop - stderr>> - GENERIC_WRITE - CREATE_ALWAYS - redirect - STD_ERROR_HANDLE GetStdHandle or - ] if ; - -: redirect-stdin ( process args -- handle ) - drop - stdin>> - GENERIC_READ - OPEN_EXISTING - redirect - STD_INPUT_HANDLE GetStdHandle or ; - -M: winnt fill-redirection ( process args -- ) - dup lpStartupInfo>> - [ [ redirect-stdout ] dip hStdOutput<< ] - [ [ redirect-stderr ] dip hStdError<< ] - [ [ redirect-stdin ] dip hStdInput<< ] 3tri ; diff --git a/basis/io/launcher/windows/nt/platforms.txt b/basis/io/launcher/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/launcher/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/launcher/windows/nt/test/append.factor b/basis/io/launcher/windows/test/append.factor similarity index 93% rename from basis/io/launcher/windows/nt/test/append.factor rename to basis/io/launcher/windows/test/append.factor index 4c1de0c5f9..2943b53f70 100644 --- a/basis/io/launcher/windows/nt/test/append.factor +++ b/basis/io/launcher/windows/test/append.factor @@ -1,2 +1,2 @@ -USE: io -"Hello appender" print +USE: io +"Hello appender" print diff --git a/basis/io/launcher/windows/nt/test/env.factor b/basis/io/launcher/windows/test/env.factor similarity index 100% rename from basis/io/launcher/windows/nt/test/env.factor rename to basis/io/launcher/windows/test/env.factor diff --git a/basis/io/launcher/windows/nt/test/input.txt b/basis/io/launcher/windows/test/input.txt old mode 100755 new mode 100644 similarity index 95% rename from basis/io/launcher/windows/nt/test/input.txt rename to basis/io/launcher/windows/test/input.txt index 99c3cc6fb1..a225e1f1b9 --- a/basis/io/launcher/windows/nt/test/input.txt +++ b/basis/io/launcher/windows/test/input.txt @@ -1 +1 @@ -USE: system 0 exit +USE: system 0 exit diff --git a/basis/io/launcher/windows/nt/test/stderr.factor b/basis/io/launcher/windows/test/stderr.factor similarity index 95% rename from basis/io/launcher/windows/nt/test/stderr.factor rename to basis/io/launcher/windows/test/stderr.factor index f22f50e406..9b2df73860 100644 --- a/basis/io/launcher/windows/nt/test/stderr.factor +++ b/basis/io/launcher/windows/test/stderr.factor @@ -1,5 +1,5 @@ -USE: io -USE: namespaces - -"output" write flush -"error" error-stream get stream-write error-stream get stream-flush +USE: io +USE: namespaces + +"output" write flush +"error" error-stream get stream-write error-stream get stream-flush diff --git a/basis/io/launcher/windows/windows-tests.factor b/basis/io/launcher/windows/windows-tests.factor index 1a3fe823a5..39b5e36cbb 100644 --- a/basis/io/launcher/windows/windows-tests.factor +++ b/basis/io/launcher/windows/windows-tests.factor @@ -1,5 +1,9 @@ +USING: accessors arrays assocs calendar continuations +environment eval hashtables io io.directories +io.encodings.ascii io.files io.files.temp io.launcher +io.launcher.windows io.pathnames kernel math namespaces parser +sequences splitting system tools.test ; IN: io.launcher.windows.tests -USING: tools.test io.launcher.windows ; [ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test @@ -8,3 +12,194 @@ USING: tools.test io.launcher.windows ; [ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test [ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test + +[ ] [ + + "notepad" >>command + 1/2 seconds >>timeout + "notepad" set +] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ f ] [ "notepad" get process-started? ] unit-test + +[ ] [ "notepad" [ run-detached ] change ] unit-test + +[ "notepad" get wait-for-process ] must-fail + +[ t ] [ "notepad" get killed>> ] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ + + "notepad" >>command + 1/2 seconds >>timeout + try-process +] must-fail + +[ + + "notepad" >>command + 1/2 seconds >>timeout + try-output-process +] must-fail + +: console-vm ( -- path ) + vm ".exe" ?tail [ ".com" append ] when ; + +[ ] [ + + console-vm "-quiet" "-run=hello-world" 3array >>command + "out.txt" temp-file >>stdout + try-process +] unit-test + +[ "Hello world" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "( scratchpad ) " ] [ + + console-vm "-run=listener" 2array >>command + +closed+ >>stdin + +stdout+ >>stderr + ascii [ lines last ] with-process-reader +] unit-test + +: launcher-test-path ( -- str ) + "resource:basis/io/launcher/windows/test" ; + +[ ] [ + launcher-test-path [ + + console-vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + "err.txt" temp-file >>stderr + try-process + ] with-directory +] unit-test + +[ "output" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "error" ] [ + "err.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + launcher-test-path [ + + console-vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + +stdout+ >>stderr + try-process + ] with-directory +] unit-test + +[ "outputerror" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "output" ] [ + launcher-test-path [ + + console-vm "-script" "stderr.factor" 3array >>command + "err2.txt" temp-file >>stderr + ascii stream-lines first + ] with-directory +] unit-test + +[ "error" ] [ + "err2.txt" temp-file ascii file-lines first +] unit-test + +[ t ] [ + launcher-test-path [ + + console-vm "-script" "env.factor" 3array >>command + ascii stream-contents + ] with-directory eval( -- alist ) + + os-envs = +] unit-test + +[ t ] [ + launcher-test-path [ + + console-vm "-script" "env.factor" 3array >>command + +replace-environment+ >>environment-mode + os-envs >>environment + ascii stream-contents + ] with-directory eval( -- alist ) + + os-envs = +] unit-test + +[ "B" ] [ + launcher-test-path [ + + console-vm "-script" "env.factor" 3array >>command + { { "A" "B" } } >>environment + ascii stream-contents + ] with-directory eval( -- alist ) + + "A" swap at +] unit-test + +[ f ] [ + launcher-test-path [ + + console-vm "-script" "env.factor" 3array >>command + { { "USERPROFILE" "XXX" } } >>environment + +prepend-environment+ >>environment-mode + ascii stream-contents + ] with-directory eval( -- alist ) + + "USERPROFILE" swap at "XXX" = +] unit-test + +2 [ + [ ] [ + + "cmd.exe /c dir" >>command + "dir.txt" temp-file >>stdout + try-process + ] unit-test + + [ ] [ "dir.txt" temp-file delete-file ] unit-test +] times + +[ "append-test" temp-file delete-file ] ignore-errors + +[ "Hello appender\r\nHello appender\r\n" ] [ + 2 [ + launcher-test-path [ + + console-vm "-script" "append.factor" 3array >>command + "append-test" temp-file >>stdout + try-process + ] with-directory + ] times + + "append-test" temp-file ascii file-contents +] unit-test + +[ "( scratchpad ) " ] [ + console-vm "-run=listener" 2array + ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream +] unit-test + +[ ] [ + console-vm "-run=listener" 2array + ascii [ "USE: system 0 exit" print ] with-process-writer +] unit-test + +[ ] [ + + console-vm "-run=listener" 2array >>command + "vocab:io/launcher/windows/test/input.txt" >>stdin + try-process +] unit-test diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index ecf730716a..0b58df2e43 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.data arrays continuations io -io.backend.windows io.pipes.windows.nt io.pathnames libc -io.ports windows.types math windows.kernel32 namespaces make -io.launcher kernel sequences windows.errors splitting system -threads init strings combinators io.backend accessors -concurrency.flags io.files assocs io.files.private windows -destructors classes classes.struct specialized-arrays -debugger prettyprint ; +USING: accessors alien alien.c-types alien.data arrays assocs +classes classes.struct combinators concurrency.flags +continuations debugger destructors init io io.backend +io.backend.windows io.files io.files.private io.files.windows +io.launcher io.pathnames io.pipes io.pipes.windows io.ports +kernel libc locals make math namespaces prettyprint sequences +specialized-arrays splitting +strings system threads windows windows.errors windows.handles +windows.kernel32 windows.types ; SPECIALIZED-ARRAY: ushort SPECIALIZED-ARRAY: void* IN: io.launcher.windows @@ -174,3 +175,104 @@ M: windows wait-for-processes ( -- ? ) WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; + +: duplicate-handle ( handle -- handle' ) + GetCurrentProcess ! source process + swap handle>> ! handle + GetCurrentProcess ! target process + f [ ! target handle + DUPLICATE_SAME_ACCESS ! desired access + TRUE ! inherit handle + 0 ! options + DuplicateHandle win32-error=0/f + ] keep *void* &dispose ; + +! /dev/null simulation +: null-input ( -- pipe ) + (pipe) [ in>> &dispose ] [ out>> dispose ] bi ; + +: null-output ( -- pipe ) + (pipe) [ out>> &dispose ] [ in>> dispose ] bi ; + +: null-pipe ( mode -- pipe ) + { + { GENERIC_READ [ null-input ] } + { GENERIC_WRITE [ null-output ] } + } case ; + +! The below code is based on the example given in +! http://msdn2.microsoft.com/en-us/library/ms682499.aspx + +: redirect-default ( obj access-mode create-mode -- handle ) + 3drop f ; + +: redirect-closed ( obj access-mode create-mode -- handle ) + drop nip null-pipe ; + +:: redirect-file ( path access-mode create-mode -- handle ) + path normalize-path + access-mode + share-mode + default-security-attributes + create-mode + FILE_ATTRIBUTE_NORMAL ! flags and attributes + f ! template file + CreateFile check-invalid-handle &dispose ; + +: redirect-append ( path access-mode create-mode -- handle ) + [ path>> ] 2dip + drop OPEN_ALWAYS + redirect-file + dup 0 FILE_END set-file-pointer ; + +: redirect-handle ( handle access-mode create-mode -- handle ) + 2drop ; + +: redirect-stream ( stream access-mode create-mode -- handle ) + [ underlying-handle ] 2dip redirect-handle ; + +: redirect ( obj access-mode create-mode -- handle ) + { + { [ pick not ] [ redirect-default ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick string? ] [ redirect-file ] } + { [ pick appender? ] [ redirect-append ] } + { [ pick win32-file? ] [ redirect-handle ] } + [ redirect-stream ] + } cond + dup [ dup t set-inherit handle>> ] when ; + +: redirect-stdout ( process args -- handle ) + drop + stdout>> + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_OUTPUT_HANDLE GetStdHandle or ; + +: redirect-stderr ( process args -- handle ) + over stderr>> +stdout+ eq? [ + nip + lpStartupInfo>> hStdOutput>> + ] [ + drop + stderr>> + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_ERROR_HANDLE GetStdHandle or + ] if ; + +: redirect-stdin ( process args -- handle ) + drop + stdin>> + GENERIC_READ + OPEN_EXISTING + redirect + STD_INPUT_HANDLE GetStdHandle or ; + +M: winnt fill-redirection ( process args -- ) + dup lpStartupInfo>> + [ [ redirect-stdout ] dip hStdOutput<< ] + [ [ redirect-stderr ] dip hStdError<< ] + [ [ redirect-stdin ] dip hStdInput<< ] 3tri ; diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index 3eabfc4e7f..d99bebbdc3 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -44,7 +44,7 @@ HELP: with-mapped-array { $values { "path" "a pathname string" } { "c-type" c-type } { "quot" quotation } } -{ $description "Memory-maps a file for reading and writing as a mapped-array of the given c-type. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $description "Memory-maps a file for reading and writing, wrapping it in a specialized array with the given element type. The mapped file is disposed of when the quotation returns, or if an error is thrown." } { $examples { $unchecked-example "USING: alien.c-types io.mmap prettyprint specialized-arrays ;" @@ -81,7 +81,7 @@ ARTICLE: "io.mmap.examples" "Memory-mapped file examples" "" "\"mydata.dat\" char [" " 4 " - " [ reverse! drop ] map! drop" + " [ reverse! drop ] each" "] with-mapped-array" } "Normalize a file containing packed quadrupes of floats:" diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index b1191082b3..bd18c12eda 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -1,8 +1,7 @@ -USING: alien alien.c-types arrays destructors generic io.mmap -io.ports io.backend.windows io.files.windows io.backend.windows.privileges -io.mmap.private kernel libc math math.bitwise namespaces quotations sequences -windows windows.advapi32 windows.kernel32 io.backend system -accessors locals windows.errors literals ; +USING: accessors destructors windows.privileges +io.files.windows io.mmap io.mmap.private kernel literals locals +math math.bitwise system windows.errors windows.handles +windows.kernel32 ; IN: io.mmap.windows : create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE ) diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor old mode 100644 new mode 100755 diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor index 4649b85668..6347a979a6 100644 --- a/basis/io/monitors/monitors-docs.factor +++ b/basis/io/monitors/monitors-docs.factor @@ -117,8 +117,9 @@ $nl "An example which watches a directory for changes:" { $code "USE: io.monitors" + "" ": watch-loop ( monitor -- )" - " dup next-change path>> print nl nl flush watch-loop ;" + " dup next-change path>> print flush watch-loop ;" "" ": watch-directory ( path -- )" " [ t [ watch-loop ] with-monitor ] with-monitors ;" diff --git a/basis/io/monitors/monitors-tests.factor b/basis/io/monitors/monitors-tests.factor index ac17c4a39f..d084416030 100644 --- a/basis/io/monitors/monitors-tests.factor +++ b/basis/io/monitors/monitors-tests.factor @@ -1,9 +1,9 @@ -IN: io.monitors.tests USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint destructors io.timeouts io.files.temp io.directories io.directories.hierarchy io.pathnames accessors concurrency.promises ; +IN: io.monitors.tests os { winnt linux macosx } member? [ [ diff --git a/basis/io/monitors/monitors.factor b/basis/io/monitors/monitors.factor index f3e744a59a..bc9638ce4d 100644 --- a/basis/io/monitors/monitors.factor +++ b/basis/io/monitors/monitors.factor @@ -77,6 +77,6 @@ SYMBOL: +rename-file+ { { [ os macosx? ] [ "io.monitors.macosx" require ] } { [ os linux? ] [ "io.monitors.linux" require ] } - { [ os winnt? ] [ "io.monitors.windows.nt" require ] } + { [ os windows? ] [ "io.monitors.windows" require ] } { [ os bsd? ] [ ] } } cond diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor old mode 100644 new mode 100755 diff --git a/basis/io/monitors/windows/nt/authors.txt b/basis/io/monitors/windows/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/io/monitors/windows/nt/authors.txt rename to basis/io/monitors/windows/authors.txt diff --git a/basis/io/monitors/windows/nt/nt-tests.factor b/basis/io/monitors/windows/nt/nt-tests.factor deleted file mode 100644 index a7ee649400..0000000000 --- a/basis/io/monitors/windows/nt/nt-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: io.monitors.windows.nt.tests -USING: io.monitors.windows.nt tools.test ; - - diff --git a/basis/io/monitors/windows/nt/platforms.txt b/basis/io/monitors/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/monitors/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/backend/windows/nt/platforms.txt b/basis/io/monitors/windows/platforms.txt similarity index 100% rename from basis/io/backend/windows/nt/platforms.txt rename to basis/io/monitors/windows/platforms.txt diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/windows.factor similarity index 95% rename from basis/io/monitors/windows/nt/nt.factor rename to basis/io/monitors/windows/windows.factor index e6a055a9d6..8887d718d1 100644 --- a/basis/io/monitors/windows/nt/nt.factor +++ b/basis/io/monitors/windows/windows.factor @@ -3,12 +3,12 @@ USING: alien alien.c-types alien.data alien.strings libc destructors locals kernel math assocs namespaces make continuations sequences hashtables sorting arrays combinators math.bitwise strings -system accessors threads splitting io.backend io.backend.windows -io.backend.windows.nt io.files.windows.nt io.monitors io.ports +system accessors threads splitting io.backend +io.files.windows io.monitors io.ports io.buffers io.files io.timeouts io.encodings.string literals io.encodings.utf16n io windows.errors windows.kernel32 windows.types io.pathnames classes.struct ; -IN: io.monitors.windows.nt +IN: io.monitors.windows : open-directory ( path -- handle ) normalize-path diff --git a/basis/io/pipes/pipes-tests.factor b/basis/io/pipes/pipes-tests.factor index 5ece6cfdf3..0f15faff90 100644 --- a/basis/io/pipes/pipes-tests.factor +++ b/basis/io/pipes/pipes-tests.factor @@ -1,7 +1,7 @@ USING: io io.pipes io.streams.string io.encodings.utf8 -io.streams.duplex io.encodings io.timeouts namespaces -continuations tools.test kernel calendar destructors -accessors debugger math ; +io.encodings.binary io.streams.duplex io.encodings io.timeouts +namespaces continuations tools.test kernel calendar destructors +accessors debugger math sequences ; IN: io.pipes.tests [ "Hello" ] [ @@ -28,7 +28,7 @@ IN: io.pipes.tests [ utf8 [ - 5 seconds over set-timeout + 1 seconds over set-timeout stream-readln ] with-disposal ] must-fail @@ -42,3 +42,12 @@ IN: io.pipes.tests ] curry ignore-errors ] times ] unit-test + +! 0 read should not block +[ f ] [ + [ + binary &dispose + in>> + [ 0 read ] with-input-stream + ] with-destructors +] unit-test diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index 73de6bf1a2..aee69f640e 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -60,6 +60,6 @@ PRIVATE> { { [ os unix? ] [ "io.pipes.unix" require ] } - { [ os winnt? ] [ "io.pipes.windows.nt" require ] } + { [ os windows? ] [ "io.pipes.windows" require ] } [ ] } cond diff --git a/basis/cpu/arm/assembler/authors.txt b/basis/io/pipes/windows/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/cpu/arm/assembler/authors.txt rename to basis/io/pipes/windows/authors.txt diff --git a/basis/io/pipes/windows/nt/platforms.txt b/basis/io/pipes/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/pipes/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/backend/windows/nt/privileges/platforms.txt b/basis/io/pipes/windows/platforms.txt similarity index 100% rename from basis/io/backend/windows/nt/privileges/platforms.txt rename to basis/io/pipes/windows/platforms.txt diff --git a/basis/io/pipes/windows/nt/nt.factor b/basis/io/pipes/windows/windows.factor similarity index 77% rename from basis/io/pipes/windows/nt/nt.factor rename to basis/io/pipes/windows/windows.factor index d58e5e3d5f..ea906de966 100644 --- a/basis/io/pipes/windows/nt/nt.factor +++ b/basis/io/pipes/windows/windows.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays destructors io io.backend.windows libc -windows.types math.bitwise windows.kernel32 windows namespaces -make kernel sequences windows.errors assocs math.parser system -random combinators accessors io.pipes io.ports literals ; -IN: io.pipes.windows.nt +USING: accessors alien alien.c-types arrays assocs combinators +destructors io io.files.windows io.pipes +io.ports kernel libc literals make math.bitwise math.parser +namespaces random sequences system windows windows.errors +windows.kernel32 windows.types ; +IN: io.pipes.windows ! This code is based on ! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 8517910b0f..6c2f75ec80 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -46,11 +46,17 @@ M: input-port stream-read1 dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline : read-step ( count port -- byte-array/f ) - dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ; + { + { [ over 0 = ] [ 2drop f ] } + { [ dup wait-to-read ] [ 2drop f ] } + [ buffer>> buffer-read ] + } cond ; + +: prepare-read ( count stream -- count stream ) + dup check-disposed [ 0 max >fixnum ] dip ; inline M: input-port stream-read-partial ( max stream -- byte-array/f ) - dup check-disposed - [ 0 max >integer ] dip read-step ; + prepare-read read-step ; : read-loop ( count port accum -- ) pick over length - dup 0 > [ @@ -64,8 +70,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f ) ] if ; M: input-port stream-read - dup check-disposed - [ 0 max >fixnum ] dip + prepare-read 2dup read-step dup [ pick over length > [ pick diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor index fa5acbd054..4dd8efdbe3 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -1,9 +1,9 @@ +USING: calendar classes concurrency.semaphores help.markup +help.syntax io io.sockets io.sockets.secure math quotations ; IN: io.servers.connection -USING: help help.syntax help.markup io io.sockets -io.sockets.secure concurrency.semaphores calendar classes math ; ARTICLE: "server-config" "Threaded server configuration" -"The " { $link threaded-server } " tuple has a variety of slots which can be set before starting the server with " { $link start-server } " or " { $link start-server* } "." +"The " { $link threaded-server } " tuple has a variety of slots which can be set before starting the server with " { $link start-server } "." { $subsections "server-config-logging" "server-config-listen" @@ -66,13 +66,13 @@ ARTICLE: "io.servers.connection" "Threaded servers" "The server must be configured before it can be started." { $subsections "server-config" } "Starting the server:" -{ $subsections - start-server - start-server* - wait-for-server -} +{ $subsections start-server } "Stopping the server:" { $subsections stop-server } +"Waiting for the server to stop:" +{ $subsections wait-for-server } +"Combinator for running a server:" +{ $subsections with-threaded-server } "From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:" { $subsections stop-this-server @@ -105,30 +105,32 @@ HELP: handle-client* HELP: start-server { $values { "threaded-server" threaded-server } } -{ $description "Starts a threaded server." } +{ $description "Starts a threaded server and returns after the server is fully running. Throws an error if any of the ports cannot be aquired." } { $notes "Use " { $link stop-server } " or " { $link stop-this-server } " to stop the server." } ; -HELP: wait-for-server -{ $values { "threaded-server" threaded-server } } -{ $description "Waits for a threaded server to begin accepting connections." } ; - -HELP: start-server* -{ $values { "threaded-server" threaded-server } } -{ $description "Starts a threaded server, returning as soon as it is ready to begin accepting connections." } ; - HELP: stop-server { $values { "threaded-server" threaded-server } } -{ $description "Stops a threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ; +{ $description "Stops a threaded server, preventing it from accepting any more connections. All client connections which have already been opened continue to be serviced." } ; + +HELP: wait-for-server +{ $values { "threaded-server" threaded-server } } +{ $description "Waits for a threaded server to stop serving new connections." } ; HELP: stop-this-server -{ $description "Stops the current threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ; +{ $description "Stops the current threaded server, preventing it from accepting any more connections. All client connections which have already been opened continue to be serviced." } ; + +HELP: with-threaded-server +{ $values + { "threaded-server" threaded-server } { "quot" quotation } +} +{ $description "Runs a server and calls a quotation, stopping the server once the quotation returns." } ; HELP: secure-port -{ $values { "n" { $maybe integer } } } -{ $description "Outputs the port number on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." } +{ $values { "n/f" { $maybe integer } } } +{ $description "Outputs one of the port numbers on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." } { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ; HELP: insecure-port -{ $values { "n" { $maybe integer } } } -{ $description "Outputs the port number on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." } +{ $values { "n/f" { $maybe integer } } } +{ $description "Outputs one of the port numbers on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." } { $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ; diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index 14100d3f04..72f4706957 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -1,7 +1,8 @@ +USING: accessors calendar concurrency.promises fry io +io.encodings.ascii io.servers.connection +io.servers.connection.private io.sockets kernel namespaces +sequences threads tools.test ; IN: io.servers.connection -USING: tools.test io.servers.connection io.sockets namespaces -io.servers.connection.private kernel accessors sequences -concurrency.promises io.encodings.ascii io threads calendar ; [ t ] [ ascii listen-on empty? ] unit-test @@ -27,12 +28,19 @@ concurrency.promises io.encodings.ascii io threads calendar ; init-server semaphore>> count>> ] unit-test -[ ] [ +[ "Hello world." ] [ ascii 5 >>max-connections 0 >>insecure [ "Hello world." write stop-this-server ] >>handler - dup start-server* sockets>> first addr>> port>> "port" set + [ + "localhost" insecure-port ascii drop stream-contents + ] with-threaded-server ] unit-test -[ "Hello world." ] [ "localhost" "port" get ascii drop stream-contents ] unit-test +[ ] [ + ascii + 5 >>max-connections + 0 >>insecure + start-server [ '[ _ wait-for-server ] in-thread ] [ stop-server ] bi +] unit-test diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 4dfdc13bc9..fbe5421cea 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -1,28 +1,53 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: continuations destructors kernel math math.parser -namespaces parser sequences strings prettyprint -quotations combinators logging calendar assocs present -fry accessors arrays io io.sockets io.encodings.ascii -io.sockets.secure io.files io.streams.duplex io.timeouts -io.encodings threads make concurrency.combinators -concurrency.semaphores concurrency.flags -combinators.short-circuit ; +USING: accessors arrays calendar combinators +combinators.short-circuit concurrency.combinators +concurrency.count-downs concurrency.flags +concurrency.semaphores continuations debugger destructors fry +io io.sockets io.sockets.secure io.streams.duplex io.styles +io.timeouts kernel logging make math math.parser namespaces +present prettyprint random sequences sets strings threads ; +FROM: namespaces => set ; IN: io.servers.connection -TUPLE: threaded-server +TUPLE: threaded-server < identity-tuple name log-level secure insecure secure-config -sockets +servers max-connections semaphore timeout encoding handler -ready ; +server-stopped ; + +SYMBOL: running-servers +running-servers [ HS{ } clone ] initialize + +ERROR: server-already-running threaded-server ; + +ERROR: server-not-running threaded-server ; + + : local-server ( port -- addrspec ) "localhost" swap ; @@ -33,10 +58,8 @@ ready ; "server" >>name DEBUG >>log-level >>secure-config - V{ } clone >>sockets 1 minutes >>timeout [ "No handler quotation" throw ] >>handler - >>ready swap >>encoding ; : ( encoding -- threaded-server ) @@ -46,16 +69,27 @@ GENERIC: handle-client* ( threaded-server -- ) insecure ( addrspec -- addrspec' ) - dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ; +GENERIC: (>insecure) ( obj -- obj ) + +M: inet (>insecure) ; +M: inet4 (>insecure) ; +M: inet6 (>insecure) ; +M: local (>insecure) ; +M: integer (>insecure) internet-server ; +M: string (>insecure) internet-server ; +M: array (>insecure) [ (>insecure) ] map ; +M: f (>insecure) ; + +: >insecure ( obj -- seq ) + (>insecure) dup sequence? [ 1array ] unless ; : >secure ( addrspec -- addrspec' ) >insecure - dup { [ secure? ] [ not ] } 1|| [ ] unless ; + [ dup { [ secure? ] [ not ] } 1|| [ ] unless ] map ; : listen-on ( threaded-server -- addrspecs ) - [ secure>> >secure ] [ insecure>> >insecure ] bi - [ resolve-host ] bi@ append ; + [ secure>> >secure ] [ insecure>> >insecure ] bi append + [ resolve-host ] map concat ; : accepted-connection ( remote local -- ) [ @@ -81,57 +115,72 @@ M: threaded-server handle-client* handler>> call( -- ) ; \ handle-client NOTICE add-error-logging -: thread-name ( server-name addrspec -- string ) +: client-thread-name ( addrspec -- string ) + [ threaded-server get name>> ] dip unparse-short " connection from " glue ; -: accept-connection ( threaded-server -- ) +: (accept-connection) ( server -- ) [ accept ] [ addr>> ] bi [ '[ _ _ _ handle-client ] ] - [ drop threaded-server get name>> swap thread-name ] 2bi + [ drop client-thread-name ] 2bi spawn drop ; -: accept-loop ( threaded-server -- ) - [ - threaded-server get semaphore>> - [ [ accept-connection ] with-semaphore ] - [ accept-connection ] - if* - ] [ accept-loop ] bi ; +: accept-connection ( server -- ) + threaded-server get semaphore>> + [ [ (accept-connection) ] with-semaphore ] + [ (accept-connection) ] + if* ; -: started-accept-loop ( threaded-server -- ) - threaded-server get - [ sockets>> push ] [ ready>> raise-flag ] bi ; +: accept-loop ( server -- ) + [ accept-connection ] [ accept-loop ] bi ; -: start-accept-loop ( addrspec -- ) - threaded-server get encoding>> - [ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ; +: start-accept-loop ( server -- ) accept-loop ; \ start-accept-loop NOTICE add-error-logging : init-server ( threaded-server -- threaded-server ) + >>server-stopped dup semaphore>> [ dup max-connections>> [ >>semaphore ] when* ] unless ; +ERROR: no-ports-configured threaded-server ; + +: (make-servers) ( theaded-server addrspecs -- servers ) + swap encoding>> + '[ [ _ |dispose ] map ] with-destructors ; + +: set-servers ( threaded-server -- threaded-server ) + dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty + >>servers ; + +: server-thread-name ( threaded-server addrspec -- string ) + [ name>> ] [ addr>> present ] bi* " server on " glue ; + : (start-server) ( threaded-server -- ) init-server dup threaded-server [ - [ ] [ name>> ] bi [ - [ listen-on [ start-accept-loop ] parallel-each ] - [ ready>> raise-flag ] - bi + [ ] [ name>> ] bi + [ + set-servers + dup add-running-server + dup servers>> + [ + [ nip '[ _ [ start-accept-loop ] with-disposal ] ] + [ server-thread-name ] 2bi spawn drop + ] with each ] with-logging ] with-variable ; PRIVATE> -: start-server ( threaded-server -- ) +: start-server ( threaded-server -- threaded-server ) #! Only create a secure-context if we want to listen on #! a secure port, otherwise start-server won't work at #! all if SSL is not available. - dup secure>> [ + dup dup secure>> [ dup secure-config>> [ (start-server) ] with-secure-context @@ -139,28 +188,62 @@ PRIVATE> (start-server) ] if ; -: wait-for-server ( threaded-server -- ) - ready>> wait-for-flag ; - -: start-server* ( threaded-server -- ) - [ [ start-server ] curry "Threaded server" spawn drop ] - [ wait-for-server ] - bi ; +: server-running? ( threaded-server -- ? ) + server-stopped>> [ value>> not ] [ f ] if* ; : stop-server ( threaded-server -- ) - [ f ] change-sockets drop dispose-each ; + dup server-running? [ + [ [ f ] change-servers drop dispose-each ] + [ remove-running-server ] + [ server-stopped>> raise-flag ] tri + ] [ + drop + ] if ; : stop-this-server ( -- ) threaded-server get stop-server ; -GENERIC: port ( addrspec -- n ) +: wait-for-server ( threaded-server -- ) + server-stopped>> wait-for-flag ; -M: integer port ; +: with-threaded-server ( threaded-server quot -- ) + [ start-server ] dip over + '[ + [ _ threaded-server _ with-variable ] + [ _ stop-server ] + [ ] cleanup + ] call ; inline -M: object port port>> ; +> port ] when ; +: first-port ( quot -- n/f ) + [ threaded-server get servers>> ] dip + filter [ f ] [ first addr>> port>> ] if-empty ; inline -: insecure-port ( -- n ) - threaded-server get dup [ insecure>> port ] when ; +PRIVATE> + +: secure-port ( -- n/f ) [ addr>> secure? ] first-port ; + +: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ; + +: secure-addr ( -- inet ) + threaded-server get servers>> [ addr>> secure? ] filter random ; + +: insecure-addr ( -- inet ) + threaded-server get servers>> [ addr>> secure? not ] filter random addr>> ; + +: server. ( threaded-server -- ) + [ [ "=== " write name>> ] [ ] bi write-object nl ] + [ servers>> [ addr>> present print ] each ] bi ; + +: all-servers ( -- sequence ) + running-servers get-global members ; + +: get-servers-named ( string -- sequence ) + [ all-servers ] dip '[ name>> _ = ] filter ; + +: servers. ( -- ) + all-servers [ server. ] each ; + +: stop-all-servers ( -- ) + all-servers [ stop-server ] each ; diff --git a/basis/io/sockets/icmp/authors.txt b/basis/io/sockets/icmp/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/io/sockets/icmp/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/io/sockets/icmp/icmp-docs.factor b/basis/io/sockets/icmp/icmp-docs.factor new file mode 100644 index 0000000000..b06aca98ac --- /dev/null +++ b/basis/io/sockets/icmp/icmp-docs.factor @@ -0,0 +1,85 @@ + +USING: help.markup help.syntax io.sockets ; + +IN: io.sockets.icmp + +HELP: icmp +{ $class-description + "Host name specifier for ICMP. " + "The " { $snippet "host" } " slot holds the host name. " + "New instances are created by calling " { $link } "." } +{ $notes + "This address specifier can be used with " { $link resolve-host } + " to obtain a list of IP addresses associated with the host name, " + "and attempts a connection to each one in turn until one succeeds. " + "Other network words do not accept this address specifier, and " + { $link resolve-host } " must be called directly; it is " + "then up to the application to pick the correct address from the " + "(possibly several) addresses associated to the host name." +} +{ $examples + { $code "\"www.apple.com\" " } +} ; + +HELP: +{ $values { "host" "a host name" } { "icmp" icmp } } +{ $description "Creates a new " { $link icmp } " address specifier." } ; + +HELP: icmp4 +{ $class-description + "IPv4 address specifier for ICMP. " + "The " { $snippet "host" } " slot holds the IPv4 address. " + "New instances are created by calling " { $link } "." +} +{ $notes + "Most applications do not operate on IPv4 addresses directly, " + "and instead should use the " { $link icmp } + " address specifier, or call " { $link resolve-host } "." +} +{ $examples + { $code "\"127.0.0.1\" " } +} ; + +HELP: +{ $values { "host" "an IPv4 address" } { "icmp4" icmp4 } } +{ $description "Creates a new " { $link icmp4 } " address specifier." } ; + +HELP: icmp6 +{ $class-description + "IPv6 address specifier for ICMP. " + "The " { $snippet "host" } " slot holds the IPv6 address. " + "New instances are created by calling " { $link } "." +} +{ $notes + "Most applications do not operate on IPv6 addresses directly, " + "and instead should use the " { $link icmp } + " address specifier, or call " { $link resolve-host } "." +} +{ $examples + { $code "\"::1\" " } +} ; + +HELP: +{ $values { "host" "an IPv6 address" } { "icmp6" icmp4 } } +{ $description "Creates a new " { $link icmp6 } " address specifier." } ; + +ARTICLE: "network-icmp" "ICMP" +"ICMP support is implemented for both IPv4 and IPv6 addresses, using the " +"operating system's host name resolution (via " { $link resolve-host } "):" +{ $subsections + icmp + +} +"IPv4 addresses, with no host name resolution:" +{ $subsections + icmp4 + +} +"IPv6 addresses, with no host name resolution:" +{ $subsections + icmp6 + +} ; + +ABOUT: "network-icmp" + diff --git a/basis/io/sockets/icmp/icmp-tests.factor b/basis/io/sockets/icmp/icmp-tests.factor new file mode 100644 index 0000000000..602ecc5060 --- /dev/null +++ b/basis/io/sockets/icmp/icmp-tests.factor @@ -0,0 +1,10 @@ + +USING: accessors destructors kernel io.sockets io.sockets.icmp +sequences tools.test ; + +IN: io.sockets.icmp.tests + +[ { } ] [ + "localhost" resolve-host + [ [ icmp4? ] [ icmp6? ] bi or not ] filter +] unit-test diff --git a/basis/io/sockets/icmp/icmp.factor b/basis/io/sockets/icmp/icmp.factor new file mode 100644 index 0000000000..80693c0963 --- /dev/null +++ b/basis/io/sockets/icmp/icmp.factor @@ -0,0 +1,61 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: accessors arrays combinators generic kernel io.sockets +io.sockets.private memoize sequences system vocabs.parser ; + +IN: io.sockets.icmp + +<< { + { [ os windows? ] [ "windows.winsock" ] } + { [ os unix? ] [ "unix.ffi" ] } +} cond use-vocab >> + +> ; + +MEMO: IPPROTO_ICMP6 ( -- protocol ) + "ipv6-icmp" getprotobyname proto>> ; + +GENERIC: with-icmp ( addrspec -- addrspec ) + +PRIVATE> + + +TUPLE: icmp4 < ipv4 ; + +C: icmp4 + +M: ipv4 with-icmp host>> ; + +M: icmp4 protocol drop IPPROTO_ICMP4 ; + +M: icmp4 port>> drop 0 ; + +M: icmp4 parse-sockaddr call-next-method with-icmp ; + +M: icmp4 resolve-host 1array ; + + +TUPLE: icmp6 < ipv6 ; + +C: icmp6 + +M: ipv6 with-icmp host>> ; + +M: icmp6 protocol drop IPPROTO_ICMP6 ; + +M: icmp6 port>> drop 0 ; + +M: icmp6 parse-sockaddr call-next-method with-icmp ; + +M: icmp6 resolve-host 1array ; + + +TUPLE: icmp < hostname ; + +C: icmp + +M: icmp resolve-host call-next-method [ with-icmp ] map ; diff --git a/basis/io/sockets/icmp/summary.txt b/basis/io/sockets/icmp/summary.txt new file mode 100644 index 0000000000..905ff71aa5 --- /dev/null +++ b/basis/io/sockets/icmp/summary.txt @@ -0,0 +1 @@ +Support for ICMP. diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor index 9f7a4f822f..fbbea7c4c3 100644 --- a/basis/io/sockets/secure/secure.factor +++ b/basis/io/sockets/secure/secure.factor @@ -39,7 +39,7 @@ HOOK: secure-socket-backend ( config -- context ) with-disposal ] with-scope ; inline -TUPLE: secure addrspec ; +TUPLE: secure { addrspec read-only } ; C: secure diff --git a/basis/io/sockets/sockets-tests.factor b/basis/io/sockets/sockets-tests.factor index 96ffbc5e18..56939f484f 100644 --- a/basis/io/sockets/sockets-tests.factor +++ b/basis/io/sockets/sockets-tests.factor @@ -58,7 +58,29 @@ io.streams.string ; [ "2001:6f8:37a:5:0:0:0:1" ] [ "2001:6f8:37a:5::1" T{ inet6 } [ inet-pton ] [ inet-ntop ] bi ] unit-test -[ t ] [ "localhost" 80 resolve-host length 1 >= ] unit-test +[ t t ] [ + "localhost" 80 resolve-host + [ length 1 >= ] + [ [ [ inet4? ] [ inet6? ] bi or ] all? ] bi +] unit-test + +[ t t ] [ + "localhost" resolve-host + [ length 1 >= ] + [ [ [ ipv4? ] [ ipv6? ] bi or ] all? ] bi +] unit-test + +[ t t ] [ + f resolve-host + [ length 1 >= ] + [ [ [ ipv4? ] [ ipv6? ] bi or ] all? ] bi +] unit-test + +[ t t ] [ + f 0 resolve-host + [ length 1 >= ] + [ [ [ ipv4? ] [ ipv6? ] bi or ] all? ] bi +] unit-test ! Smoke-test UDP [ ] [ "127.0.0.1" 0 "datagram1" set ] unit-test @@ -107,3 +129,6 @@ io.streams.string ; "hi\n" write flush readln readln ] with-client ] unit-test + +! Binding to all interfaces should work +[ ] [ f 0 dispose ] unit-test diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index a1260e80be..a48e6ffc95 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -1,12 +1,14 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman, +! Copyright (C) 2007, 2010 Slava Pestov, Doug Coleman, ! Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: generic kernel io.backend namespaces continuations sequences -arrays io.encodings io.ports io.streams.duplex io.encodings.ascii -alien.strings io.binary accessors destructors classes byte-arrays -parser alien.c-types math.parser splitting grouping math assocs -summary system vocabs.loader combinators present fry vocabs.parser -classes.struct alien.data ; +USING: accessors alien.c-types alien.data alien.strings arrays +assocs byte-arrays classes classes.struct combinators +combinators.short-circuit continuations destructors fry generic +grouping init io.backend io.binary io.encodings +io.encodings.ascii io.encodings.binary io.ports +io.streams.duplex kernel math math.parser memoize namespaces +parser present sequences splitting strings summary system +vocabs.loader vocabs.parser ; IN: io.sockets << { @@ -17,6 +19,10 @@ IN: io.sockets ! Addressing -TUPLE: abstract-inet host port ; - -M: abstract-inet present - [ host>> ":" ] [ port>> number>string ] bi 3append ; - -TUPLE: local path ; +TUPLE: local { path read-only } ; : ( path -- addrspec ) normalize-path local boa ; M: local present path>> "Unix domain socket: " prepend ; -TUPLE: inet4 < abstract-inet ; +M: local protocol drop 0 ; + +SLOT: port + +TUPLE: ipv4 { host ?string read-only } ; + +C: ipv4 + +M: ipv4 inet-ntop ( data addrspec -- str ) + drop 4 memory>byte-array [ number>string ] { } map-as "." join ; + +number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as ; + +ERROR: invalid-ipv4 string reason ; + +M: invalid-ipv4 summary drop "Invalid IPv4 address" ; + +PRIVATE> + +M: ipv4 inet-pton ( str addrspec -- data ) + drop [ parse-ipv4 ] [ invalid-ipv4 ] recover ; + +M: ipv4 address-size drop 4 ; + +M: ipv4 protocol-family drop PF_INET ; + +M: ipv4 sockaddr-size drop sockaddr-in heap-size ; + +M: ipv4 empty-sockaddr drop sockaddr-in ; + +M: ipv4 make-sockaddr ( inet -- sockaddr ) + sockaddr-in + AF_INET >>family + swap + [ port>> htons >>port ] + [ host>> "0.0.0.0" or ] + [ inet-pton *uint >>addr ] tri ; + +M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec ) + [ addr>> ] dip inet-ntop ; + +TUPLE: inet4 < ipv4 { port integer read-only } ; C: inet4 -M: inet4 inet-ntop ( data addrspec -- str ) - drop 4 memory>byte-array [ number>string ] { } map-as "." join ; - -ERROR: malformed-inet4 sequence ; -ERROR: bad-inet4-component string ; - -: parse-inet4 ( string -- seq ) - "." split dup length 4 = [ - malformed-inet4 - ] unless - [ - string>number - [ "Dotted component not a number" throw ] unless* - ] B{ } map-as ; - -ERROR: invalid-inet4 string reason ; - -M: invalid-inet4 summary drop "Invalid IPv4 address" ; - -M: inet4 inet-pton ( str addrspec -- data ) - drop - [ parse-inet4 ] [ invalid-inet4 ] recover ; - -M: inet4 address-size drop 4 ; - -M: inet4 protocol-family drop PF_INET ; - -M: inet4 sockaddr-size drop sockaddr-in heap-size ; - -M: inet4 empty-sockaddr drop sockaddr-in ; - -M: inet4 make-sockaddr ( inet -- sockaddr ) - sockaddr-in - AF_INET >>family - swap [ port>> htons >>port ] - [ host>> "0.0.0.0" or ] - [ inet-pton *uint >>addr ] tri ; +M: ipv4 with-port [ host>> ] dip ; M: inet4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec ) - [ [ addr>> ] dip inet-ntop ] - [ drop port>> ntohs ] 2bi ; + [ call-next-method ] [ drop port>> ntohs ] 2bi with-port ; -TUPLE: inet6 < abstract-inet ; +M: inet4 present + [ host>> ] [ port>> number>string ] bi ":" glue ; -C: inet6 +M: inet4 protocol drop 0 ; -M: inet6 inet-ntop ( data addrspec -- str ) +TUPLE: ipv6 { host ?string read-only } ; + +C: ipv6 + +M: ipv6 inet-ntop ( data addrspec -- str ) drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; -ERROR: invalid-inet6 string reason ; - -M: invalid-inet6 summary drop "Invalid IPv6 address" ; +ERROR: invalid-ipv6 string reason ; [ nip ] [ bad-ipv6-component ] if* ] { } map-as ; -: parse-inet6 ( string -- seq ) +: parse-ipv6 ( string -- seq ) [ f ] [ ":" split CHAR: . over last member? [ unclip-last - [ parse-ipv6-component ] [ parse-inet4 ] bi* append + [ parse-ipv6-component ] [ parse-ipv4 ] bi* append ] [ parse-ipv6-component ] if ] if-empty ; -: pad-inet6 ( string1 string2 -- seq ) +: pad-ipv6 ( string1 string2 -- seq ) 2dup [ length ] bi@ + 8 swap - - dup 0 < [ "More than 8 components" throw ] when + dup 0 < [ more-than-8-components ] when glue ; -: inet6-bytes ( seq -- bytes ) +: ipv6-bytes ( seq -- bytes ) [ 2 >be ] { } map-as B{ } concat-as ; PRIVATE> -M: inet6 inet-pton ( str addrspec -- data ) +M: ipv6 inet-pton ( str addrspec -- data ) drop - [ - "::" split1 [ parse-inet6 ] bi@ pad-inet6 inet6-bytes - ] [ invalid-inet6 ] recover ; + [ "::" split1 [ parse-ipv6 ] bi@ pad-ipv6 ipv6-bytes ] + [ invalid-ipv6 ] + recover ; -M: inet6 address-size drop 16 ; +M: ipv6 address-size drop 16 ; -M: inet6 protocol-family drop PF_INET6 ; +M: ipv6 protocol-family drop PF_INET6 ; -M: inet6 sockaddr-size drop sockaddr-in6 heap-size ; +M: ipv6 sockaddr-size drop sockaddr-in6 heap-size ; -M: inet6 empty-sockaddr drop sockaddr-in6 ; +M: ipv6 empty-sockaddr drop sockaddr-in6 ; -M: inet6 make-sockaddr ( inet -- sockaddr ) +M: ipv6 make-sockaddr ( inet -- sockaddr ) sockaddr-in6 AF_INET6 >>family - swap [ port>> htons >>port ] - [ host>> "::" or ] - [ inet-pton >>addr ] tri ; + swap + [ port>> htons >>port ] + [ host>> "::" or ] + [ inet-pton >>addr ] tri ; + +M: ipv6 parse-sockaddr + [ addr>> ] dip inet-ntop ; + +TUPLE: inet6 < ipv6 { port integer read-only } ; + +C: inet6 + +M: ipv6 with-port [ host>> ] dip ; M: inet6 parse-sockaddr - [ [ addr>> ] dip inet-ntop ] - [ drop port>> ntohs ] 2bi ; + [ call-next-method ] [ drop port>> ntohs ] 2bi with-port ; -M: f parse-sockaddr nip ; +M: inet6 present + [ host>> ] [ port>> number>string ] bi ":" glue ; + +M: inet6 protocol drop 0 ; > [ class ] bi@ assert= pick class byte-array assert= ; +: check-connectionless-port ( port -- port ) + dup { [ datagram-port? ] [ raw-port? ] } 1|| [ invalid-port ] unless ; + +: check-send ( packet addrspec port -- packet addrspec port ) + check-connectionless-port dup check-disposed check-port ; + +: check-receive ( port -- port ) + check-connectionless-port dup check-disposed ; + HOOK: (send) io-backend ( packet addrspec datagram -- ) : addrinfo>addrspec ( addrinfo -- addrspec ) @@ -247,17 +291,11 @@ HOOK: (send) io-backend ( packet addrspec datagram -- ) HOOK: addrinfo-error io-backend ( n -- ) -: resolve-passive-host ( -- addrspecs ) - { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ; - : prepare-addrinfo ( -- addrinfo ) addrinfo PF_UNSPEC >>family IPPROTO_TCP >>protocol ; -: fill-in-ports ( addrspecs port -- addrspecs ) - '[ _ >>port ] map ; - PRIVATE> : ( remote encoding -- stream local ) @@ -297,30 +335,63 @@ SYMBOL: remote-address >>addr ] with-destructors ; +: ( addrspec -- datagram ) + [ + [ (raw) |dispose ] keep + [ drop raw-port ] [ get-local-address ] 2bi + >>addr + ] with-destructors ; + : receive ( datagram -- packet addrspec ) - check-datagram-port + check-receive [ (receive) ] [ addr>> ] bi parse-sockaddr ; : send ( packet addrspec datagram -- ) - check-datagram-send (send) ; + check-send (send) ; + +MEMO: ipv6-supported? ( -- ? ) + [ "::1" 0 binary dispose t ] [ drop f ] recover ; + +[ \ ipv6-supported? reset-memoized ] "io.sockets" add-startup-hook GENERIC: resolve-host ( addrspec -- seq ) -TUPLE: inet < abstract-inet ; +HOOK: resolve-localhost os ( -- obj ) + +TUPLE: hostname { host ?string read-only } ; + +TUPLE: inet < hostname port ; + +M: inet present + [ host>> ] [ port>> number>string ] bi ":" glue ; C: inet +M: string resolve-host + f prepare-addrinfo f + [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct + [ parse-addrinfo-list ] keep freeaddrinfo ; + +M: hostname resolve-host + host>> resolve-host ; + M: inet resolve-host - [ port>> ] [ host>> ] bi [ - f prepare-addrinfo f - [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct - [ parse-addrinfo-list ] keep freeaddrinfo - ] [ resolve-passive-host ] if* - swap fill-in-ports ; + [ call-next-method ] [ port>> ] bi '[ _ with-port ] map ; -M: f resolve-host drop { } ; +M: inet4 resolve-host 1array ; -M: object resolve-host 1array ; +M: inet6 resolve-host 1array ; + +M: local resolve-host 1array ; + +M: f resolve-host + drop resolve-localhost ; + +M: object resolve-localhost + ipv6-supported? + { T{ ipv4 f "0.0.0.0" } T{ ipv6 f "::" } } + { T{ ipv4 f "0.0.0.0" } } + ? ; : host-name ( -- string ) 256 dup dup length gethostname @@ -351,5 +422,5 @@ M: invalid-local-address summary { { [ os unix? ] [ "io.sockets.unix" require ] } - { [ os winnt? ] [ "io.sockets.windows.nt" require ] } + { [ os windows? ] [ "io.sockets.windows" require ] } } cond diff --git a/basis/system-info/windows/ce/authors.txt b/basis/io/sockets/unix/linux/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/system-info/windows/ce/authors.txt rename to basis/io/sockets/unix/linux/authors.txt diff --git a/basis/io/sockets/unix/linux/linux.factor b/basis/io/sockets/unix/linux/linux.factor new file mode 100644 index 0000000000..a2c4d96633 --- /dev/null +++ b/basis/io/sockets/unix/linux/linux.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.sockets kernel system ; +IN: io.sockets.unix.linux + +! Linux seems to use the same port-space for ipv4 and ipv6. + +M: linux resolve-localhost { T{ ipv4 f "0.0.0.0" } } ; + diff --git a/basis/io/sockets/unix/linux/platforms.txt b/basis/io/sockets/unix/linux/platforms.txt new file mode 100644 index 0000000000..a08e1f35eb --- /dev/null +++ b/basis/io/sockets/unix/linux/platforms.txt @@ -0,0 +1 @@ +linux diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index cc0740500a..4d6c699211 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -1,20 +1,19 @@ ! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings generic kernel math -threads sequences byte-arrays io.binary io.backend.unix -io.streams.duplex io.backend io.pathnames io.sockets.private -io.files.private io.encodings.utf8 math.parser continuations -libc combinators system accessors destructors unix locals init -classes.struct alien.data unix.ffi ; - +USING: accessors alien alien.c-types alien.data alien.strings +byte-arrays classes.struct combinators continuations +destructors generic init io.backend io.backend.unix io.binary +io.encodings.utf8 io.files.private io.pathnames +io.sockets.private io.streams.duplex kernel libc locals math +math.parser sequences system threads unix unix.ffi +vocabs.loader ; EXCLUDE: namespaces => bind ; EXCLUDE: io => read write ; EXCLUDE: io.sockets => accept ; - IN: io.sockets.unix -: socket-fd ( domain type -- fd ) - 0 socket dup io-error init-fd |dispose ; +: socket-fd ( domain type protocol -- fd ) + socket dup io-error init-fd |dispose ; : set-socket-option ( fd level opt -- ) [ handle-fd ] 2dip 1 dup byte-length setsockopt io-error ; @@ -32,8 +31,8 @@ M: unix sockaddr-of-family ( alien af -- addrspec ) M: unix addrspec-of-family ( af -- addrspec ) { - { AF_INET [ T{ inet4 } ] } - { AF_INET6 [ T{ inet6 } ] } + { AF_INET [ T{ ipv4 } ] } + { AF_INET6 [ T{ ipv6 } ] } { AF_UNIX [ T{ local } ] } [ drop f ] } case ; @@ -83,7 +82,7 @@ M:: object establish-connection ( client-out remote -- ) ] if* ; inline M: object ((client)) ( addrspec -- fd ) - protocol-family SOCK_STREAM socket-fd + [ protocol-family SOCK_STREAM ] [ protocol ] bi socket-fd [ init-client-socket ] [ ?bind-client ] [ ] tri ; ! Server sockets - TCP and Unix domain @@ -91,7 +90,7 @@ M: object ((client)) ( addrspec -- fd ) SOL_SOCKET SO_REUSEADDR set-socket-option ; : server-socket-fd ( addrspec type -- fd ) - [ dup protocol-family ] dip socket-fd + [ dup protocol-family ] dip pick protocol socket-fd [ init-server-socket ] keep [ handle-fd swap make-sockaddr/size [ bind ] unix-system-call drop ] keep ; @@ -123,6 +122,9 @@ M: object (accept) ( server addrspec -- fd sockaddr ) M: unix (datagram) [ SOCK_DGRAM server-socket-fd ] with-destructors ; +M: unix (raw) + [ SOCK_RAW server-socket-fd ] with-destructors ; + SYMBOL: receive-buffer CONSTANT: packet-size 65536 @@ -182,3 +184,5 @@ M: local make-sockaddr M: local parse-sockaddr drop path>> utf8 alien>string ; + +os linux? [ "io.sockets.unix.linux" require ] when diff --git a/basis/io/backend/windows/nt/authors.txt b/basis/io/sockets/windows/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/io/backend/windows/nt/authors.txt rename to basis/io/sockets/windows/authors.txt diff --git a/basis/io/sockets/windows/nt/authors.txt b/basis/io/sockets/windows/nt/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/sockets/windows/nt/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor deleted file mode 100644 index 13f399697e..0000000000 --- a/basis/io/sockets/windows/nt/nt.factor +++ /dev/null @@ -1,224 +0,0 @@ -USING: alien alien.accessors alien.c-types alien.data byte-arrays -continuations destructors io.ports io.timeouts io.sockets -io.sockets.private io namespaces io.streams.duplex -io.backend.windows io.sockets.windows io.backend.windows.nt -windows.winsock kernel libc math sequences threads system -combinators accessors classes.struct windows.kernel32 -windows.types ; -IN: io.sockets.windows.nt - -: malloc-int ( n -- alien ) - malloc-byte-array ; inline - -M: winnt WSASocket-flags ( -- DWORD ) - WSA_FLAG_OVERLAPPED ; - -: get-ConnectEx-ptr ( socket -- void* ) - SIO_GET_EXTENSION_FUNCTION_POINTER - WSAID_CONNECTEX - GUID heap-size - { void* } - [ - void* heap-size - DWORD - f - f - WSAIoctl SOCKET_ERROR = [ - winsock-error-string throw - ] when - ] with-out-parameters ; - -TUPLE: ConnectEx-args port - s name namelen lpSendBuffer dwSendDataLength - lpdwBytesSent lpOverlapped ptr ; - -: wait-for-socket ( args -- n ) - [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline - -: ( sockaddr size -- ConnectEx ) - ConnectEx-args new - swap >>namelen - swap >>name - f >>lpSendBuffer - 0 >>dwSendDataLength - f >>lpdwBytesSent - (make-overlapped) >>lpOverlapped ; inline - -: call-ConnectEx ( ConnectEx -- ) - { - [ s>> ] - [ name>> ] - [ namelen>> ] - [ lpSendBuffer>> ] - [ dwSendDataLength>> ] - [ lpdwBytesSent>> ] - [ lpOverlapped>> ] - [ ptr>> ] - } cleave - int - { SOCKET void* int PVOID DWORD LPDWORD void* } - stdcall alien-indirect drop - winsock-error-string [ throw ] when* ; inline - -M: object establish-connection ( client-out remote -- ) - make-sockaddr/size - swap >>port - dup port>> handle>> handle>> >>s - dup s>> get-ConnectEx-ptr >>ptr - dup call-ConnectEx - wait-for-socket drop ; - -TUPLE: AcceptEx-args port - sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength - dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ; - -: init-accept-buffer ( addr AcceptEx -- ) - swap sockaddr-size 16 + - [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi - dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer - drop ; inline - -: ( server addr -- AcceptEx ) - AcceptEx-args new - 2dup init-accept-buffer - swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket - over handle>> handle>> >>sListenSocket - swap >>port - 0 >>dwReceiveDataLength - f >>lpdwBytesReceived - (make-overlapped) >>lpOverlapped ; inline - -: call-AcceptEx ( AcceptEx -- ) - { - [ sListenSocket>> ] - [ sAcceptSocket>> ] - [ lpOutputBuffer>> ] - [ dwReceiveDataLength>> ] - [ dwLocalAddressLength>> ] - [ dwRemoteAddressLength>> ] - [ lpdwBytesReceived>> ] - [ lpOverlapped>> ] - } cleave AcceptEx drop - winsock-error-string [ throw ] when* ; inline - -: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr ) - f 0 f [ 0 GetAcceptExSockaddrs ] keep *void* ; - -: extract-remote-address ( AcceptEx -- sockaddr ) - [ - { - [ lpOutputBuffer>> ] - [ dwReceiveDataLength>> ] - [ dwLocalAddressLength>> ] - [ dwRemoteAddressLength>> ] - } cleave - (extract-remote-address) - ] [ port>> addr>> protocol-family ] bi - sockaddr-of-family ; inline - -M: object (accept) ( server addr -- handle sockaddr ) - [ - - { - [ call-AcceptEx ] - [ wait-for-socket drop ] - [ sAcceptSocket>> ] - [ extract-remote-address ] - } cleave - ] with-destructors ; - -TUPLE: WSARecvFrom-args port - s lpBuffers dwBufferCount lpNumberOfBytesRecvd - lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ; - -: make-receive-buffer ( -- WSABUF ) - WSABUF malloc-struct &free - default-buffer-size get - [ >>len ] [ malloc &free >>buf ] bi ; inline - -: ( datagram -- WSARecvFrom ) - WSARecvFrom-args new - swap >>port - dup port>> handle>> handle>> >>s - dup port>> addr>> sockaddr-size - [ malloc &free >>lpFrom ] - [ malloc-int &free >>lpFromLen ] bi - make-receive-buffer >>lpBuffers - 1 >>dwBufferCount - 0 malloc-int &free >>lpFlags - 0 malloc-int &free >>lpNumberOfBytesRecvd - (make-overlapped) >>lpOverlapped ; inline - -: call-WSARecvFrom ( WSARecvFrom -- ) - { - [ s>> ] - [ lpBuffers>> ] - [ dwBufferCount>> ] - [ lpNumberOfBytesRecvd>> ] - [ lpFlags>> ] - [ lpFrom>> ] - [ lpFromLen>> ] - [ lpOverlapped>> ] - [ lpCompletionRoutine>> ] - } cleave WSARecvFrom socket-error* ; inline - -: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) - [ lpBuffers>> buf>> swap memory>byte-array ] - [ - [ port>> addr>> empty-sockaddr dup ] - [ lpFrom>> ] - [ lpFromLen>> *int ] - tri memcpy - ] bi ; inline - -M: winnt (receive) ( datagram -- packet addrspec ) - [ - - [ call-WSARecvFrom ] - [ wait-for-socket ] - [ parse-WSARecvFrom ] - tri - ] with-destructors ; - -TUPLE: WSASendTo-args port - s lpBuffers dwBufferCount lpNumberOfBytesSent - dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ; - -: make-send-buffer ( packet -- WSABUF ) - [ WSABUF malloc-struct &free ] dip - [ malloc-byte-array &free >>buf ] - [ length >>len ] bi ; inline - -: ( packet addrspec datagram -- WSASendTo ) - WSASendTo-args new - swap >>port - dup port>> handle>> handle>> >>s - swap make-sockaddr/size - [ malloc-byte-array &free ] dip - [ >>lpTo ] [ >>iToLen ] bi* - swap make-send-buffer >>lpBuffers - 1 >>dwBufferCount - 0 >>dwFlags - 0 >>lpNumberOfBytesSent - (make-overlapped) >>lpOverlapped ; inline - -: call-WSASendTo ( WSASendTo -- ) - { - [ s>> ] - [ lpBuffers>> ] - [ dwBufferCount>> ] - [ lpNumberOfBytesSent>> ] - [ dwFlags>> ] - [ lpTo>> ] - [ iToLen>> ] - [ lpOverlapped>> ] - [ lpCompletionRoutine>> ] - } cleave WSASendTo socket-error* ; inline - -M: winnt (send) ( packet addrspec datagram -- ) - [ - - [ call-WSASendTo ] - [ wait-for-socket drop ] - bi - ] with-destructors ; diff --git a/basis/io/sockets/windows/nt/platforms.txt b/basis/io/sockets/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/sockets/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor old mode 100644 new mode 100755 index cf1edc0cb1..157aa5c848 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -1,8 +1,10 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors io.sockets io.sockets.private -io.backend.windows io.backend windows.winsock system destructors -alien.c-types classes.struct combinators ; +USING: accessors alien alien.c-types alien.data classes.struct +combinators destructors io.backend io.files.windows io.ports +io.sockets io.sockets.icmp io.sockets.private kernel libc math +sequences system windows.handles windows.kernel32 windows.types +windows.winsock ; FROM: namespaces => get ; IN: io.sockets.windows @@ -18,8 +20,8 @@ M: windows sockaddr-of-family ( alien af -- addrspec ) M: windows addrspec-of-family ( af -- addrspec ) { - { AF_INET [ T{ inet4 } ] } - { AF_INET6 [ T{ inet6 } ] } + { AF_INET [ T{ ipv4 } ] } + { AF_INET6 [ T{ ipv6 } ] } [ drop f ] } case ; @@ -30,18 +32,18 @@ TUPLE: win32-socket < win32-file ; : ( handle -- win32-socket ) win32-socket new-win32-handle ; -M: win32-socket dispose ( stream -- ) - handle>> closesocket drop ; +M: win32-socket dispose* ( stream -- ) + handle>> closesocket socket-error* ; : unspecific-sockaddr/size ( addrspec -- sockaddr len ) [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ; : opened-socket ( handle -- win32-socket ) - |dispose dup add-completion ; + |dispose add-completion ; : open-socket ( addrspec type -- win32-socket ) - [ protocol-family ] dip - 0 f 0 WSASocket-flags WSASocket + [ drop protocol-family ] [ swap protocol ] 2bi + f 0 WSASocket-flags WSASocket dup socket-error opened-socket ; @@ -80,3 +82,222 @@ M: object (server) ( addrspec -- handle ) M: windows (datagram) ( addrspec -- handle ) [ SOCK_DGRAM server-socket ] with-destructors ; + +M: windows (raw) ( addrspec -- handle ) + [ SOCK_RAW server-socket ] with-destructors ; + +: malloc-int ( n -- alien ) + malloc-byte-array ; inline + +M: winnt WSASocket-flags ( -- DWORD ) + WSA_FLAG_OVERLAPPED ; + +: get-ConnectEx-ptr ( socket -- void* ) + SIO_GET_EXTENSION_FUNCTION_POINTER + WSAID_CONNECTEX + GUID heap-size + { void* } + [ + void* heap-size + DWORD + f + f + WSAIoctl SOCKET_ERROR = [ + maybe-winsock-exception throw + ] when + ] with-out-parameters ; + +TUPLE: ConnectEx-args port + s name namelen lpSendBuffer dwSendDataLength + lpdwBytesSent lpOverlapped ptr ; + +: wait-for-socket ( args -- n ) + [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline + +: ( sockaddr size -- ConnectEx ) + ConnectEx-args new + swap >>namelen + swap >>name + f >>lpSendBuffer + 0 >>dwSendDataLength + f >>lpdwBytesSent + (make-overlapped) >>lpOverlapped ; inline + +: call-ConnectEx ( ConnectEx -- ) + { + [ s>> ] + [ name>> ] + [ namelen>> ] + [ lpSendBuffer>> ] + [ dwSendDataLength>> ] + [ lpdwBytesSent>> ] + [ lpOverlapped>> ] + [ ptr>> ] + } cleave + int + { SOCKET void* int PVOID DWORD LPDWORD void* } + stdcall alien-indirect drop + winsock-error ; inline + +M: object establish-connection ( client-out remote -- ) + make-sockaddr/size + swap >>port + dup port>> handle>> handle>> >>s + dup s>> get-ConnectEx-ptr >>ptr + dup call-ConnectEx + wait-for-socket drop ; + +TUPLE: AcceptEx-args port + sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength + dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ; + +: init-accept-buffer ( addr AcceptEx -- ) + swap sockaddr-size 16 + + [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi + dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer + drop ; inline + +: ( server addr -- AcceptEx ) + AcceptEx-args new + 2dup init-accept-buffer + swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket + over handle>> handle>> >>sListenSocket + swap >>port + 0 >>dwReceiveDataLength + f >>lpdwBytesReceived + (make-overlapped) >>lpOverlapped ; inline + +! AcceptEx return value is useless +: call-AcceptEx ( AcceptEx -- ) + { + [ sListenSocket>> ] + [ sAcceptSocket>> ] + [ lpOutputBuffer>> ] + [ dwReceiveDataLength>> ] + [ dwLocalAddressLength>> ] + [ dwRemoteAddressLength>> ] + [ lpdwBytesReceived>> ] + [ lpOverlapped>> ] + } cleave AcceptEx drop winsock-error ; inline + +: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr ) + f 0 f [ 0 GetAcceptExSockaddrs ] keep *void* ; + +: extract-remote-address ( AcceptEx -- sockaddr ) + [ + { + [ lpOutputBuffer>> ] + [ dwReceiveDataLength>> ] + [ dwLocalAddressLength>> ] + [ dwRemoteAddressLength>> ] + } cleave + (extract-remote-address) + ] [ port>> addr>> protocol-family ] bi + sockaddr-of-family ; inline + +M: object (accept) ( server addr -- handle sockaddr ) + [ + + { + [ call-AcceptEx ] + [ wait-for-socket drop ] + [ sAcceptSocket>> ] + [ extract-remote-address ] + } cleave + ] with-destructors ; + +TUPLE: WSARecvFrom-args port + s lpBuffers dwBufferCount lpNumberOfBytesRecvd + lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ; + +: make-receive-buffer ( -- WSABUF ) + WSABUF malloc-struct &free + default-buffer-size get + [ >>len ] [ malloc &free >>buf ] bi ; inline + +: ( datagram -- WSARecvFrom ) + WSARecvFrom-args new + swap >>port + dup port>> handle>> handle>> >>s + dup port>> addr>> sockaddr-size + [ malloc &free >>lpFrom ] + [ malloc-int &free >>lpFromLen ] bi + make-receive-buffer >>lpBuffers + 1 >>dwBufferCount + 0 malloc-int &free >>lpFlags + 0 malloc-int &free >>lpNumberOfBytesRecvd + (make-overlapped) >>lpOverlapped ; inline + +: call-WSARecvFrom ( WSARecvFrom -- ) + { + [ s>> ] + [ lpBuffers>> ] + [ dwBufferCount>> ] + [ lpNumberOfBytesRecvd>> ] + [ lpFlags>> ] + [ lpFrom>> ] + [ lpFromLen>> ] + [ lpOverlapped>> ] + [ lpCompletionRoutine>> ] + } cleave WSARecvFrom socket-error* ; inline + +: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) + [ lpBuffers>> buf>> swap memory>byte-array ] + [ + [ port>> addr>> empty-sockaddr dup ] + [ lpFrom>> ] + [ lpFromLen>> *int ] + tri memcpy + ] bi ; inline + +M: winnt (receive) ( datagram -- packet addrspec ) + [ + + [ call-WSARecvFrom ] + [ wait-for-socket ] + [ parse-WSARecvFrom ] + tri + ] with-destructors ; + +TUPLE: WSASendTo-args port + s lpBuffers dwBufferCount lpNumberOfBytesSent + dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ; + +: make-send-buffer ( packet -- WSABUF ) + [ WSABUF malloc-struct &free ] dip + [ malloc-byte-array &free >>buf ] + [ length >>len ] bi ; inline + +: ( packet addrspec datagram -- WSASendTo ) + WSASendTo-args new + swap >>port + dup port>> handle>> handle>> >>s + swap make-sockaddr/size + [ malloc-byte-array &free ] dip + [ >>lpTo ] [ >>iToLen ] bi* + swap make-send-buffer >>lpBuffers + 1 >>dwBufferCount + 0 >>dwFlags + 0 >>lpNumberOfBytesSent + (make-overlapped) >>lpOverlapped ; inline + +: call-WSASendTo ( WSASendTo -- ) + { + [ s>> ] + [ lpBuffers>> ] + [ dwBufferCount>> ] + [ lpNumberOfBytesSent>> ] + [ dwFlags>> ] + [ lpTo>> ] + [ iToLen>> ] + [ lpOverlapped>> ] + [ lpCompletionRoutine>> ] + } cleave WSASendTo socket-error* ; inline + +M: winnt (send) ( packet addrspec datagram -- ) + [ + + [ call-WSASendTo ] + [ wait-for-socket drop ] + bi + ] with-destructors ; diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index 7ce7bd2016..916af4c29a 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -79,3 +79,46 @@ IN: io.streams.limited.tests "asdf" over stream-write dup stream-flush 3 swap stream-read ] unit-test + +[ t ] +[ + "abc" 3 limit-stream unlimit-stream + "abc" = +] unit-test + +[ t ] +[ + "abc" 3 limit-stream unlimit-stream + "abc" = +] unit-test + +[ t ] +[ + [ + "resource:license.txt" utf8 &dispose + 3 limit-stream unlimit-stream + "resource:license.txt" utf8 &dispose + [ decoder? ] both? + ] with-destructors +] unit-test + +[ "asdf" ] [ + "asdf" 2 [ + unlimited-input contents + ] with-input-stream +] unit-test + +[ "asdf" ] [ + "asdf" 2 [ + [ contents ] with-unlimited-input + ] with-input-stream +] unit-test + +[ "gh" ] [ + "asdfgh" 4 [ + 2 [ + [ contents drop ] with-unlimited-input + ] with-limited-input + [ contents ] with-unlimited-input + ] with-input-stream +] unit-test diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index 4ca1779a7b..929520edaa 100644 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -33,6 +33,10 @@ M: object limit-stream ( stream limit -- stream' ) : with-limited-stream ( stream limit quot -- ) [ limit-stream ] dip call ; inline +: with-limited-input ( limit quot -- ) + [ [ input-stream get ] dip limit-stream input-stream ] dip + with-variable ; inline + ERROR: limit-exceeded n stream ; > dispose ; M: limited-stream stream-element-type stream>> stream-element-type ; + +GENERIC: unlimit-stream ( stream -- stream' ) + +M: decoder unlimit-stream ( stream -- stream' ) + [ stream>> ] change-stream ; + +M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ; + +: unlimited-input ( -- ) + input-stream [ unlimit-stream ] change ; + +: with-unlimited-stream ( stream quot -- ) + [ unlimit-stream ] dip call ; inline + +: with-unlimited-input ( quot -- ) + [ input-stream get unlimit-stream input-stream ] dip + with-variable ; inline diff --git a/basis/io/timeouts/timeouts.factor b/basis/io/timeouts/timeouts.factor index 68110ded15..c024e49856 100644 --- a/basis/io/timeouts/timeouts.factor +++ b/basis/io/timeouts/timeouts.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel calendar timers io io.encodings accessors -namespaces fry io.streams.null ; +USING: accessors fry io io.encodings io.streams.null kernel +namespaces timers ; IN: io.timeouts GENERIC: timeout ( obj -- dt/f ) diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index f54a03ae2f..e9693aa2df 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -97,8 +97,7 @@ FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ; FUNCTION: int memcmp ( void* a, void* b, ulong size ) ; -: memory= ( a b size -- ? ) - memcmp 0 = ; +: memory= ( a b size -- ? ) memcmp 0 = ; inline FUNCTION: size_t strlen ( c-string alien ) ; diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index bb014fef62..34c6c74b3a 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -64,7 +64,7 @@ $nl $nl "The listener can watch dynamic variables:" { $subsections "listener-watch" } -"Nested listeners can be useful for testing code in other dynamic scopes. For example, when doing database maintanance using the " { $vocab-link "db.tuples" } " vocabulary, it can be useful to start a listener with a database connection:" +"Nested listeners can be useful for testing code in other dynamic scopes. For example, when doing database maintenance using the " { $vocab-link "db.tuples" } " vocabulary, it can be useful to start a listener with a database connection:" { $code "USING: db db.sqlite listener ;" "\"data.db\" [ listener ] with-db" diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor index 102bc79c7e..133509687f 100644 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -1,23 +1,17 @@ USING: help.markup help.syntax quotations kernel -stack-checker.transforms sequences ; +stack-checker.transforms sequences combinators ; IN: macros HELP: MACRO: { $syntax "MACRO: word ( inputs... -- ) definition... ;" } -{ $description "Defines a code transformation. The definition must have stack effect " { $snippet "( inputs... -- quot )" } "." } +{ $description "Defines a macro word. The definition must have stack effect " { $snippet "( inputs... -- quot )" } "." } { $notes - "A call of a macro inside a word definition is replaced with the quotation expansion at compile-time if precisely the following conditions hold:" + "A call of a macro inside a word definition is replaced with the quotation expansion at compile-time. The following two conditions must hold:" { $list - { "All inputs to the macro call are literal" } - { "The word calling the macro has a static stack effect" } + { "All inputs to the macro call must be literals" } { "The expansion quotation produced by the macro has a static stack effect" } } - "If any of these conditions fail to hold, the macro will still work, but expansion will be performed at run-time." - $nl - "Other than possible compile-time expansion, the following two definition styles are equivalent:" - { $code "MACRO: foo ... ;" } - { $code ": foo ... call ;" } - "Conceptually, macros allow computation to be moved from run-time to compile-time, splicing the result of this computation into the generated quotation." + "Macros allow computation to be moved from run-time to compile-time, splicing the result of this computation into the generated quotation." } { $examples "A macro that calls a quotation but preserves any values it consumes off the stack:" @@ -41,15 +35,16 @@ HELP: macro ARTICLE: "macros" "Macros" "The " { $vocab-link "macros" } " vocabulary implements " { $emphasis "macros" } ", which are code transformations that may run at compile-time under the right circumstances." $nl -"Macros can be used to give static stack effects to combinators that otherwise would not have static stack effects. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." +"Macros can be used to implement combinators whose stack effects depend on an input parameter. Since macros are expanded at compile time, this permits the compiler to infer a static stack effect for the word calling the macro." +$nl +"Macros can also be used to calculate lookup tables and generate code at compile time, which can improve performance, raise the level of abstraction, and simplify code." $nl "Factor macros are similar to Lisp macros; they are not like C preprocessor macros." $nl "Defining new macros:" { $subsections POSTPONE: MACRO: } -"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion." +"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion. The ordinary definition is only used from code compiled with the non-optimizing compiler. Under normal circumstances, macros should be used instead of compiler transforms; compiler transforms are only used for words such as " { $link cond } " which are frequently invoked during the bootstrap process, and this having a performant non-optimized definition which does not generate code on the fly is important." { $subsections define-transform } -"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." { $see-also "generalizations" "fry" } ; ABOUT: "macros" diff --git a/basis/match/match-docs.factor b/basis/match/match-docs.factor index 8d840bc047..fb73182f3d 100644 --- a/basis/match/match-docs.factor +++ b/basis/match/match-docs.factor @@ -17,7 +17,7 @@ HELP: match-cond { $values { "assoc" "a sequence of pairs" } } { $description "Calls the second quotation in the first pair whose first sequence yields a successful " { $link match } " against the top of the stack. The second quotation, when called, has the hashtable returned from the " { $link match } " call bound as the top namespace so " { $link get } " can be used to retrieve the values. To have a fallthrough match clause use the '_' match variable." } { $examples - { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" } + { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment 346126 } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" } } { $see-also match POSTPONE: MATCH-VARS: replace-patterns match-replace } ; @@ -27,7 +27,7 @@ HELP: MATCH-VARS: { $values { "var" "a match variable name beginning with '?'" } } { $description "Creates a symbol that can be used in " { $link match } " and " { $link match-cond } " for binding values in the matched sequence. The symbol name is created as a word that is defined to get the value of the symbol out of the current namespace. This can be used in " { $link match-cond } " to retrive the values in the quotation body." } { $examples - { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment ?value } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" } + { $code "USE: match" "MATCH-VARS: ?value ;\n{ increment 346126 } {\n { { increment ?value } [ ?value do-something ] }\n { { decrement ?value } [ ?value do-something-else ] }\n { _ [ no-match-found ] }\n} match-cond" } } { $see-also match match-cond replace-patterns match-replace } ; diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 8a551bfe9d..7567dd510b 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -78,7 +78,8 @@ IN: math.combinatorics.tests [ { } ] [ { 1 2 } 0 selections ] unit-test -[ { { 1 2 } } ] [ { 1 2 } 1 selections ] unit-test +[ { { 1 } { 2 } } ] [ { 1 2 } 1 selections ] unit-test +[ { { { 1 } } { 2 } } ] [ { { 1 } 2 } 1 selections ] unit-test [ { { 1 1 } { 1 2 } { 2 1 } { 2 2 } } ] [ { 1 2 } 2 selections ] unit-test diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index b69867fb12..1d67f4870b 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,8 +1,9 @@ ! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer, John Benediktsson. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs binary-search fry kernel locals math math.order - math.ranges namespaces sequences sorting make sequences.deep arrays - combinators ; + +USING: accessors arrays assocs binary-search fry kernel locals +math math.order math.ranges namespaces sequences sorting ; + IN: math.combinatorics [ -rot ] dip each-combination ; inline : all-subsets ( seq -- subsets ) - dup length [0,b] [ - [ dupd all-combinations [ , ] each ] each - ] { } make nip ; + dup length [0,b] [ all-combinations ] with map concat ; + + ] [ - swap pick cartesian-product [ - [ [ dup length 1 > [ flatten ] when , ] each ] each - ] { } make swap 1 - - ] while drop nip ; + [ [ 1array ] map dup ] [ 1 - ] bi* [ + cartesian-product concat [ { } concat-as ] map + ] with times ; + +PRIVATE> : selections ( seq n -- selections ) - { - { 0 [ drop { } ] } - { 1 [ 1array ] } - [ (selections) ] - } case ; + dup 0 > [ (selections) ] [ 2drop { } ] if ; + diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor old mode 100644 new mode 100755 index 89aa1bd394..c762d265c3 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -1,7 +1,7 @@ USING: kernel math math.floats.env math.floats.env.private math.functions math.libm sequences tools.test locals compiler.units kernel.private fry compiler.test math.private -words system ; +words system memory ; IN: math.floats.env.tests : set-default-fp-env ( -- ) @@ -113,23 +113,26 @@ os linux? cpu x86.64? and [ ! FP traps cause a kernel panic on OpenBSD 4.5 i386 os openbsd eq? cpu x86.32 eq? and [ - : test-traps ( traps inputs quot -- quot' ) - append '[ _ _ with-fp-traps ] ; + : fp-trap-error? ( error -- ? ) + 2 head { "kernel-error" 17 } = ; - : test-traps-compiled ( traps inputs quot -- quot' ) - swapd '[ @ [ _ _ with-fp-traps ] compile-call ] ; + : test-traps ( traps inputs quot -- quot' fail-quot ) + append '[ _ _ with-fp-traps ] [ fp-trap-error? ] ; - { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail - { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail - { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail - { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail - { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail + : test-traps-compiled ( traps inputs quot -- quot' fail-quot ) + swapd '[ @ [ _ _ with-fp-traps ] compile-call ] [ fp-trap-error? ] ; - { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail - { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail - { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail - { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail - { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail + { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail-with + { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail-with + { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail-with + { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail-with + { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail-with + + { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail-with + { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail-with + { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail-with + { +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail-with + { +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail-with ! Ensure ordered comparisons raise traps :: test-comparison-quot ( word -- quot ) @@ -138,46 +141,46 @@ os openbsd eq? cpu x86.32 eq? and [ { +fp-invalid-operation+ } [ word execute ] with-fp-traps ] ; - : test-comparison ( inputs word -- quot ) - test-comparison-quot append ; + : test-comparison ( inputs word -- quot fail-quot ) + test-comparison-quot append [ fp-trap-error? ] ; - : test-comparison-compiled ( inputs word -- quot ) - test-comparison-quot '[ @ _ compile-call ] ; + : test-comparison-compiled ( inputs word -- quot fail-quot ) + test-comparison-quot '[ @ _ compile-call ] [ fp-trap-error? ] ; \ float< "intrinsic" word-prop [ - [ 0/0. -15.0 ] \ < test-comparison must-fail - [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail - [ -15.0 0/0. ] \ < test-comparison must-fail - [ -15.0 0/0. ] \ < test-comparison-compiled must-fail - [ 0/0. -15.0 ] \ <= test-comparison must-fail - [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail - [ -15.0 0/0. ] \ <= test-comparison must-fail - [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail - [ 0/0. -15.0 ] \ > test-comparison must-fail - [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail - [ -15.0 0/0. ] \ > test-comparison must-fail - [ -15.0 0/0. ] \ > test-comparison-compiled must-fail - [ 0/0. -15.0 ] \ >= test-comparison must-fail - [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail - [ -15.0 0/0. ] \ >= test-comparison must-fail - [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ < test-comparison must-fail-with + [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail-with + [ -15.0 0/0. ] \ < test-comparison must-fail-with + [ -15.0 0/0. ] \ < test-comparison-compiled must-fail-with + [ 0/0. -15.0 ] \ <= test-comparison must-fail-with + [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail-with + [ -15.0 0/0. ] \ <= test-comparison must-fail-with + [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail-with + [ 0/0. -15.0 ] \ > test-comparison must-fail-with + [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail-with + [ -15.0 0/0. ] \ > test-comparison must-fail-with + [ -15.0 0/0. ] \ > test-comparison-compiled must-fail-with + [ 0/0. -15.0 ] \ >= test-comparison must-fail-with + [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail-with + [ -15.0 0/0. ] \ >= test-comparison must-fail-with + [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail-with - [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test - [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test - [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test - [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test - [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test - [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test - [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test - [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test - [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test - [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test - [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test - [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test - [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test - [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test - [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test - [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u< test-comparison drop unit-test + [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled drop unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison drop unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled drop unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison drop unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled drop unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison drop unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled drop unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison drop unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled drop unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison drop unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled drop unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison drop unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled drop unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison drop unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled drop unit-test ] when ] unless @@ -190,6 +193,9 @@ os openbsd eq? cpu x86.32 eq? and [ [ +denormal-keep+ ] [ denormal-mode ] unit-test [ { } ] [ fp-traps ] unit-test +[ ] [ + all-fp-exceptions [ compact-gc ] with-fp-traps +] unit-test + ! In case the tests screw up the FP env because of bugs in math.floats.env set-default-fp-env - diff --git a/basis/math/floats/env/x86/tags.txt b/basis/math/floats/env/x86/tags.txt index ebb74b4d5f..411ecb03f2 100644 --- a/basis/math/floats/env/x86/tags.txt +++ b/basis/math/floats/env/x86/tags.txt @@ -1 +1,2 @@ not loaded +not tested diff --git a/basis/math/floats/env/x86/x86-tests.factor b/basis/math/floats/env/x86/x86-tests.factor new file mode 100755 index 0000000000..c8beed1489 --- /dev/null +++ b/basis/math/floats/env/x86/x86-tests.factor @@ -0,0 +1,15 @@ +USING: math.floats.env math.floats.env.x86 tools.test +classes.struct cpu.x86.assembler cpu.x86.assembler.operands +compiler.test math kernel sequences alien alien.c-types +continuations ; +IN: math.floats.env.x86.tests + +[ t ] [ + [ [ + void { } cdecl [ + 9 [ FLDZ ] times + 9 [ ST0 FSTP ] times + ] alien-assembly + ] compile-call ] collect-fp-exceptions + +fp-x87-stack-fault+ swap member? +] unit-test diff --git a/basis/math/floats/env/x86/x86.factor b/basis/math/floats/env/x86/x86.factor index 89dd402378..aad37b73cc 100644 --- a/basis/math/floats/env/x86/x86.factor +++ b/basis/math/floats/env/x86/x86.factor @@ -88,7 +88,9 @@ M: sse-env (set-denormal-mode) ( register mode -- register' ) } case ] curry change-mxcsr ; inline -CONSTANT: x87-exception-bits HEX: 3f +SINGLETON: +fp-x87-stack-fault+ + +CONSTANT: x87-exception-bits HEX: 7f CONSTANT: x87-exception>bit H{ { +fp-invalid-operation+ HEX: 01 } @@ -96,6 +98,7 @@ CONSTANT: x87-exception>bit { +fp-underflow+ HEX: 10 } { +fp-zero-divide+ HEX: 04 } { +fp-inexact+ HEX: 20 } + { +fp-x87-stack-fault+ HEX: 40 } } CONSTANT: x87-rounding-mode-bits HEX: 0c00 diff --git a/basis/math/libm/libm.factor b/basis/math/libm/libm.factor index c87a2819ca..148ff71a92 100644 --- a/basis/math/libm/libm.factor +++ b/basis/math/libm/libm.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2006 Slava Pestov. +! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax ; +USING: alien alien.c-types alien.syntax words ; +FROM: math => float mod ; IN: math.libm LIBRARY: libm @@ -49,7 +50,17 @@ FUNCTION-ALIAS: fpow FUNCTION-ALIAS: fsqrt double sqrt ( double x ) ; - + +FUNCTION: double fmod ( double x, double y ) ; + +M: float mod fmod ; inline + +! fsqrt has an intrinsic so we don't actually want to inline it +! unconditionally +<< +\ fsqrt f "inline" set-word-prop +>> + ! Windows doesn't have these... FUNCTION-ALIAS: flog1+ double log1p ( double x ) ; diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index dd73b0a073..105bd5b976 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -47,8 +47,10 @@ PRIVATE> dup 1 = [ 1array ] [ - group-factors [ first2 [0,b] [ ^ ] with map ] map - [ product ] product-map natural-sort + group-factors dup empty? [ + [ first2 [0,b] [ ^ ] with map ] map + [ product ] product-map natural-sort + ] unless ] if ; : unix-factor ( string -- ) diff --git a/basis/math/rectangles/prettyprint/prettyprint.factor b/basis/math/rectangles/prettyprint/prettyprint.factor index c23be50029..b1fe1789f7 100644 --- a/basis/math/rectangles/prettyprint/prettyprint.factor +++ b/basis/math/rectangles/prettyprint/prettyprint.factor @@ -1,7 +1,11 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ; IN: math.rectangles.prettyprint M: rect pprint* - \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; + [ + \ RECT: [ + [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ + ] pprint-prefix + ] check-recursion ; diff --git a/basis/math/rectangles/rectangles-tests.factor b/basis/math/rectangles/rectangles-tests.factor index 7959d98f92..0e1c32778b 100644 --- a/basis/math/rectangles/rectangles-tests.factor +++ b/basis/math/rectangles/rectangles-tests.factor @@ -1,4 +1,5 @@ -USING: tools.test math.rectangles ; +USING: tools.test math.rectangles prettyprint io.streams.string +kernel accessors ; IN: math.rectangles.tests [ RECT: { 10 10 } { 20 20 } ] @@ -40,3 +41,6 @@ IN: math.rectangles.tests { 30 30 } } rect-containing ] unit-test + +! Prettyprint for RECT: didn't do nesting check properly +[ ] [ [ RECT: f f dup >>dim . ] with-string-writer drop ] unit-test diff --git a/basis/math/vectors/simd/simd-docs.factor b/basis/math/vectors/simd/simd-docs.factor index accced4b79..742bc7cb45 100644 --- a/basis/math/vectors/simd/simd-docs.factor +++ b/basis/math/vectors/simd/simd-docs.factor @@ -150,11 +150,11 @@ M: actor advance ( dt actor -- ) M\\ actor advance optimized.""" } -"The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:" +"The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "regs." } " on a word or quotation:" { $code """USE: compiler.tree.debugger -M\\ actor advance test-mr mr.""" } +M\\ actor advance regs.""" } "Example of a high-performance algorithms that use SIMD primitives can be found in the following vocabularies:" { $list { $vocab-link "benchmark.nbody-simd" } diff --git a/basis/mime/multipart/multipart-tests.factor b/basis/mime/multipart/multipart-tests.factor index d91e31cca2..6c3094fe22 100644 --- a/basis/mime/multipart/multipart-tests.factor +++ b/basis/mime/multipart/multipart-tests.factor @@ -1,8 +1,10 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.encodings.ascii io.files io.files.unique kernel -mime.multipart tools.test io.streams.duplex io multiline -assocs accessors ; +USING: accessors assocs continuations fry http.server io +io.encodings.ascii io.files io.files.unique +io.servers.connection io.streams.duplex io.streams.string +kernel math.ranges mime.multipart multiline namespaces random +sequences strings threads tools.test ; IN: mime.multipart.tests : upload-separator ( -- seq ) @@ -33,3 +35,22 @@ IN: mime.multipart.tests "file1" swap at filename>> "up.txt" = ] unit-test +SYMBOL: mime-test-server + +: with-test-server ( quot -- ) + [ + + f >>secure + 0 >>insecure + ] dip with-threaded-server ; inline + +: test-server-port ( -- n ) + mime-test-server get insecure>> ; + +: a-stream ( n -- stream ) + CHAR: a ; + +[ ] [ + [ + ] with-test-server +] unit-test diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index 1d56c59fc0..c464e5d674 100644 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -39,7 +39,7 @@ ERROR: end-of-stream multipart ; : fill-bytes ( multipart -- multipart ) buffer-size read - [ '[ _ append ] change-bytes ] + [ '[ _ B{ } append-as ] change-bytes ] [ t >>end-of-stream? ] if* ; : maybe-fill-bytes ( multipart -- multipart ) @@ -151,5 +151,5 @@ ERROR: no-content-disposition multipart ; dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ; : parse-multipart ( separator -- mime-parts ) - parse-beginning fill-bytes parse-multipart-loop - mime-parts>> ; + parse-beginning fill-bytes + parse-multipart-loop mime-parts>> ; diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index a6413fee4a..16f5cf64a6 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -1297,10 +1297,10 @@ GL-FUNCTION: void glCompressedTexSubImage1D { glCompressedTexSubImage1DARB } ( G GL-FUNCTION: void glCompressedTexSubImage2D { glCompressedTexSubImage2DARB } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLsizei width, GLsizei height, GLenum format, GLsizei imageSize, GLvoid* data ) ; GL-FUNCTION: void glCompressedTexSubImage3D { glCompressedTexSubImage3DARB } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLsizei imageSize, GLvoid* data ) ; GL-FUNCTION: void glGetCompressedTexImage { glGetCompressedTexImageARB } ( GLenum target, GLint lod, GLvoid* img ) ; -GL-FUNCTION: void glLoadTransposeMatrixd { glLoadTransposeMatrixdARB } ( GLdouble m[16] ) ; -GL-FUNCTION: void glLoadTransposeMatrixf { glLoadTransposeMatrixfARB } ( GLfloat m[16] ) ; -GL-FUNCTION: void glMultTransposeMatrixd { glMultTransposeMatrixdARB } ( GLdouble m[16] ) ; -GL-FUNCTION: void glMultTransposeMatrixf { glMultTransposeMatrixfARB } ( GLfloat m[16] ) ; +GL-FUNCTION: void glLoadTransposeMatrixd { glLoadTransposeMatrixdARB } ( GLdouble* m ) ; +GL-FUNCTION: void glLoadTransposeMatrixf { glLoadTransposeMatrixfARB } ( GLfloat* m ) ; +GL-FUNCTION: void glMultTransposeMatrixd { glMultTransposeMatrixdARB } ( GLdouble* m ) ; +GL-FUNCTION: void glMultTransposeMatrixf { glMultTransposeMatrixfARB } ( GLfloat* m ) ; GL-FUNCTION: void glMultiTexCoord1d { glMultiTexCoord1dARB } ( GLenum target, GLdouble s ) ; GL-FUNCTION: void glMultiTexCoord1dv { glMultiTexCoord1dvARB } ( GLenum target, GLdouble* v ) ; GL-FUNCTION: void glMultiTexCoord1f { glMultiTexCoord1fARB } ( GLenum target, GLfloat s ) ; @@ -2435,23 +2435,23 @@ GL-FUNCTION: void glUniformMatrix3x4dv { } ( GLint location, GLsizei count, GLbo GL-FUNCTION: void glUniformMatrix4x2dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; GL-FUNCTION: void glUniformMatrix4x3dv { } ( GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; GL-FUNCTION: void glGetUniformdv { } ( GLuint program, GLint location, GLdouble* params ) ; -GL-FUNCTION: void glProgramUniform1dEXT { } ( GLuint program, GLint location, GLdouble x ) ; -GL-FUNCTION: void glProgramUniform2dEXT { } ( GLuint program, GLint location, GLdouble x, GLdouble y ) ; -GL-FUNCTION: void glProgramUniform3dEXT { } ( GLuint program, GLint location, GLdouble x, GLdouble y, GLdouble z ) ; -GL-FUNCTION: void glProgramUniform4dEXT { } ( GLuint program, GLint location, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ; -GL-FUNCTION: void glProgramUniform1dvEXT { } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniform2dvEXT { } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniform3dvEXT { } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniform4dvEXT { } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniformMatrix2dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniformMatrix3dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniformMatrix4dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniformMatrix2x3dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniformMatrix2x4dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniformMatrix3x2dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniformMatrix3x4dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniformMatrix4x2dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; -GL-FUNCTION: void glProgramUniformMatrix4x3dvEXT { } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniform1d { glProgramUniform1dEXT } ( GLuint program, GLint location, GLdouble x ) ; +GL-FUNCTION: void glProgramUniform2d { glProgramUniform2dEXT } ( GLuint program, GLint location, GLdouble x, GLdouble y ) ; +GL-FUNCTION: void glProgramUniform3d { glProgramUniform3dEXT } ( GLuint program, GLint location, GLdouble x, GLdouble y, GLdouble z ) ; +GL-FUNCTION: void glProgramUniform4d { glProgramUniform4dEXT } ( GLuint program, GLint location, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ; +GL-FUNCTION: void glProgramUniform1dv { glProgramUniform1dvEXT } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniform2dv { glProgramUniform2dvEXT } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniform3dv { glProgramUniform3dvEXT } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniform4dv { glProgramUniform4dvEXT } ( GLuint program, GLint location, GLsizei count, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniformMatrix2dv { glProgramUniformMatrix2dvEXT } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniformMatrix3dv { glProgramUniformMatrix3dvEXT } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniformMatrix4dv { glProgramUniformMatrix4dvEXT } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniformMatrix2x3dv { glProgramUniformMatrix2x3dvEXT } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniformMatrix2x4dv { glProgramUniformMatrix2x4dvEXT } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniformMatrix3x2dv { glProgramUniformMatrix3x2dvEXT } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniformMatrix3x4dv { glProgramUniformMatrix3x4dvEXT } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniformMatrix4x2dv { glProgramUniformMatrix4x2dvEXT } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; +GL-FUNCTION: void glProgramUniformMatrix4x3dv { glProgramUniformMatrix4x3dvEXT } ( GLuint program, GLint location, GLsizei count, GLboolean transpose, GLdouble* value ) ; GL-FUNCTION: GLint glGetSubroutineUniformLocation { } ( GLuint program, GLenum shadertype, GLstring name ) ; GL-FUNCTION: GLuint glGetSubroutineIndex { } ( GLuint program, GLenum shadertype, GLstring name ) ; diff --git a/basis/opengl/gl3/gl3.factor b/basis/opengl/gl3/gl3.factor index 0faacacf15..f2937f1c4d 100644 --- a/basis/opengl/gl3/gl3.factor +++ b/basis/opengl/gl3/gl3.factor @@ -1212,23 +1212,23 @@ ALIAS: glUniformMatrix3x4dv gl:glUniformMatrix3x4dv ALIAS: glUniformMatrix4x2dv gl:glUniformMatrix4x2dv ALIAS: glUniformMatrix4x3dv gl:glUniformMatrix4x3dv ALIAS: glGetUniformdv gl:glGetUniformdv -ALIAS: glProgramUniform1dEXT gl:glProgramUniform1dEXT -ALIAS: glProgramUniform2dEXT gl:glProgramUniform2dEXT -ALIAS: glProgramUniform3dEXT gl:glProgramUniform3dEXT -ALIAS: glProgramUniform4dEXT gl:glProgramUniform4dEXT -ALIAS: glProgramUniform1dvEXT gl:glProgramUniform1dvEXT -ALIAS: glProgramUniform2dvEXT gl:glProgramUniform2dvEXT -ALIAS: glProgramUniform3dvEXT gl:glProgramUniform3dvEXT -ALIAS: glProgramUniform4dvEXT gl:glProgramUniform4dvEXT -ALIAS: glProgramUniformMatrix2dvEXT gl:glProgramUniformMatrix2dvEXT -ALIAS: glProgramUniformMatrix3dvEXT gl:glProgramUniformMatrix3dvEXT -ALIAS: glProgramUniformMatrix4dvEXT gl:glProgramUniformMatrix4dvEXT -ALIAS: glProgramUniformMatrix2x3dvEXT gl:glProgramUniformMatrix2x3dvEXT -ALIAS: glProgramUniformMatrix2x4dvEXT gl:glProgramUniformMatrix2x4dvEXT -ALIAS: glProgramUniformMatrix3x2dvEXT gl:glProgramUniformMatrix3x2dvEXT -ALIAS: glProgramUniformMatrix3x4dvEXT gl:glProgramUniformMatrix3x4dvEXT -ALIAS: glProgramUniformMatrix4x2dvEXT gl:glProgramUniformMatrix4x2dvEXT -ALIAS: glProgramUniformMatrix4x3dvEXT gl:glProgramUniformMatrix4x3dvEXT +ALIAS: glProgramUniform1d gl:glProgramUniform1d +ALIAS: glProgramUniform2d gl:glProgramUniform2d +ALIAS: glProgramUniform3d gl:glProgramUniform3d +ALIAS: glProgramUniform4d gl:glProgramUniform4d +ALIAS: glProgramUniform1dv gl:glProgramUniform1dv +ALIAS: glProgramUniform2dv gl:glProgramUniform2dv +ALIAS: glProgramUniform3dv gl:glProgramUniform3dv +ALIAS: glProgramUniform4dv gl:glProgramUniform4dv +ALIAS: glProgramUniformMatrix2dv gl:glProgramUniformMatrix2dv +ALIAS: glProgramUniformMatrix3dv gl:glProgramUniformMatrix3dv +ALIAS: glProgramUniformMatrix4dv gl:glProgramUniformMatrix4dv +ALIAS: glProgramUniformMatrix2x3dv gl:glProgramUniformMatrix2x3dv +ALIAS: glProgramUniformMatrix2x4dv gl:glProgramUniformMatrix2x4dv +ALIAS: glProgramUniformMatrix3x2dv gl:glProgramUniformMatrix3x2dv +ALIAS: glProgramUniformMatrix3x4dv gl:glProgramUniformMatrix3x4dv +ALIAS: glProgramUniformMatrix4x2dv gl:glProgramUniformMatrix4x2dv +ALIAS: glProgramUniformMatrix4x3dv gl:glProgramUniformMatrix4x3dv ALIAS: glGetSubroutineUniformLocation gl:glGetSubroutineUniformLocation ALIAS: glGetSubroutineIndex gl:glGetSubroutineIndex ALIAS: glGetActiveSubroutineUniformiv gl:glGetActiveSubroutineUniformiv diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index b682f582ad..045b0a588d 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -449,7 +449,7 @@ M: ebnf-sequence build-locals ( code ast -- code ) drop ] [ [ - "FROM: locals => [let :> ; FROM: sequences => nth ; [let " % + "FROM: locals => [let :> ; FROM: sequences => nth ; FROM: kernel => nip over ; [let " % [ over ebnf-var? [ " " % # " over nth :> " % diff --git a/basis/system-info/windows/nt/authors.txt b/basis/random/data/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/system-info/windows/nt/authors.txt rename to basis/random/data/authors.txt diff --git a/basis/random/data/data.factor b/basis/random/data/data.factor new file mode 100644 index 0000000000..f153065527 --- /dev/null +++ b/basis/random/data/data.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators effects.parser kernel math random +combinators.random sequences ; +IN: random.data + +: random-digit ( -- ch ) + 10 random CHAR: 0 + ; + +: random-LETTER ( -- ch ) 26 random CHAR: A + ; + +: random-letter ( -- ch ) 26 random CHAR: a + ; + +: random-Letter ( -- ch ) + { random-LETTER random-letter } execute-random ; + +: random-ch ( -- ch ) + { random-digit random-Letter } execute-random ; + +: random-string ( n -- string ) [ random-ch ] "" replicate-as ; diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 5c7026bcc8..0bf08b7878 100755 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -1,84 +1,62 @@ -USING: accessors alien.c-types alien.data byte-arrays -combinators.short-circuit continuations destructors init kernel -locals namespaces random windows.advapi32 windows.errors -windows.kernel32 windows.types math.bitwise sequences fry -literals ; +USING: accessors alien.data byte-arrays continuations +destructors init kernel literals locals namespaces random +sequences windows.advapi32 windows.errors windows.handles +windows.types ; IN: random.windows -TUPLE: windows-rng provider type ; -C: windows-rng +TUPLE: windows-crypto-context < win32-handle provider type ; -TUPLE: windows-crypto-context handle ; -C: windows-crypto-context - -M: windows-crypto-context dispose ( tuple -- ) - handle>> 0 CryptReleaseContext win32-error=0/f ; +M: windows-crypto-context dispose* ( tuple -- ) + [ handle>> 0 CryptReleaseContext win32-error=0/f ] + [ f >>handle drop ] bi ; CONSTANT: factor-crypto-container "FactorCryptoContainer" -:: (acquire-crypto-context) ( provider type flags -- ret handle ) +:: (acquire-crypto-context) ( provider type flags -- handle ) { HCRYPTPROV } [ factor-crypto-container provider type flags - CryptAcquireContextW + CryptAcquireContextW win32-error=0/f ] with-out-parameters ; : acquire-crypto-context ( provider type -- handle ) - CRYPT_MACHINE_KEYSET - (acquire-crypto-context) - swap 0 = [ - GetLastError NTE_BAD_KEYSET = - [ drop f ] [ win32-error-string throw ] if - ] when ; + CRYPT_MACHINE_KEYSET (acquire-crypto-context) ; : create-crypto-context ( provider type -- handle ) - flags{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } - (acquire-crypto-context) win32-error=0/f *void* ; + flags{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } (acquire-crypto-context) ; -ERROR: acquire-crypto-context-failed provider type ; +ERROR: acquire-crypto-context-failed provider type error ; : attempt-crypto-context ( provider type -- handle ) - { - [ acquire-crypto-context ] - [ create-crypto-context ] - [ acquire-crypto-context-failed ] - } 2|| ; + [ acquire-crypto-context ] + [ drop [ create-crypto-context ] [ acquire-crypto-context-failed ] recover ] recover ; -: windows-crypto-context ( provider type -- context ) - attempt-crypto-context ; +: initialize-crypto-context ( crypto-context -- crypto-context ) + dup [ provider>> ] [ type>> ] bi attempt-crypto-context >>handle ; -M: windows-rng random-bytes* ( n tuple -- bytes ) - [ - [ provider>> ] [ type>> ] bi - windows-crypto-context &dispose - handle>> swap dup - [ CryptGenRandom win32-error=0/f ] keep - ] with-destructors ; +: ( provider type -- windows-crypto-type ) + windows-crypto-context new-disposable + swap >>type + swap >>provider + initialize-crypto-context ; inline -ERROR: no-windows-crypto-provider error ; +M: windows-crypto-context random-bytes* ( n windows-crypto-context -- bytes ) + handle>> swap [ ] [ ] bi + [ CryptGenRandom win32-error=0/f ] keep ; -: try-crypto-providers ( seq -- windows-rng ) - [ first2 ] attempt-all - dup windows-rng? [ no-windows-crypto-provider ] unless ; +: try-crypto-providers ( seq -- windows-crypto-context ) + [ first2 ] attempt-all ; [ { ${ MS_ENHANCED_PROV PROV_RSA_FULL } ${ MS_DEF_PROV PROV_RSA_FULL } - } try-crypto-providers - system-random-generator set-global + } try-crypto-providers system-random-generator set-global { ${ MS_STRONG_PROV PROV_RSA_FULL } ${ MS_ENH_RSA_AES_PROV PROV_RSA_AES } } try-crypto-providers secure-random-generator set-global ] "random.windows" add-startup-hook - -[ - [ - ! system-random-generator get-global &dispose drop - ! secure-random-generator get-global &dispose drop - ] with-destructors -] "random.windows" add-shutdown-hook diff --git a/basis/serialize/serialize-tests.factor b/basis/serialize/serialize-tests.factor index 9213a54004..639cc1e2b0 100644 --- a/basis/serialize/serialize-tests.factor +++ b/basis/serialize/serialize-tests.factor @@ -45,7 +45,7 @@ CONSTANT: objects { 1 2 "three" } V{ 1 2 "three" } SBUF" hello world" - "hello \u123456 unicode" + "hello \u012345 unicode" \ dup [ \ dup dup ] T{ serialize-test f "a" 2 } diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor index 0f0bf169e6..b3657b60a2 100644 --- a/basis/sorting/human/human-docs.factor +++ b/basis/sorting/human/human-docs.factor @@ -6,8 +6,8 @@ IN: sorting.human HELP: find-numbers { $values - { "string" string } - { "seq" sequence } + { "sequence" sequence } + { "sequence'" sequence } } { $description "Splits a string on numbers and returns a sequence of sequences and integers." } ; diff --git a/basis/sorting/human/human-tests.factor b/basis/sorting/human/human-tests.factor index 68ddf8c3c9..6f057ecd3b 100644 --- a/basis/sorting/human/human-tests.factor +++ b/basis/sorting/human/human-tests.factor @@ -12,3 +12,10 @@ IN: sorting.human.tests [ { "4dup" "4nip" "5drop" "nip" "nip2" "nipd" } ] [ { "nip" "4dup" "4nip" "5drop" "nip2" "nipd" } [ human<=> ] sort ] unit-test + + +{ { "Abc" "abc" "def" "gh" } } +[ { "abc" "Abc" "def" "gh" } [ human<=> ] sort ] unit-test + +{ { "abc" "Abc" "def" "gh" } } +[ { "abc" "Abc" "def" "gh" } [ humani<=> ] sort ] unit-test diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index 7487f559ed..ceef6f2a15 100644 --- a/basis/sorting/human/human.factor +++ b/basis/sorting/human/human.factor @@ -1,21 +1,47 @@ -! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math math.order math.parser peg.ebnf -sequences sorting.functor ; +USING: accessors fry kernel make math math.order math.parser +sequences sorting.functor strings unicode.case +unicode.categories unicode.collation ; IN: sorting.human -: find-numbers ( string -- seq ) - [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ; +: cut-find ( sequence pred -- before after ) + [ drop ] [ find drop ] 2bi dup [ cut ] when ; inline + +: cut3 ( sequence pred -- first mid last ) + [ cut-find ] keep [ not ] compose cut-find ; inline + +: find-sequences ( sequence pred quot -- sequences ) + '[ + [ + _ cut3 [ + [ , ] + [ [ @ , ] when* ] bi* + ] dip dup + ] loop drop + ] { } make ; inline + +: find-numbers ( sequence -- sequence' ) + [ digit? ] [ string>number ] find-sequences ; ! For comparing integers or sequences TUPLE: hybrid obj ; +: ( obj -- hybrid ) + hybrid new + swap >>obj ; inline + +: ( obj -- hybrid ) + hybrid new + swap dup string? [ w/collation-key ] when >>obj ; inline + M: hybrid <=> [ obj>> ] bi@ 2dup [ integer? ] bi@ xor [ - drop integer? [ +lt+ ] [ +gt+ ] if + drop integer? +lt+ +gt+ ? ] [ <=> ] if ; -<< "human" [ find-numbers [ hybrid boa ] map ] define-sorting >> +<< "human" [ find-numbers [ ] map ] define-sorting >> +<< "humani" [ find-numbers [ ] map ] define-sorting >> diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 42c87f05b9..149168532f 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -4,7 +4,9 @@ USING: kernel arrays sequences accessors combinators math namespaces init sets words assocs alien.libraries alien alien.private alien.c-types fry quotations strings stack-checker.backend stack-checker.errors stack-checker.visitor -stack-checker.dependencies compiler.utilities ; +stack-checker.dependencies stack-checker.state +compiler.utilities effects ; +FROM: kernel.private => declare ; IN: stack-checker.alien TUPLE: alien-node-params @@ -19,7 +21,7 @@ TUPLE: alien-indirect-params < alien-node-params ; TUPLE: alien-assembly-params < alien-node-params { quot callable } ; -TUPLE: alien-callback-params < alien-node-params { quot callable } xt ; +TUPLE: alien-callback-params < alien-node-params xt ; : param-prep-quot ( params -- quot ) parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ; @@ -106,27 +108,48 @@ TUPLE: alien-callback-params < alien-node-params { quot callable } xt ; callbacks get [ dup "stack-cleanup" word-prop ] cache ; : callback-bottom ( params -- ) - xt>> '[ _ callback-xt ] infer-quot-here ; + "( callback )" >>xt + xt>> '[ _ callback-xt { alien } declare ] infer-quot-here ; : callback-return-quot ( ctype -- quot ) return>> [ [ ] ] [ c-type c-type-unboxer-quot ] if-void ; -: callback-prep-quot ( params -- quot ) - parameters>> [ c-type c-type-boxer-quot ] map spread>quot ; +: callback-parameter-quot ( params -- quot ) + parameters>> [ c-type ] map + [ [ c-type-class ] map '[ _ declare ] ] + [ [ c-type-boxer-quot ] map spread>quot ] + bi append ; -: wrap-callback-quot ( params -- quot ) - [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append - yield-hook get - '[ _ _ do-callback ] - >quotation ; +GENERIC: wrap-callback-quot ( params quot -- quot' ) + +M: callable wrap-callback-quot + swap [ callback-parameter-quot ] [ callback-return-quot ] bi surround + yield-hook get + '[ _ _ do-callback ] + >quotation ; + +: callback-effect ( params -- effect ) + [ parameters>> length "x" ] [ return>> void? { } { "x" } ? ] bi + ; + +: infer-callback-quot ( params quot -- child ) + [ + init-inference + nest-visitor + infer-quot-here + end-infer + callback-effect check-effect + stack-visitor get + ] with-scope ; : infer-alien-callback ( -- ) - alien-callback-params new - pop-quot - pop-abi - pop-params - pop-return - "( callback )" >>xt - dup wrap-callback-quot >>quot - dup callback-bottom + pop-literal nip [ + alien-callback-params new + pop-abi + pop-params + pop-return + dup callback-bottom + dup + dup + ] dip wrap-callback-quot infer-callback-quot #alien-callback, ; diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 50d5ff6189..5709448b62 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -79,7 +79,7 @@ TUPLE: depends-on-class-predicate class1 class2 result ; M: depends-on-class-predicate satisfied? { [ [ class1>> classoid? ] [ class2>> classoid? ] bi and ] - [ [ [ class1>> ] [ class2>> ] bi compare-classes ] [ result>> ] bi eq? ] + [ [ [ class1>> ] [ class2>> ] bi evaluate-class-predicate ] [ result>> ] bi eq? ] } 1&& ; TUPLE: depends-on-instance-predicate object class result ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 4b43c4c2f1..47e882f227 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -300,7 +300,7 @@ M: object infer-call* \ call bad-macro-input ; \ { integer word } { alien } define-primitive \ { integer c-ptr } { c-ptr } define-primitive \ make-flushable \ { integer integer } { string } define-primitive \ make-flushable -\ { tuple-layout } { tuple } define-primitive \ make-flushable +\ { array } { tuple } define-primitive \ make-flushable \ { object } { wrapper } define-primitive \ make-foldable \ alien-address { alien } { integer } define-primitive \ alien-address make-flushable \ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive \ alien-cell make-flushable @@ -394,7 +394,6 @@ M: object infer-call* \ call bad-macro-input ; \ float* { float float } { float } define-primitive \ float* make-foldable \ float+ { float float } { float } define-primitive \ float+ make-foldable \ float- { float float } { float } define-primitive \ float- make-foldable -\ float-mod { float float } { float } define-primitive \ float-mod make-foldable \ float-u< { float float } { object } define-primitive \ float-u< make-foldable \ float-u<= { float float } { object } define-primitive \ float-u<= make-foldable \ float-u> { float float } { object } define-primitive \ float-u> make-foldable @@ -408,6 +407,7 @@ M: object infer-call* \ call bad-macro-input ; \ float>bignum { float } { bignum } define-primitive \ float>bignum make-foldable \ float>bits { real } { integer } define-primitive \ float>bits make-foldable \ float>fixnum { float } { fixnum } define-primitive \ bignum>fixnum make-foldable +\ fpu-state { } { } define-primitive \ fputc { object alien } { } define-primitive \ fread { integer alien } { object } define-primitive \ fseek { integer integer alien } { } define-primitive @@ -445,6 +445,7 @@ M: object infer-call* \ call bad-macro-input ; \ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive \ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive \ set-context-object { object fixnum } { } define-primitive +\ set-fpu-state { } { } define-primitive \ set-innermost-frame-quot { quotation callstack } { } define-primitive \ set-slot { object object fixnum } { } define-primitive \ set-special-object { object fixnum } { } define-primitive diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 351cf5cde0..417b7fbed0 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -473,3 +473,31 @@ FROM: splitting.private => split, ; ! M\ declared-effect infer-call* didn't properly unify branches { 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as +! Make sure alien-callback effects are checked properly +USING: alien.c-types alien ; + +[ void { } cdecl [ ] alien-callback ] must-infer + +[ [ void { } cdecl [ f [ drop ] unless ] alien-callback ] infer ] [ unbalanced-branches-error? ] must-fail-with + +[ [ void { } cdecl [ drop ] alien-callback ] infer ] [ effect-error? ] must-fail-with + +[ [ int { } cdecl [ ] alien-callback ] infer ] [ effect-error? ] must-fail-with + +[ int { } cdecl [ 5 ] alien-callback ] must-infer + +[ int { int } cdecl [ ] alien-callback ] must-infer + +[ int { int } cdecl [ 1 + ] alien-callback ] must-infer + +[ void { int } cdecl [ . ] alien-callback ] must-infer + +: recursive-callback-1 ( -- x ) + void { } cdecl [ recursive-callback-1 drop ] alien-callback ; + +\ recursive-callback-1 def>> must-infer + +: recursive-callback-2 ( -- x ) + void { } cdecl [ recursive-callback-2 drop ] alien-callback ; inline recursive + +[ recursive-callback-2 ] must-infer diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 3ac6a4531f..0469f45858 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -43,6 +43,9 @@ SYMBOL: literals meta-d length "x" terminated? get ; +: check-effect ( required-effect -- ) + [ current-effect ] dip 2dup effect<= [ 2drop ] [ effect-error ] if ; + : init-inference ( -- ) terminated? off V{ } clone \ meta-d set diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index d24be0e783..435cb550c1 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -67,11 +67,9 @@ IN: stack-checker.transforms [ [ no-case ] ] [ - dup last callable? [ - dup last swap but-last - ] [ - [ no-case ] swap - ] if case>quot + dup [ callable? ] find dup + [ [ head ] dip ] [ 2drop [ no-case ] ] if + swap case>quot ] if-empty ] 1 define-transform diff --git a/basis/stack-checker/visitor/dummy/dummy.factor b/basis/stack-checker/visitor/dummy/dummy.factor index 871f79d320..3011aac10b 100644 --- a/basis/stack-checker/visitor/dummy/dummy.factor +++ b/basis/stack-checker/visitor/dummy/dummy.factor @@ -25,4 +25,4 @@ M: f #drop, drop ; M: f #alien-invoke, drop ; M: f #alien-indirect, drop ; M: f #alien-assembly, drop ; -M: f #alien-callback, drop ; +M: f #alien-callback, 2drop ; diff --git a/basis/stack-checker/visitor/visitor.factor b/basis/stack-checker/visitor/visitor.factor index d4207caf5b..5871f73a4a 100644 --- a/basis/stack-checker/visitor/visitor.factor +++ b/basis/stack-checker/visitor/visitor.factor @@ -30,4 +30,4 @@ HOOK: #copy, stack-visitor ( inputs outputs -- ) HOOK: #alien-invoke, stack-visitor ( params -- ) HOOK: #alien-indirect, stack-visitor ( params -- ) HOOK: #alien-assembly, stack-visitor ( params -- ) -HOOK: #alien-callback, stack-visitor ( params -- ) +HOOK: #alien-callback, stack-visitor ( params child -- ) diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index 8f728c1eda..9e111ed2e2 100644 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -29,6 +29,7 @@ IN: suffix-arrays PRIVATE> : >suffix-array ( seq -- array ) + members [ suffixes ] map concat natural-sort ; SYNTAX: SA{ \ } [ >suffix-array ] parse-literal ; diff --git a/basis/system-info/windows/ce/ce.factor b/basis/system-info/windows/ce/ce.factor deleted file mode 100644 index 8c4f81a117..0000000000 --- a/basis/system-info/windows/ce/ce.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.data system-info kernel math namespaces -windows windows.kernel32 system-info.backend system ; -IN: system-info.windows.ce - -: memory-status ( -- MEMORYSTATUS ) - "MEMORYSTATUS" - "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength - dup GlobalMemoryStatus ; - -M: wince cpus ( -- n ) 1 ; - -M: wince memory-load ( -- n ) - memory-status MEMORYSTATUS-dwMemoryLoad ; - -M: wince physical-mem ( -- n ) - memory-status MEMORYSTATUS-dwTotalPhys ; - -M: wince available-mem ( -- n ) - memory-status MEMORYSTATUS-dwAvailPhys ; - -M: wince total-page-file ( -- n ) - memory-status MEMORYSTATUS-dwTotalPageFile ; - -M: wince available-page-file ( -- n ) - memory-status MEMORYSTATUS-dwAvailPageFile ; - -M: wince total-virtual-mem ( -- n ) - memory-status MEMORYSTATUS-dwTotalVirtual ; - -M: wince available-virtual-mem ( -- n ) - memory-status MEMORYSTATUS-dwAvailVirtual ; diff --git a/basis/system-info/windows/ce/platforms.txt b/basis/system-info/windows/ce/platforms.txt deleted file mode 100644 index cd0d980f6f..0000000000 --- a/basis/system-info/windows/ce/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -wince diff --git a/basis/system-info/windows/nt/nt.factor b/basis/system-info/windows/nt/nt.factor deleted file mode 100644 index 804eb25def..0000000000 --- a/basis/system-info/windows/nt/nt.factor +++ /dev/null @@ -1,47 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings -kernel libc math namespaces system-info.backend -system-info.windows windows windows.advapi32 -windows.kernel32 system byte-arrays windows.errors -classes classes.struct accessors ; -IN: system-info.windows.nt - -M: winnt cpus ( -- n ) - system-info dwNumberOfProcessors>> ; - -: memory-status ( -- MEMORYSTATUSEX ) - MEMORYSTATUSEX - MEMORYSTATUSEX heap-size >>dwLength - dup GlobalMemoryStatusEx win32-error=0/f ; - -M: winnt memory-load ( -- n ) - memory-status dwMemoryLoad>> ; - -M: winnt physical-mem ( -- n ) - memory-status ullTotalPhys>> ; - -M: winnt available-mem ( -- n ) - memory-status ullAvailPhys>> ; - -M: winnt total-page-file ( -- n ) - memory-status ullTotalPageFile>> ; - -M: winnt available-page-file ( -- n ) - memory-status ullAvailPageFile>> ; - -M: winnt total-virtual-mem ( -- n ) - memory-status ullTotalVirtual>> ; - -M: winnt available-virtual-mem ( -- n ) - memory-status ullAvailVirtual>> ; - -: computer-name ( -- string ) - MAX_COMPUTERNAME_LENGTH 1 + - [ dup ] keep - GetComputerName win32-error=0/f alien>native-string ; - -: username ( -- string ) - UNLEN 1 + - [ dup ] keep - GetUserName win32-error=0/f alien>native-string ; diff --git a/basis/system-info/windows/nt/platforms.txt b/basis/system-info/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/system-info/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/system-info/windows/nt/nt-tests.factor b/basis/system-info/windows/windows-tests.factor old mode 100755 new mode 100644 similarity index 58% rename from basis/system-info/windows/nt/nt-tests.factor rename to basis/system-info/windows/windows-tests.factor index dfbd8b3283..d26e86742c --- a/basis/system-info/windows/nt/nt-tests.factor +++ b/basis/system-info/windows/windows-tests.factor @@ -1,7 +1,6 @@ USING: math.order strings system-info.backend -system-info.windows system-info.windows.nt -tools.test ; -IN: system-info.windows.nt.tests +system-info.windows tools.test ; +IN: system-info.windows.tests [ t ] [ cpus 0 1024 between? ] unit-test [ t ] [ username string? ] unit-test diff --git a/basis/system-info/windows/windows.factor b/basis/system-info/windows/windows.factor index 07cbcc41b3..0aba5eeff1 100644 --- a/basis/system-info/windows/windows.factor +++ b/basis/system-info/windows/windows.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types classes.struct accessors kernel -math namespaces windows windows.kernel32 windows.advapi32 words -combinators vocabs.loader system-info.backend system -alien.strings windows.errors specialized-arrays ; +USING: accessors alien alien.c-types alien.strings byte-arrays +classes.struct combinators kernel math namespaces +specialized-arrays system +system-info.backend vocabs.loader windows windows.advapi32 +windows.errors windows.kernel32 words ; SPECIALIZED-ARRAY: ushort IN: system-info.windows @@ -63,8 +64,41 @@ IN: system-info.windows : system-windows-directory ( -- str ) \ GetSystemWindowsDirectory get-directory ; -<< -{ - { [ os wince? ] [ "system-info.windows.ce" ] } - { [ os winnt? ] [ "system-info.windows.nt" ] } -} cond require >> +M: winnt cpus ( -- n ) + system-info dwNumberOfProcessors>> ; + +: memory-status ( -- MEMORYSTATUSEX ) + MEMORYSTATUSEX + MEMORYSTATUSEX heap-size >>dwLength + dup GlobalMemoryStatusEx win32-error=0/f ; + +M: winnt memory-load ( -- n ) + memory-status dwMemoryLoad>> ; + +M: winnt physical-mem ( -- n ) + memory-status ullTotalPhys>> ; + +M: winnt available-mem ( -- n ) + memory-status ullAvailPhys>> ; + +M: winnt total-page-file ( -- n ) + memory-status ullTotalPageFile>> ; + +M: winnt available-page-file ( -- n ) + memory-status ullAvailPageFile>> ; + +M: winnt total-virtual-mem ( -- n ) + memory-status ullTotalVirtual>> ; + +M: winnt available-virtual-mem ( -- n ) + memory-status ullAvailVirtual>> ; + +: computer-name ( -- string ) + MAX_COMPUTERNAME_LENGTH 1 + + [ dup ] keep + GetComputerName win32-error=0/f alien>native-string ; + +: username ( -- string ) + UNLEN 1 + + [ dup ] keep + GetUserName win32-error=0/f alien>native-string ; diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index 01578d4e64..d5e2f806b6 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -1,6 +1,6 @@ -USING: namespaces io tools.test threads kernel +USING: namespaces io tools.test threads threads.private kernel concurrency.combinators concurrency.promises locals math -words calendar sequences ; +words calendar sequences fry ; IN: threads.tests 3 "x" set @@ -59,3 +59,21 @@ yield ! Test system traps inside threads [ ] [ [ dup ] in-thread yield ] unit-test + +! The start-context-and-delete primitive wasn't rewinding the +! callstack properly. + +! This got fixed for x86-64 but the problem remained on x86-32. + +! The unit test asserts that the callstack is empty from the +! quotation passed to start-context-and-delete. + +[ { } ] [ + [ + '[ + _ [ + callstack swap fulfill stop + ] start-context-and-delete + ] in-thread + ] [ ?promise callstack>array ] bi +] unit-test diff --git a/basis/timers/timers-docs.factor b/basis/timers/timers-docs.factor index fb07c8a4cc..f3a3e4437b 100644 --- a/basis/timers/timers-docs.factor +++ b/basis/timers/timers-docs.factor @@ -53,8 +53,8 @@ HELP: delayed-every } } ; -ARTICLE: "timers" "Alarms" -"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl +ARTICLE: "timers" "Timers" +"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Timers run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Timers use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl "The timer class:" { $subsections timer } "Create a timer before starting it:" diff --git a/basis/tools/completion/completion-docs.factor b/basis/tools/completion/completion-docs.factor index 7d5ebf8910..87e675efa6 100644 --- a/basis/tools/completion/completion-docs.factor +++ b/basis/tools/completion/completion-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax strings generic vectors assocs -math ; +math make ; IN: tools.completion ARTICLE: "tools.completion" "Fuzzy completion" @@ -50,6 +50,14 @@ HELP: completion } } ; +HELP: completion, +{ $values { "short" string } { "candidate" "a pair " { $snippet "{ obj full }" } } } +{ $description + "Adds the result of " { $link completion } + " to the end of the sequence being constructed by " { $link make } + " if the score is positive." +} ; + HELP: completions { $values { "short" string } { "candidates" "a sequence of pairs of the shape " { $snippet "{ obj full }" } } { "seq" "a sequence of pairs of the shape " { $snippet "{ score obj }" } } } { $description "Calls " { $link completion } " to produce a sequence of " { $snippet "{ score obj }" } " pairs, then calls " { $link rank-completions } " to sort them and discard the low 33%." } ; diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index d62c192ac1..abb9ecfe39 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel arrays sequences math namespaces strings io -fry vectors words assocs combinators sorting unicode.case -unicode.categories math.order vocabs vocabs.hierarchy unicode.data -locals ; + +USING: accessors arrays assocs combinators fry io kernel locals +make math math.order namespaces sequences sorting strings +unicode.case unicode.categories unicode.data vectors vocabs +vocabs.hierarchy words ; + IN: tools.completion :: (fuzzy) ( accum i full ch -- accum i full ? ) @@ -64,9 +66,14 @@ IN: tools.completion : completion ( short candidate -- result ) [ second >lower swap complete ] keep 2array ; +: completion, ( short candidate -- ) + completion dup first 0 > [ , ] [ drop ] if ; + : completions ( short candidates -- seq ) - [ ] [ [ >lower ] dip [ completion ] with map rank-completions ] - bi-curry if-empty ; + [ ] [ + [ >lower ] dip [ [ completion, ] with each ] { } make + rank-completions + ] bi-curry if-empty ; : name-completions ( str seq -- seq' ) [ dup name>> ] { } map>assoc completions ; @@ -79,3 +86,4 @@ IN: tools.completion : chars-matching ( str -- seq ) name-map keys dup zip completions ; + diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index 4ee9869f76..0b06abc29a 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/basis/tools/deploy/config/config-docs.factor @@ -46,7 +46,6 @@ $nl { $link heap-size } { $link } { $link } - { $link malloc-object } { $link malloc-array } } "If your program looks up C types dynamically or from words which do not have a stack effect, you must enable this flag, because in these situations the C type lookup code is not folded away and the word properties must be consulted at runtime." } ; diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 7a505ca957..fa446ad44c 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -68,8 +68,8 @@ M: quit-responder call-responder* 0 >>insecure f >>secure - dup start-server* - sockets>> first addr>> port>> + start-server + servers>> first addr>> port>> dup number>string "resource:temp/port-number" ascii set-file-contents ] with-scope "port" set ; diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 7981859573..7fad2414fc 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -6,7 +6,7 @@ sequences locals system splitting tools.deploy.backend tools.deploy.config tools.deploy.config.editor assocs hashtables prettyprint combinators windows.kernel32 windows.shell32 windows.user32 alien.c-types vocabs.metadata vocabs.loader tools.deploy.windows.ico -io.files.windows.nt ; +io.files.windows ; IN: tools.deploy.windows CONSTANT: app-icon-resource-id "APPICON" diff --git a/basis/tools/disassembler/disassembler-docs.factor b/basis/tools/disassembler/disassembler-docs.factor index 8ee5ff48bd..22507b2cc3 100644 --- a/basis/tools/disassembler/disassembler-docs.factor +++ b/basis/tools/disassembler/disassembler-docs.factor @@ -8,6 +8,9 @@ HELP: disassemble ARTICLE: "tools.disassembler" "Disassembling words" "The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC." +$nl +"See also " { $vocab-link "compiler.tree.debugger" } " and " { $vocab-link "compiler.cfg.debugger" } "." +$nl { $subsections disassemble } ; ABOUT: "tools.disassembler" diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 17df1a13f2..3141f1d098 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -7,6 +7,7 @@ math.parser io.streams.string ui.tools.operations quotations strings arrays prettyprint words vocabs sorting sets classes math alien urls splitting ascii combinators.short-circuit timers words.symbol system summary ; +FROM: sets => members ; IN: tools.scaffold SYMBOL: developer-name @@ -164,15 +165,20 @@ M: bad-developer-name summary : 4bl ( -- ) " " write ; inline +: ?print-nl ( seq1 seq2 -- ) + [ empty? ] either? [ nl ] unless ; + : $values. ( word -- ) "declared-effect" word-prop [ [ in>> ] [ out>> ] bi 2dup [ empty? ] bi@ and [ 2drop ] [ + [ members ] dip over diff "{ $values" print - [ 4bl ($values.) ] - [ [ nl 4bl ($values.) ] unless-empty ] bi* + [ drop 4bl ($values.) ] + [ ?print-nl ] + [ nip 4bl ($values.) ] 2tri nl "}" print ] if ] when* ; diff --git a/basis/tools/time/time-docs.factor b/basis/tools/time/time-docs.factor index a3b8e9fc7e..8d891c1aa4 100644 --- a/basis/tools/time/time-docs.factor +++ b/basis/tools/time/time-docs.factor @@ -10,13 +10,13 @@ ARTICLE: "timing" "Timing code and collecting statistics" "A lower-level word puts timings on the stack, intead of printing:" { $subsections benchmark } "You can also read the system clock directly; see " { $link "system" } "." -{ $see-also "profiling" "calendar" } ; +{ $see-also "profiling" "tools.annotations" "calendar" } ; ABOUT: "timing" HELP: benchmark { $values { "quot" quotation } - { "runtime" "the runtime in microseconds" } } + { "runtime" "the runtime in nanoseconds" } } { $description "Runs a quotation, measuring the total wall clock time." } { $notes "A nicer word for interactive use is " { $link time } "." } ; diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 0fbf0eeaa0..aa64e9a72d 100644 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -1,5 +1,5 @@ USING: tuple-arrays sequences tools.test namespaces kernel -math accessors classes.tuple eval ; +math accessors classes.tuple eval classes.struct ; IN: tuple-arrays.tests SYMBOL: mat @@ -41,4 +41,31 @@ TUPLE: non-final x ; [ "IN: tuple-arrays.tests USE: tuple-arrays TUPLE-ARRAY: non-final" eval( -- ) ] [ error>> not-final? ] -must-fail-with \ No newline at end of file +must-fail-with + +! Empty tuple +TUPLE: empty-tuple ; final + +TUPLE-ARRAY: empty-tuple + +[ 100 ] [ 100 length ] unit-test +[ T{ empty-tuple } ] [ 100 first ] unit-test +[ ] [ T{ empty-tuple } 100 set-first ] unit-test + +! Changing a tuple into a struct shouldn't break the tuple array to the point +! of crashing Factor +TUPLE: tuple-to-struct x ; final + +TUPLE-ARRAY: tuple-to-struct + +[ f ] [ tuple-to-struct struct-class? ] unit-test + +! This shouldn't crash +[ ] [ + "IN: tuple-arrays.tests + USING: alien.c-types classes.struct ; + STRUCT: tuple-to-struct { x int } ;" + eval( -- ) +] unit-test + +[ t ] [ tuple-to-struct struct-class? ] unit-test \ No newline at end of file diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index dba6184c58..5178dbb499 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -7,7 +7,7 @@ ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io kernel math math.vectors namespaces make sequences strings vectors words windows.dwmapi system-info.windows windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages -windows.types windows.offscreen windows.nt threads libc combinators +windows.types windows.offscreen windows threads libc combinators fry combinators.short-circuit continuations command-line shuffle opengl ui.render math.bitwise locals accessors math.rectangles math.order calendar ascii sets io.encodings.utf16n @@ -615,8 +615,12 @@ SYMBOL: trace-messages? : ui-wndproc ( -- object ) uint { void* uint long long } stdcall [ pick - trace-messages? get-global [ dup windows-message-name name>> print flush ] when - wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if + + trace-messages? get-global + [ dup windows-message-name name>> print flush ] when + + wm-handlers get-global at* + [ call( hWnd Msg wParam lParam -- result ) ] [ drop DefWindowProc ] if ] alien-callback ; : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ; diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor index dc3cd89b51..2c29de3f28 100644 --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -149,10 +149,8 @@ PRIVATE> : quaternary= ( str1 str2 -- ? ) 0 insensitive= ; - : sort-strings ( strings -- sorted ) [ w/collation-key ] map natural-sort values ; diff --git a/basis/unix/ffi/bsd/bsd.factor b/basis/unix/ffi/bsd/bsd.factor index ad323bf14a..3b3052af23 100644 --- a/basis/unix/ffi/bsd/bsd.factor +++ b/basis/unix/ffi/bsd/bsd.factor @@ -64,6 +64,7 @@ CONSTANT: max-un-path 104 CONSTANT: SOCK_STREAM 1 CONSTANT: SOCK_DGRAM 2 +CONSTANT: SOCK_RAW 3 CONSTANT: AF_UNSPEC 0 CONSTANT: AF_UNIX 1 diff --git a/basis/unix/ffi/ffi.factor b/basis/unix/ffi/ffi.factor index 5b26cf8deb..56d08b8f7e 100644 --- a/basis/unix/ffi/ffi.factor +++ b/basis/unix/ffi/ffi.factor @@ -52,6 +52,11 @@ STRUCT: group { gr_gid int } { gr_mem c-string* } ; +STRUCT: protoent + { name c-string } + { aliases void* } + { proto int } ; + FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; FUNCTION: int chdir ( c-string path ) ; @@ -100,6 +105,7 @@ FUNCTION: void endgrent ( ) ; FUNCTION: int gethostname ( c-string name, int len ) ; FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ; FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ; +FUNCTION: protoent* getprotobyname ( c-string name ) ; FUNCTION: uid_t getuid ; FUNCTION: uint htonl ( uint n ) ; FUNCTION: ushort htons ( ushort n ) ; diff --git a/basis/unix/ffi/linux/linux.factor b/basis/unix/ffi/linux/linux.factor index 3f19e18c14..437280e819 100644 --- a/basis/unix/ffi/linux/linux.factor +++ b/basis/unix/ffi/linux/linux.factor @@ -62,6 +62,7 @@ STRUCT: sockaddr-un CONSTANT: SOCK_STREAM 1 CONSTANT: SOCK_DGRAM 2 +CONSTANT: SOCK_RAW 3 CONSTANT: AF_UNSPEC 0 CONSTANT: AF_UNIX 1 diff --git a/basis/urls/secure/secure.factor b/basis/urls/secure/secure.factor index d2fa55f7f3..1c9b925641 100644 --- a/basis/urls/secure/secure.factor +++ b/basis/urls/secure/secure.factor @@ -1,6 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: urls urls.private io.sockets io.sockets.secure ; IN: urls.secure +UNION: abstract-inet inet inet4 inet6 ; + M: abstract-inet >secure-addr ; diff --git a/basis/vocabs/metadata/resources/resources.factor b/basis/vocabs/metadata/resources/resources.factor index d8f9bdcffd..1ff002d13a 100644 --- a/basis/vocabs/metadata/resources/resources.factor +++ b/basis/vocabs/metadata/resources/resources.factor @@ -1,6 +1,6 @@ ! (c)2010 Joe Groff bsd license -USING: arrays fry globs io.directories io.files.info -io.pathnames kernel regexp sequences vocabs.loader +USING: arrays fry globs io.directories io.directories.hierarchy +io.files.info io.pathnames kernel regexp sequences vocabs.loader vocabs.metadata ; IN: vocabs.metadata.resources diff --git a/basis/windows/ce/ce.factor b/basis/windows/ce/ce.factor deleted file mode 100644 index 614a535ea0..0000000000 --- a/basis/windows/ce/ce.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: alien sequences alien.libraries ; -{ - { "advapi32" "\\windows\\coredll.dll" stdcall } - { "gdi32" "\\windows\\coredll.dll" stdcall } - { "user32" "\\windows\\coredll.dll" stdcall } - { "kernel32" "\\windows\\coredll.dll" stdcall } - { "winsock" "\\windows\\ws2.dll" stdcall } - { "mswsock" "\\windows\\ws2.dll" stdcall } - { "libc" "\\windows\\coredll.dll" stdcall } - { "libm" "\\windows\\coredll.dll" stdcall } - ! { "gl" "libGLES_CM.dll" stdcall } - ! { "glu" "libGLES_CM.dll" stdcall } - { "ole32" "ole32.dll" stdcall } -} [ first3 add-library ] each diff --git a/basis/windows/ce/platforms.txt b/basis/windows/ce/platforms.txt deleted file mode 100644 index cd0d980f6f..0000000000 --- a/basis/windows/ce/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -wince diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor index 094859009d..e4b6d1e85a 100644 --- a/basis/windows/com/com.factor +++ b/basis/windows/com/com.factor @@ -36,10 +36,9 @@ FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ; FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; : com-query-interface ( interface iid -- interface' ) - [ - void* malloc-object &free - [ IUnknown::QueryInterface ole32-error ] keep *void* - ] with-destructors ; + { void* } + [ IUnknown::QueryInterface ole32-error ] + with-out-parameters ; : com-add-ref ( interface -- interface ) [ IUnknown::AddRef drop ] keep ; inline diff --git a/basis/windows/directx/dxfile/dxfile.factor b/basis/windows/directx/dxfile/dxfile.factor old mode 100644 new mode 100755 index 60d072256c..e549445eb6 --- a/basis/windows/directx/dxfile/dxfile.factor +++ b/basis/windows/directx/dxfile/dxfile.factor @@ -1,4 +1,4 @@ -USING: alien.syntax classes.struct windows.com +USING: alien.syntax alien.c-types classes.struct windows.com windows.com.syntax windows.kernel32 windows.ole32 windows.types ; IN: windows.directx.dxfile diff --git a/basis/windows/directx/xinput/xinput.factor b/basis/windows/directx/xinput/xinput.factor old mode 100644 new mode 100755 index d51e37af65..618aeb4840 --- a/basis/windows/directx/xinput/xinput.factor +++ b/basis/windows/directx/xinput/xinput.factor @@ -1,4 +1,4 @@ -USING: alien.syntax classes.struct windows.kernel32 windows.types ; +USING: alien.c-types alien.syntax classes.struct windows.kernel32 windows.types ; IN: windows.directx.xinput LIBRARY: xinput diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index a4943ef877..99284bdb80 100755 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -734,10 +734,8 @@ ERROR: windows-error n string ; : win32-error<0 ( n -- ) 0 < [ win32-error ] when ; : win32-error<>0 ( n -- ) zero? [ win32-error ] unless ; -: invalid-handle? ( handle -- ) - INVALID_HANDLE_VALUE = [ - win32-error-string throw - ] when ; +: check-invalid-handle ( handle -- handle ) + dup INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ; CONSTANT: expected-io-errors ${ diff --git a/basis/windows/ce/authors.txt b/basis/windows/handles/authors.txt similarity index 100% rename from basis/windows/ce/authors.txt rename to basis/windows/handles/authors.txt diff --git a/basis/windows/handles/handles.factor b/basis/windows/handles/handles.factor new file mode 100644 index 0000000000..07d6c8f5d2 --- /dev/null +++ b/basis/windows/handles/handles.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors destructors kernel windows.errors +windows.kernel32 windows.types ; +IN: windows.handles + +TUPLE: win32-handle < disposable handle ; + +: set-inherit ( handle ? -- ) + [ handle>> HANDLE_FLAG_INHERIT ] dip + >BOOLEAN SetHandleInformation win32-error=0/f ; + +: new-win32-handle ( handle class -- win32-handle ) + new-disposable swap >>handle + dup f set-inherit ; + +: ( handle -- win32-handle ) + win32-handle new-win32-handle ; + +M: win32-handle dispose* ( handle -- ) + handle>> CloseHandle win32-error=0/f ; diff --git a/basis/windows/handles/platforms.txt b/basis/windows/handles/platforms.txt new file mode 100644 index 0000000000..d493d3459b --- /dev/null +++ b/basis/windows/handles/platforms.txt @@ -0,0 +1 @@ +windows \ No newline at end of file diff --git a/basis/windows/nt/nt.factor b/basis/windows/nt/nt.factor deleted file mode 100644 index 4b119ba5fa..0000000000 --- a/basis/windows/nt/nt.factor +++ /dev/null @@ -1,35 +0,0 @@ -USING: alien sequences alien.libraries ; -{ - { "advapi32" "advapi32.dll" stdcall } - { "dinput" "dinput8.dll" stdcall } - { "gdi32" "gdi32.dll" stdcall } - { "user32" "user32.dll" stdcall } - { "kernel32" "kernel32.dll" stdcall } - { "winsock" "ws2_32.dll" stdcall } - { "mswsock" "mswsock.dll" stdcall } - { "shell32" "shell32.dll" stdcall } - { "libc" "msvcrt.dll" cdecl } - { "libm" "msvcrt.dll" cdecl } - { "gl" "opengl32.dll" stdcall } - { "glu" "glu32.dll" stdcall } - { "ole32" "ole32.dll" stdcall } - { "usp10" "usp10.dll" stdcall } - { "psapi" "psapi.dll" stdcall } - { "xinput" "xinput1_3.dll" stdcall } - { "dxgi" "dxgi.dll" stdcall } - { "d2d1" "d2d1.dll" stdcall } - { "d3d9" "d3d9.dll" stdcall } - { "d3d10" "d3d10.dll" stdcall } - { "d3d10_1" "d3d10_1.dll" stdcall } - { "d3d11" "d3d11.dll" stdcall } - { "d3dcompiler" "d3dcompiler_42.dll" stdcall } - { "d3dcsx" "d3dcsx_42.dll" stdcall } - { "d3dx9" "d3dx9_42.dll" stdcall } - { "d3dx10" "d3dx10_42.dll" stdcall } - { "d3dx11" "d3dx11_42.dll" stdcall } - { "dwrite" "dwrite.dll" stdcall } - { "x3daudio" "x3daudio1_6.dll" stdcall } - { "xactengine" "xactengine3_5.dll" stdcall } - { "xapofx" "xapofx1_3.dll" stdcall } - { "xaudio2" "xaudio2_5.dll" stdcall } -} [ first3 add-library ] each diff --git a/basis/windows/nt/platforms.txt b/basis/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/windows/nt/authors.txt b/basis/windows/privileges/authors.txt similarity index 100% rename from basis/windows/nt/authors.txt rename to basis/windows/privileges/authors.txt diff --git a/basis/io/backend/windows/privileges/platforms.txt b/basis/windows/privileges/platforms.txt similarity index 100% rename from basis/io/backend/windows/privileges/platforms.txt rename to basis/windows/privileges/platforms.txt diff --git a/basis/windows/privileges/privileges-tests.factor b/basis/windows/privileges/privileges-tests.factor new file mode 100644 index 0000000000..355ed71614 --- /dev/null +++ b/basis/windows/privileges/privileges-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test windows.privileges ; +IN: windows.privileges.tests diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/windows/privileges/privileges.factor similarity index 70% rename from basis/io/backend/windows/nt/privileges/privileges.factor rename to basis/windows/privileges/privileges.factor index 896785b048..ed2827ed8a 100644 --- a/basis/io/backend/windows/nt/privileges/privileges.factor +++ b/basis/windows/privileges/privileges.factor @@ -1,11 +1,9 @@ -USING: alien alien.c-types alien.data alien.syntax arrays -continuations destructors generic io.mmap io.ports -io.backend.windows io.files.windows kernel libc fry locals math -math.bitwise namespaces quotations sequences windows -windows.advapi32 windows.kernel32 windows.types io.backend -system accessors io.backend.windows.privileges classes.struct -windows.errors literals ; -IN: io.backend.windows.nt.privileges +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.data alien.syntax classes.struct +continuations fry kernel libc literals locals sequences +windows.advapi32 windows.errors windows.kernel32 windows.types ; +IN: windows.privileges TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES @@ -40,7 +38,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES name lookup-privilege >>Luid >>Privileges ; -M: winnt set-privilege ( name ? -- ) +: set-privilege ( name ? -- ) '[ 0 _ _ make-token-privileges @@ -49,3 +47,8 @@ M: winnt set-privilege ( name ? -- ) f AdjustTokenPrivileges win32-error=0/f ] with-process-token ; + +: with-privileges ( seq quot -- ) + [ '[ _ [ t set-privilege ] each @ ] ] + [ drop '[ _ [ f set-privilege ] each ] ] + 2bi [ ] cleanup ; inline diff --git a/basis/windows/time/time.factor b/basis/windows/time/time.factor index 904c85200e..913e613312 100644 --- a/basis/windows/time/time.factor +++ b/basis/windows/time/time.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types kernel math windows.errors windows.kernel32 windows.types namespaces calendar math.bitwise -accessors classes.struct ; +accessors classes.struct windows.handles ; IN: windows.time : >64bit ( lo hi -- n ) diff --git a/basis/windows/windows.factor b/basis/windows/windows.factor index 92ba8b638a..dcdcb8b227 100644 --- a/basis/windows/windows.factor +++ b/basis/windows/windows.factor @@ -1,5 +1,41 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. +USING: alien sequences alien.libraries ; IN: windows CONSTANT: MAX_UNICODE_PATH 32768 + +{ + { "advapi32" "advapi32.dll" stdcall } + { "dinput" "dinput8.dll" stdcall } + { "gdi32" "gdi32.dll" stdcall } + { "user32" "user32.dll" stdcall } + { "kernel32" "kernel32.dll" stdcall } + { "winsock" "ws2_32.dll" stdcall } + { "mswsock" "mswsock.dll" stdcall } + { "shell32" "shell32.dll" stdcall } + { "libc" "msvcrt.dll" cdecl } + { "libm" "msvcrt.dll" cdecl } + { "gl" "opengl32.dll" stdcall } + { "glu" "glu32.dll" stdcall } + { "ole32" "ole32.dll" stdcall } + { "usp10" "usp10.dll" stdcall } + { "psapi" "psapi.dll" stdcall } + { "xinput" "xinput1_3.dll" stdcall } + { "dxgi" "dxgi.dll" stdcall } + { "d2d1" "d2d1.dll" stdcall } + { "d3d9" "d3d9.dll" stdcall } + { "d3d10" "d3d10.dll" stdcall } + { "d3d10_1" "d3d10_1.dll" stdcall } + { "d3d11" "d3d11.dll" stdcall } + { "d3dcompiler" "d3dcompiler_42.dll" stdcall } + { "d3dcsx" "d3dcsx_42.dll" stdcall } + { "d3dx9" "d3dx9_42.dll" stdcall } + { "d3dx10" "d3dx10_42.dll" stdcall } + { "d3dx11" "d3dx11_42.dll" stdcall } + { "dwrite" "dwrite.dll" stdcall } + { "x3daudio" "x3daudio1_6.dll" stdcall } + { "xactengine" "xactengine3_5.dll" stdcall } + { "xapofx" "xapofx1_3.dll" stdcall } + { "xaudio2" "xaudio2_5.dll" stdcall } +} [ first3 add-library ] each diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 4dd7d7385c..384f18caef 100644 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -7,7 +7,7 @@ classes.struct windows.com.syntax init ; FROM: alien.c-types => short ; IN: windows.winsock -TYPEDEF: void* SOCKET +TYPEDEF: int* SOCKET : ( -- byte-array ) HEX: 190 ; @@ -96,7 +96,7 @@ CONSTANT: INADDR_ANY 0 : INVALID_SOCKET ( -- n ) -1 ; inline -CONSTANT: SOCKET_ERROR -1 +: SOCKET_ERROR ( -- n ) -1 ; inline CONSTANT: SD_RECV 0 CONSTANT: SD_SEND 1 @@ -126,6 +126,11 @@ STRUCT: hostent { length short } { addr-list void* } ; +STRUCT: protoent + { name c-string } + { aliases void* } + { proto short } ; + STRUCT: addrinfo { flags int } { family int } @@ -171,6 +176,8 @@ FUNCTION: int recv ( SOCKET s, c-string buf, int len, int flags ) ; FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ; FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ; +FUNCTION: protoent* getprotobyname ( c-string name ) ; + TYPEDEF: uint SERVICETYPE TYPEDEF: OVERLAPPED WSAOVERLAPPED TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED @@ -376,7 +383,6 @@ FUNCTION: DWORD WSAWaitForMultipleEvents ( DWORD cEvents, LIBRARY: mswsock -! Not in Windows CE FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ; FUNCTION: void GetAcceptExSockaddrs ( @@ -394,35 +400,40 @@ CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090 CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e} +ERROR: winsock-exception n string ; + : winsock-expected-error? ( n -- ? ) ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ; -: (winsock-error-string) ( n -- str ) +: (maybe-winsock-exception) ( n -- winsock-exception/f ) ! #! WSAStartup returns the error code 'n' directly dup winsock-expected-error? - [ drop f ] [ n>win32-error-string ] if ; + [ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ; -: winsock-error-string ( -- string/f ) - WSAGetLastError (winsock-error-string) ; +: maybe-winsock-exception ( -- winsock-exception/f ) + WSAGetLastError (maybe-winsock-exception) ; : winsock-error ( -- ) - winsock-error-string [ throw ] when* ; + maybe-winsock-exception [ throw ] when* ; +: (throw-winsock-error) ( n -- * ) + [ ] [ n>win32-error-string ] bi winsock-exception ; + +: throw-winsock-error ( -- * ) + WSAGetLastError (throw-winsock-error) ; + : winsock-error=0/f ( n/f -- ) - { 0 f } member? [ - winsock-error-string throw - ] when ; + { 0 f } member? [ throw-winsock-error ] when ; : winsock-error!=0/f ( n/f -- ) - { 0 f } member? [ - winsock-error-string throw - ] unless ; + { 0 f } member? [ throw-winsock-error ] unless ; +! WSAStartup and WSACleanup return the error code directly : winsock-return-check ( n/f -- ) dup { 0 f } member? [ drop ] [ - (winsock-error-string) throw + [ ] [ n>win32-error-string ] bi winsock-exception ] if ; : socket-error* ( n -- ) @@ -431,7 +442,7 @@ CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e} dup WSA_IO_PENDING = [ drop ] [ - (winsock-error-string) throw + (maybe-winsock-exception) throw ] if ] when ; diff --git a/basis/xml/traversal/traversal-tests.factor b/basis/xml/traversal/traversal-tests.factor index 165ca34adf..c7e8c0a4ae 100644 --- a/basis/xml/traversal/traversal-tests.factor +++ b/basis/xml/traversal/traversal-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml xml.traversal tools.test xml.data sequences ; +USING: xml xml.traversal tools.test xml.data sequences arrays ; IN: xml.traversal.tests [ "bar" ] [ "bar" string>xml children>string ] unit-test @@ -16,3 +16,6 @@ IN: xml.traversal.tests [ "blah" ] [ "" string>xml "foo" deep-tag-named "attr" attr ] unit-test [ { "blah" } ] [ "" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test + +[ { "blah" } ] [ "" string>xml "blah" "attr" tags-with-attr [ "attr" attr ] map ] unit-test +[ { "blah" } ] [ "bar" { { "attr" "blah" } } f 1array "blah" "attr" tags-with-attr [ "attr" attr ] map ] unit-test diff --git a/basis/xml/traversal/traversal.factor b/basis/xml/traversal/traversal.factor index 46a5896814..c1c4ba670b 100644 --- a/basis/xml/traversal/traversal.factor +++ b/basis/xml/traversal/traversal.factor @@ -50,7 +50,7 @@ PRIVATE> assure-name '[ _ _ tag-with-attr? ] find nip ; : tags-with-attr ( tag attr-value attr-name -- tags-seq ) - assure-name '[ _ _ tag-with-attr? ] filter children>> ; + assure-name '[ _ _ tag-with-attr? ] { } filter-as ; : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag ) assure-name '[ _ _ tag-with-attr? ] deep-find ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor index d67e0a12b9..98b1d6428c 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -106,12 +106,12 @@ SYMBOL: callbacks ! returning from it, to avoid a bad interaction between threads ! and callbacks. See basis/compiler/tests/alien.factor for a ! test case. -: wait-to-return ( yield-quot callback-id -- ) +: wait-to-return ( yield-quot: ( -- ) callback-id -- ) dup current-callback eq? - [ 2drop ] [ over call( -- ) wait-to-return ] if ; + [ 2drop ] [ over call wait-to-return ] if ; inline recursive ! Used by compiler.codegen to wrap callback bodies -: do-callback ( callback-quot yield-quot -- ) +: do-callback ( callback-quot yield-quot: ( -- ) -- ) init-namespaces init-catchstack current-callback diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor old mode 100644 new mode 100755 index 14ed5b9717..8e3af26932 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -22,9 +22,6 @@ architecture get { { "unix-x86.32" "x86/32/unix" } { "winnt-x86.64" "x86/64/winnt" } { "unix-x86.64" "x86/64/unix" } - { "linux-ppc" "ppc/linux" } - { "macosx-ppc" "ppc/macosx" } - { "arm" "arm" } } ?at [ "Bad architecture: " prepend throw ] unless "vocab:cpu/" "/bootstrap.factor" surround parse-file @@ -343,6 +340,8 @@ tuple { "tag" "kernel.private" (( object -- n )) } { "(execute)" "kernel.private" (( word -- )) } { "(call)" "kernel.private" (( quot -- )) } + { "fpu-state" "kernel.private" (( -- )) } + { "set-fpu-state" "kernel.private" (( -- )) } { "unwind-native-frames" "kernel.private" (( -- )) } { "set-callstack" "kernel.private" (( callstack -- * )) } { "lazy-jit-compile" "kernel.private" (( -- )) } @@ -501,7 +500,6 @@ tuple { "float*" "math.private" "primitive_float_multiply" (( x y -- z )) } { "float+" "math.private" "primitive_float_add" (( x y -- z )) } { "float-" "math.private" "primitive_float_subtract" (( x y -- z )) } - { "float-mod" "math.private" "primitive_float_mod" (( x y -- z )) } { "float-u<" "math.private" "primitive_float_less" (( x y -- ? )) } { "float-u<=" "math.private" "primitive_float_lesseq" (( x y -- ? )) } { "float-u>" "math.private" "primitive_float_greater" (( x y -- ? )) } diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index 2c286cb3f6..f913ca5fec 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -17,7 +17,7 @@ ARTICLE: "class-operations" "Class operations" ARTICLE: "class-linearization" "Class linearization" "Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:" { $list - "If a generic word defines a method on a mixin class A and another class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both." + "If a generic word defines a method on a mixin class A and another on class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both." { "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." } } "The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:" diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 1086b9470b..52fa822c10 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -135,6 +135,14 @@ MIXIN: empty-mixin [ f ] [ empty-mixin class-not null class<= ] unit-test [ f ] [ empty-mixin null class<= ] unit-test +[ t ] [ empty-mixin class-not object class<= ] unit-test +[ t ] [ empty-mixin object class<= ] unit-test + +[ t ] [ empty-mixin class-not object class<= ] unit-test +[ t ] [ empty-mixin object class<= ] unit-test + +[ t ] [ object empty-mixin class-not class<= ] unit-test + [ t ] [ array sequence vector class-not class-and class<= ] unit-test [ f ] [ vector sequence vector class-not class-and class<= ] unit-test @@ -156,35 +164,52 @@ MIXIN: empty-mixin [ t ] [ vector array class-not vector class-and* ] unit-test +[ object ] [ object empty-mixin class-not class-and ] unit-test +[ object ] [ empty-mixin class-not object class-and ] unit-test + ! class-or : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; [ t ] [ \ f class-not \ f object class-or* ] unit-test +[ object ] [ object empty-mixin class-not class-or ] unit-test +[ object ] [ empty-mixin class-not object class-or ] unit-test + ! class-not [ vector ] [ vector class-not class-not ] unit-test ! classes-intersect? [ t ] [ both tuple classes-intersect? ] unit-test +[ t ] [ tuple both classes-intersect? ] unit-test [ f ] [ vector virtual-sequence classes-intersect? ] unit-test +[ f ] [ virtual-sequence vector classes-intersect? ] unit-test [ t ] [ number vector class-or sequence classes-intersect? ] unit-test +[ t ] [ sequence number vector class-or classes-intersect? ] unit-test [ f ] [ number vector class-and sequence classes-intersect? ] unit-test +[ f ] [ sequence number vector class-and classes-intersect? ] unit-test [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test +[ f ] [ x1 y1 z1 class-and classes-intersect? ] unit-test [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test +[ f ] [ a1 b1 class-or a1 c1 class-or b1 c1 class-or class-and classes-intersect? ] unit-test [ f ] [ integer integer class-not classes-intersect? ] unit-test +[ f ] [ integer class-not integer classes-intersect? ] unit-test [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test +[ f ] [ array fixnum class-not number class-and classes-intersect? ] unit-test [ t ] [ \ word generic-class classes-intersect? ] unit-test +[ t ] [ generic-class \ word classes-intersect? ] unit-test [ f ] [ number generic-class classes-intersect? ] unit-test +[ f ] [ generic-class number classes-intersect? ] unit-test [ f ] [ sa sb classes-intersect? ] unit-test +[ f ] [ sb sa classes-intersect? ] unit-test [ t ] [ a union-with-one-member classes-intersect? ] unit-test [ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test @@ -202,7 +227,9 @@ MIXIN: empty-mixin [ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test [ t ] [ mixin-with-one-member object classes-intersect? ] unit-test -! class= +[ f ] [ null object classes-intersect? ] unit-test +[ f ] [ object null classes-intersect? ] unit-test + [ t ] [ null class-not object class= ] unit-test [ t ] [ object class-not null class= ] unit-test diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index ae217904b7..0d42c9f5ba 100644 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -15,16 +15,22 @@ TUPLE: anonymous-union { members read-only } ; [ null eq? not ] filter set-members dup length 1 = [ first ] [ anonymous-union boa ] if ; +M: anonymous-union rank-class drop 6 ; + TUPLE: anonymous-intersection { participants read-only } ; : ( participants -- class ) set-members dup length 1 = [ first ] [ anonymous-intersection boa ] if ; +M: anonymous-intersection rank-class drop 4 ; + TUPLE: anonymous-complement { class read-only } ; C: anonymous-complement +M: anonymous-complement rank-class drop 3 ; + DEFER: (class<=) DEFER: (class-not) @@ -41,6 +47,9 @@ GENERIC: normalize-class ( class -- class' ) M: object normalize-class ; +: symmetric-class-op ( first second cache quot -- result ) + [ 2dup [ rank-class ] bi@ > [ swap ] when ] 2dip 2cache ; inline + PRIVATE> GENERIC: classoid? ( obj -- ? ) @@ -67,15 +76,27 @@ M: anonymous-complement classoid? class>> classoid? ; class-not-cache get [ (class-not) ] cache ; : classes-intersect? ( first second -- ? ) - classes-intersect-cache get [ - normalize-class (classes-intersect?) - ] 2cache ; + [ normalize-class ] bi@ + classes-intersect-cache get [ (classes-intersect?) ] symmetric-class-op ; : class-and ( first second -- class ) - class-and-cache get [ (class-and) ] 2cache ; + class-and-cache get [ (class-and) ] symmetric-class-op ; : class-or ( first second -- class ) - class-or-cache get [ (class-or) ] 2cache ; + class-or-cache get [ (class-or) ] symmetric-class-op ; + +SYMBOL: +incomparable+ + +: compare-classes ( first second -- <=> ) + [ swap class<= ] [ class<= ] 2bi + [ +eq+ +lt+ ] [ +gt+ +incomparable+ ] if ? ; + +: evaluate-class-predicate ( class1 class2 -- ? ) + { + { [ 2dup class<= ] [ t ] } + { [ 2dup classes-intersect? not ] [ f ] } + [ +incomparable+ ] + } cond 2nip ; > classoid? ; : left-anonymous-intersection<= ( first second -- ? ) [ participants>> ] dip [ class<= ] curry any? ; +PREDICATE: nontrivial-anonymous-intersection < anonymous-intersection + participants>> empty? not ; + : right-anonymous-intersection<= ( first second -- ? ) participants>> [ class<= ] with all? ; @@ -140,7 +164,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; { [ over empty-union? ] [ 2drop t ] } { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } { [ over anonymous-union? ] [ left-anonymous-union<= ] } - { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] } + { [ over nontrivial-anonymous-intersection? ] [ left-anonymous-intersection<= ] } { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] } { [ dup members ] [ right-union<= ] } { [ dup anonymous-union? ] [ right-anonymous-union<= ] } @@ -167,20 +191,22 @@ M: anonymous-complement (classes-intersect?) participants>> swap suffix ; : (class-and) ( first second -- class ) - { - { [ 2dup class<= ] [ drop ] } - { [ 2dup swap class<= ] [ nip ] } - { [ 2dup classes-intersect? not ] [ 2drop null ] } - [ - [ normalize-class ] bi@ { - { [ dup anonymous-union? ] [ anonymous-union-and ] } - { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] } - { [ over anonymous-union? ] [ swap anonymous-union-and ] } - { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] } - [ 2array ] - } cond - ] - } cond ; + 2dup compare-classes { + { +lt+ [ drop ] } + { +gt+ [ nip ] } + { +eq+ [ nip ] } + { +incomparable+ [ + 2dup classes-intersect? [ + [ normalize-class ] bi@ { + { [ dup anonymous-union? ] [ anonymous-union-and ] } + { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] } + { [ over anonymous-union? ] [ swap anonymous-union-and ] } + { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] } + [ 2array ] + } cond + ] [ 2drop null ] if + ] } + } case ; : anonymous-union-or ( first second -- class ) members>> swap suffix ; @@ -196,13 +222,18 @@ M: anonymous-complement (classes-intersect?) 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ; : (class-or) ( first second -- class ) - { - { [ 2dup class<= ] [ nip ] } - { [ 2dup swap class<= ] [ drop ] } - { [ dup anonymous-complement? ] [ anonymous-complement-or ] } - { [ over anonymous-complement? ] [ swap anonymous-complement-or ] } - [ ((class-or)) ] - } cond ; + 2dup compare-classes { + { +lt+ [ nip ] } + { +gt+ [ drop ] } + { +eq+ [ nip ] } + { +incomparable+ [ + { + { [ dup anonymous-complement? ] [ anonymous-complement-or ] } + { [ over anonymous-complement? ] [ swap anonymous-complement-or ] } + [ ((class-or)) ] + } cond + ] } + } case ; : (class-not) ( class -- complement ) { @@ -237,12 +268,3 @@ ERROR: topological-sort-failed ; : flatten-class ( class -- assoc ) [ (flatten-class) ] H{ } make-assoc ; - -SYMBOL: +incomparable+ - -: compare-classes ( class1 class2 -- ? ) - { - { [ 2dup class<= ] [ t ] } - { [ 2dup classes-intersect? not ] [ f ] } - [ +incomparable+ ] - } cond 2nip ; diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index c324ba7d52..1595816ba2 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -24,12 +24,7 @@ M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ; M: builtin-class (flatten-class) dup set ; -M: builtin-class (classes-intersect?) - { - { [ 2dup eq? ] [ 2drop t ] } - { [ over builtin-class? ] [ 2drop f ] } - [ swap classes-intersect? ] - } cond ; +M: builtin-class (classes-intersect?) eq? ; : full-cover ( -- ) builtins get [ (flatten-class) ] each ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 2b02d7c5a1..2f46d516aa 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -28,16 +28,6 @@ M: method-forget-class method-forget-test ; [ diff ] [ swap diff ] 2bi ] unit-test -! Minor leak -[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval( -- ) ] unit-test -[ ] [ f \ word set-global ] unit-test -[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval( -- ) ] unit-test -[ ] [ "IN: classes.tests FORGET: forget-me" eval( -- ) ] unit-test -[ 0 ] [ - [ word? ] instances - [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count -] unit-test - ! Long-standing problem USE: multiline diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index a3c1d5d607..3f0e581fd3 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -25,7 +25,7 @@ PREDICATE: intersection-class < class M: intersection-class update-class define-intersection-predicate ; -M: intersection-class rank-class drop 2 ; +M: intersection-class rank-class drop 5 ; M: intersection-class instance? "participants" word-prop [ instance? ] with all? ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index fa0a6e8d37..ec5c2ef2e4 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -16,7 +16,7 @@ M: mixin-class (classes-intersect?) M: mixin-class reset-class [ call-next-method ] [ { "mixin" } reset-props ] bi ; -M: mixin-class rank-class drop 3 ; +M: mixin-class rank-class drop 8 ; TUPLE: check-mixin-class class ; diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 25feac7989..f387defcb8 100644 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -35,7 +35,7 @@ PRIVATE> M: predicate-class reset-class [ call-next-method ] [ { "predicate-definition" } reset-props ] bi ; -M: predicate-class rank-class drop 1 ; +M: predicate-class rank-class drop 2 ; M: predicate-class instance? 2dup superclass instance? [ diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 64c34d221a..d67875046e 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -325,7 +325,7 @@ M: tuple-class metaclass-changed ! default superclass nip tuple over "slots" word-prop define-tuple-class ; -M: tuple-class rank-class drop 0 ; +M: tuple-class rank-class drop 1 ; M: tuple-class instance? dup echelon-of layout-class-offset tuple-instance? ; @@ -334,10 +334,8 @@ M: tuple-class (flatten-class) dup set ; M: tuple-class (classes-intersect?) { - { [ over tuple eq? ] [ 2drop t ] } - { [ over builtin-class? ] [ 2drop f ] } + { [ over builtin-class? ] [ drop tuple eq? ] } { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] } - [ swap classes-intersect? ] } cond ; M: tuple clone (clone) ; inline diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 518ba37d7c..d6abe5201f 100644 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -36,7 +36,7 @@ PRIVATE> [ drop update-classes ] 2tri ; -M: union-class rank-class drop 2 ; +M: union-class rank-class drop 7 ; M: union-class instance? "members" word-prop [ instance? ] with any? ; diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 1e7a61daaa..97de07d546 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,5 +1,5 @@ USING: alien strings kernel math tools.test io prettyprint -namespaces combinators words classes sequences accessors +namespaces combinators words classes sequences accessors math.functions arrays combinators.private ; IN: combinators.tests @@ -53,7 +53,7 @@ IN: combinators.tests [ 10 \ . compile-execute(-test-4 ] [ wrong-values? ] must-fail-with -! Compiled +! Cond : cond-test-1 ( obj -- str ) { { [ dup 2 mod 0 = ] [ drop "even" ] } @@ -63,7 +63,9 @@ IN: combinators.tests \ cond-test-1 def>> must-infer [ "even" ] [ 2 cond-test-1 ] unit-test +[ "even" ] [ 2 \ cond-test-1 def>> call ] unit-test [ "odd" ] [ 3 cond-test-1 ] unit-test +[ "odd" ] [ 3 \ cond-test-1 def>> call ] unit-test : cond-test-2 ( obj -- str ) { @@ -75,8 +77,11 @@ IN: combinators.tests \ cond-test-2 def>> must-infer [ "true" ] [ t cond-test-2 ] unit-test +[ "true" ] [ t \ cond-test-2 def>> call ] unit-test [ "false" ] [ f cond-test-2 ] unit-test +[ "false" ] [ f \ cond-test-2 def>> call ] unit-test [ "something else" ] [ "ohio" cond-test-2 ] unit-test +[ "something else" ] [ "ohio" \ cond-test-2 def>> call ] unit-test : cond-test-3 ( obj -- str ) { @@ -88,8 +93,11 @@ IN: combinators.tests \ cond-test-3 def>> must-infer [ "something else" ] [ t cond-test-3 ] unit-test +[ "something else" ] [ t \ cond-test-3 def>> call ] unit-test [ "something else" ] [ f cond-test-3 ] unit-test +[ "something else" ] [ f \ cond-test-3 def>> call ] unit-test [ "something else" ] [ "ohio" cond-test-3 ] unit-test +[ "something else" ] [ "ohio" \ cond-test-3 def>> call ] unit-test : cond-test-4 ( -- ) { @@ -97,87 +105,30 @@ IN: combinators.tests \ cond-test-4 def>> must-infer -[ cond-test-4 ] [ class \ no-cond = ] must-fail-with +[ cond-test-4 ] [ no-cond? ] must-fail-with +[ \ cond-test-4 def>> call ] [ no-cond? ] must-fail-with -! Interpreted -[ "even" ] [ - 2 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond -] unit-test - -[ "odd" ] [ - 3 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond -] unit-test - -[ "neither" ] [ - 3 { - { [ dup string? ] [ drop "string" ] } - { [ dup float? ] [ drop "float" ] } - { [ dup alien? ] [ drop "alien" ] } - [ drop "neither" ] - } cond -] unit-test - -[ "neither" ] [ - 3 { - { [ dup string? ] [ drop "string" ] } - { [ dup float? ] [ drop "float" ] } - { [ dup alien? ] [ drop "alien" ] } - [ drop "neither" ] - } cond -] unit-test - -[ "neither" ] [ - 3 { - { [ dup string? ] [ drop "string" ] } - { [ dup float? ] [ drop "float" ] } - { [ dup alien? ] [ drop "alien" ] } - [ drop "neither" ] - } cond -] unit-test - -[ "early" ] [ - 2 { +: cond-test-5 ( a -- b ) + { { [ dup 2 mod 1 = ] [ drop "odd" ] } [ drop "early" ] { [ dup 2 mod 0 = ] [ drop "even" ] } - } cond -] unit-test + } cond ; -[ "really early" ] [ - 2 { +[ "early" ] [ 2 cond-test-5 ] unit-test +[ "early" ] [ 2 \ cond-test-5 def>> call ] unit-test + +: cond-test-6 ( a -- b ) + { [ drop "really early" ] - { [ dup 2 mod 1 = ] [ drop "odd" ] } - { [ dup 2 mod 0 = ] [ drop "even" ] } - } cond -] unit-test + { [ dup 2 mod 1 = ] [ drop "odd" ] } + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond ; -[ { } cond ] [ class \ no-cond = ] must-fail-with - -[ "early" ] [ - 2 { - { [ dup 2 mod 1 = ] [ drop "odd" ] } - [ drop "early" ] - { [ dup 2 mod 0 = ] [ drop "even" ] } - } cond -] unit-test +[ "really early" ] [ 2 cond-test-6 ] unit-test +[ "really early" ] [ 2 \ cond-test-6 def>> call ] unit-test -[ "really early" ] [ - 2 { - [ drop "really early" ] - { [ dup 2 mod 1 = ] [ drop "odd" ] } - { [ dup 2 mod 0 = ] [ drop "even" ] } - } cond -] unit-test - -[ { } cond ] [ class \ no-cond = ] must-fail-with - -! Compiled +! Case : case-test-1 ( obj -- obj' ) { { 1 [ "one" ] } @@ -189,11 +140,10 @@ IN: combinators.tests \ case-test-1 def>> must-infer [ "two" ] [ 2 case-test-1 ] unit-test - -! Interpreted [ "two" ] [ 2 \ case-test-1 def>> call ] unit-test [ "x" case-test-1 ] must-fail +[ "x" \ case-test-1 def>> call ] must-fail : case-test-2 ( obj -- obj' ) { @@ -207,8 +157,6 @@ IN: combinators.tests \ case-test-2 def>> must-infer [ 25 ] [ 5 case-test-2 ] unit-test - -! Interpreted [ 25 ] [ 5 \ case-test-2 def>> call ] unit-test : case-test-3 ( obj -- obj' ) @@ -225,6 +173,7 @@ IN: combinators.tests \ case-test-3 def>> must-infer [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test +[ "an array" ] [ { 1 2 3 } \ case-test-3 def>> call ] unit-test CONSTANT: case-const-1 1 CONSTANT: case-const-2 2 @@ -234,9 +183,9 @@ CONSTANT: case-const-2 2 { { case-const-1 [ "uno" ] } { case-const-2 [ "dos" ] } - { 3 [ "tres" ] } - { 4 [ "cuatro" ] } - { 5 [ "cinco" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } [ drop "demasiado" ] } case ; @@ -247,64 +196,25 @@ CONSTANT: case-const-2 2 [ "tres" ] [ 3 case-test-4 ] unit-test [ "demasiado" ] [ 100 case-test-4 ] unit-test +[ "uno" ] [ 1 \ case-test-4 def>> call ] unit-test +[ "dos" ] [ 2 \ case-test-4 def>> call ] unit-test +[ "tres" ] [ 3 \ case-test-4 def>> call ] unit-test +[ "demasiado" ] [ 100 \ case-test-4 def>> call ] unit-test + : case-test-5 ( obj -- ) { { case-const-1 [ "uno" print ] } { case-const-2 [ "dos" print ] } - { 3 [ "tres" print ] } - { 4 [ "cuatro" print ] } - { 5 [ "cinco" print ] } + { 3 [ "tres" print ] } + { 4 [ "cuatro" print ] } + { 5 [ "cinco" print ] } [ drop "demasiado" print ] } case ; \ case-test-5 def>> must-infer [ ] [ 1 case-test-5 ] unit-test - -! Interpreted -[ "uno" ] [ - 1 { - { case-const-1 [ "uno" ] } - { case-const-2 [ "dos" ] } - { 3 [ "tres" ] } - { 4 [ "cuatro" ] } - { 5 [ "cinco" ] } - [ drop "demasiado" ] - } case -] unit-test - -[ "dos" ] [ - 2 { - { case-const-1 [ "uno" ] } - { case-const-2 [ "dos" ] } - { 3 [ "tres" ] } - { 4 [ "cuatro" ] } - { 5 [ "cinco" ] } - [ drop "demasiado" ] - } case -] unit-test - -[ "tres" ] [ - 3 { - { case-const-1 [ "uno" ] } - { case-const-2 [ "dos" ] } - { 3 [ "tres" ] } - { 4 [ "cuatro" ] } - { 5 [ "cinco" ] } - [ drop "demasiado" ] - } case -] unit-test - -[ "demasiado" ] [ - 100 { - { case-const-1 [ "uno" ] } - { case-const-2 [ "dos" ] } - { 3 [ "tres" ] } - { 4 [ "cuatro" ] } - { 5 [ "cinco" ] } - [ drop "demasiado" ] - } case -] unit-test +[ ] [ 1 \ case-test-5 def>> call ] unit-test : do-not-call ( -- * ) "do not call" throw ; @@ -319,30 +229,6 @@ CONSTANT: case-const-2 2 [ "three" ] [ 3 test-case-6 ] unit-test [ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test -[ "three" ] [ - 3 { - { \ do-not-call [ "do-not-call" ] } - { 3 [ "three" ] } - } case -] unit-test - -[ "do-not-call" ] [ - [ do-not-call ] first { - { \ do-not-call [ "do-not-call" ] } - { 3 [ "three" ] } - } case -] unit-test - -[ "do-not-call" ] [ - \ do-not-call { - { \ do-not-call [ "do-not-call" ] } - { 3 [ "three" ] } - } case -] unit-test - -! Interpreted -[ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test - [ t ] [ { 1 3 2 } contiguous-range? ] unit-test [ f ] [ { 1 2 2 4 } contiguous-range? ] unit-test [ f ] [ { + 3 2 } contiguous-range? ] unit-test @@ -358,33 +244,79 @@ CONSTANT: case-const-2 2 { \ / [ "divide" ] } { \ ^ [ "power" ] } { \ [ [ "obama" ] } - { \ ] [ "KFC" ] } } case ; \ test-case-7 def>> must-infer [ "plus" ] [ \ + test-case-7 ] unit-test +[ "plus" ] [ \ + \ test-case-7 def>> call ] unit-test -! Some corner cases (no pun intended) DEFER: corner-case-1 << \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >> [ t ] [ \ corner-case-1 optimized? ] unit-test -[ 4 ] [ 2 corner-case-1 ] unit-test -[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test +[ 4 ] [ 2 corner-case-1 ] unit-test +[ 4 ] [ 2 \ corner-case-1 def>> call ] unit-test : test-case-8 ( n -- string ) { { 1 [ "foo" ] } } case ; -[ 3 test-case-8 ] -[ object>> 3 = ] must-fail-with +[ 3 test-case-8 ] [ object>> 3 = ] must-fail-with +[ 3 \ test-case-8 def>> call ] [ object>> 3 = ] must-fail-with -[ - 3 { - { 1 [ "foo" ] } - } case -] [ object>> 3 = ] must-fail-with +: test-case-9 ( a -- b ) + { + { \ + [ "plus" ] } + { \ + [ "plus 2" ] } + { \ - [ "minus" ] } + { \ - [ "minus 2" ] } + } case ; + +[ "plus" ] [ \ + test-case-9 ] unit-test +[ "plus" ] [ \ + \ test-case-9 def>> call ] unit-test + +[ "minus" ] [ \ - test-case-9 ] unit-test +[ "minus" ] [ \ - \ test-case-9 def>> call ] unit-test + +: test-case-10 ( a -- b ) + { + { 1 [ "uno" ] } + { 2 [ "dos" ] } + { 2 [ "DOS" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + } case ; + +[ "dos" ] [ 2 test-case-10 ] unit-test +[ "dos" ] [ 2 \ test-case-10 def>> call ] unit-test + +: test-case-11 ( a -- b ) + { + { 11 [ "uno" ] } + { 22 [ "dos" ] } + { 22 [ "DOS" ] } + { 33 [ "tres" ] } + { 44 [ "cuatro" ] } + { 55 [ "cinco" ] } + } case ; + +[ "dos" ] [ 22 test-case-11 ] unit-test +[ "dos" ] [ 22 \ test-case-11 def>> call ] unit-test + +: test-case-12 ( a -- b ) + { + { 11 [ "uno" ] } + { 22 [ "dos" ] } + [ drop "nachos" ] + { 33 [ "tres" ] } + { 44 [ "cuatro" ] } + { 55 [ "cinco" ] } + } case ; + +[ "nachos" ] [ 33 test-case-12 ] unit-test +[ "nachos" ] [ 33 \ test-case-12 def>> call ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index bbfee30b3d..fc259afbaf 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -169,7 +169,7 @@ ERROR: no-case object ; PRIVATE> : case>quot ( default assoc -- quot ) - dup keys { + dup keys { { [ dup empty? ] [ 2drop ] } { [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] } { [ dup contiguous-range? ] [ drop dispatch-case-quot ] } diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 8775e599a6..dfecf75f90 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -206,8 +206,8 @@ HELP: throw-restarts { $examples "Try invoking one of the two restarts which are offered after the below code throws an error:" { $code - ": restart-test" - " \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition" + ": restart-test ( -- )" + " \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } throw-restarts" " \"You restarted: \" write . ;" "restart-test" } diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor old mode 100644 new mode 100755 index e6d78fa03e..c8b8f81f6a --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2009 Doug Coleman, Slava Pestov. +! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors continuations kernel namespaces make sequences vectors sets assocs init math ; @@ -40,15 +40,17 @@ ERROR: already-disposed disposable ; GENERIC: dispose ( disposable -- ) -M: object dispose - dup disposed>> [ drop ] [ t >>disposed dispose* ] if ; +: unless-disposed ( disposable quot -- ) + [ dup disposed>> [ drop ] ] dip if ; inline + +M: object dispose [ t >>disposed dispose* ] unless-disposed ; M: disposable dispose - dup disposed>> [ drop ] [ + [ [ unregister-disposable ] [ call-next-method ] bi - ] if ; + ] unless-disposed ; : dispose-each ( seq -- ) [ diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor deleted file mode 100644 index 805c3a4be4..0000000000 --- a/core/generic/generic-tests.factor +++ /dev/null @@ -1,227 +0,0 @@ -USING: accessors alien arrays assocs classes classes.algebra -classes.tuple classes.union compiler.units continuations -definitions eval generic generic.math generic.standard -hashtables io io.streams.string kernel layouts math math.order -namespaces parser prettyprint quotations sequences sorting -strings tools.test vectors words generic.single -compiler.crossref ; -IN: generic.tests - -GENERIC: foobar ( x -- y ) -M: object foobar drop "Hello world" ; -M: fixnum foobar drop "Goodbye cruel world" ; - -GENERIC: class-of ( x -- y ) - -M: fixnum class-of drop "fixnum" ; -M: word class-of drop "word" ; - -[ "fixnum" ] [ 5 class-of ] unit-test -[ "word" ] [ \ class-of class-of ] unit-test -[ 3.4 class-of ] must-fail - -[ "Hello world" ] [ 4 foobar foobar ] unit-test -[ "Goodbye cruel world" ] [ 4 foobar ] unit-test - -! Testing unions -UNION: funnies quotation float complex ; - -GENERIC: funny ( x -- y ) -M: funnies funny drop 2 ; -M: object funny drop 0 ; - -[ 2 ] [ [ { } ] funny ] unit-test -[ 0 ] [ { } funny ] unit-test - -PREDICATE: very-funny < funnies number? ; - -GENERIC: gooey ( x -- y ) -M: very-funny gooey sq ; - -[ 0.25 ] [ 0.5 gooey ] unit-test - -GENERIC: empty-method-test ( x -- y ) -M: object empty-method-test ; -TUPLE: for-arguments-sake ; -C: for-arguments-sake - -M: for-arguments-sake empty-method-test drop "Hi" ; - -TUPLE: another-one ; -C: another-one - -[ "Hi" ] [ empty-method-test empty-method-test ] unit-test -[ T{ another-one f } ] [ empty-method-test ] unit-test - -! Weird bug -GENERIC: stack-underflow ( x y -- ) -M: object stack-underflow 2drop ; -M: word stack-underflow 2drop ; - -GENERIC: union-containment ( x -- y ) -M: integer union-containment drop 1 ; -M: number union-containment drop 2 ; - -[ 1 ] [ 1 union-containment ] unit-test -[ 2 ] [ 1.0 union-containment ] unit-test - -! Testing recovery from bad method definitions -"IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) -[ - "IN: generic.tests M: dictionary unhappy ;" eval( -- ) -] must-fail -[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test - -GENERIC# complex-combination 1 ( a b -- c ) -M: string complex-combination drop ; -M: object complex-combination nip ; - -[ "hi" ] [ "hi" 3 complex-combination ] unit-test -[ "hi" ] [ 3 "hi" complex-combination ] unit-test - -TUPLE: shit ; - -M: shit complex-combination 2array ; -[ { T{ shit f } 5 } ] [ T{ shit f } 5 complex-combination ] unit-test - -[ t ] [ \ complex-combination generic? >boolean ] unit-test - -GENERIC: big-generic-test ( x -- x y ) -M: fixnum big-generic-test "fixnum" ; -M: bignum big-generic-test "bignum" ; -M: ratio big-generic-test "ratio" ; -M: string big-generic-test "string" ; -M: shit big-generic-test "shit" ; - -[ T{ shit f } "shit" ] [ T{ shit f } big-generic-test ] unit-test - -[ t ] [ \ + math-generic? ] unit-test - -! Regression -TUPLE: first-one ; -TUPLE: second-one ; -UNION: both first-one union-class ; - -GENERIC: wii ( x -- y ) -M: both wii drop 3 ; -M: second-one wii drop 4 ; -M: tuple-class wii drop 5 ; -M: integer wii drop 6 ; - -[ 3 ] [ T{ first-one } wii ] unit-test - -GENERIC: tag-and-f ( x -- x x ) - -M: fixnum tag-and-f 1 ; - -M: bignum tag-and-f 2 ; - -M: float tag-and-f 3 ; - -M: f tag-and-f 4 ; - -[ f 4 ] [ f tag-and-f ] unit-test - -[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test - -! Issues with forget -GENERIC: generic-forget-test ( a -- b ) - -M: f generic-forget-test ; - -[ ] [ \ f \ generic-forget-test method "m" set ] unit-test - -[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test - -[ ] [ "IN: generic.tests M: f generic-forget-test ;" eval( -- ) ] unit-test - -[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test - -[ f ] [ f generic-forget-test ] unit-test - -! erg's regression -[ ] [ - """IN: compiler.tests - - GENERIC: jeah ( a -- b ) - TUPLE: boii ; - M: boii jeah ; - GENERIC: jeah* ( a -- b ) - M: boii jeah* jeah ;""" eval( -- ) - - """IN: compiler.tests - FORGET: boii""" eval( -- ) - - """IN: compiler.tests - TUPLE: boii ; - M: boii jeah ;""" eval( -- ) -] unit-test - -! call-next-method cache test -GENERIC: c-n-m-cache ( a -- b ) - -! Force it to be unoptimized -M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ; -M: integer c-n-m-cache 1 + ; -M: number c-n-m-cache ; - -[ 3 ] [ 2 c-n-m-cache ] unit-test - -[ ] [ [ M\ integer c-n-m-cache forget ] with-compilation-unit ] unit-test - -[ 2 ] [ 2 c-n-m-cache ] unit-test - -! Moving a method from one vocab to another doesn't always work -GENERIC: move-method-generic ( a -- b ) - -[ ] [ "IN: generic.tests.a USE: strings USE: generic.tests M: string move-method-generic ;" "move-method-test-1" parse-stream drop ] unit-test - -[ ] [ "IN: generic.tests.b USE: strings USE: generic.tests M: string move-method-generic ;" "move-method-test-2" parse-stream drop ] unit-test - -[ ] [ "IN: generic.tests.a" "move-method-test-1" parse-stream drop ] unit-test - -[ { string } ] [ \ move-method-generic order ] unit-test - -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ t ] [ - reversed \ foozul method-for-class - reversed \ foozul method - eq? -] unit-test - -[ t ] [ - fixnum \ <=> method-for-class - real \ <=> method - eq? -] unit-test - -! FORGET: on method wrappers -GENERIC: forget-test ( a -- b ) - -M: integer forget-test 3 + ; - -[ ] [ "IN: generic.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test - -[ { } ] [ - \ + effect-dependencies-of keys [ method? ] filter - [ "method-generic" word-prop \ forget-test eq? ] filter -] unit-test - -[ 10 forget-test ] [ no-method? ] must-fail-with - -! Declarations on methods -GENERIC: flushable-generic ( a -- b ) flushable -M: integer flushable-generic ; - -[ t ] [ \ flushable-generic flushable? ] unit-test -[ t ] [ M\ integer flushable-generic flushable? ] unit-test - -GENERIC: non-flushable-generic ( a -- b ) -M: integer non-flushable-generic ; flushable - -[ f ] [ \ non-flushable-generic flushable? ] unit-test -[ t ] [ M\ integer non-flushable-generic flushable? ] unit-test diff --git a/core/generic/hook/hook-tests.factor b/core/generic/hook/hook-tests.factor new file mode 100644 index 0000000000..8be8355cd4 --- /dev/null +++ b/core/generic/hook/hook-tests.factor @@ -0,0 +1,36 @@ +USING: arrays generic generic.single growable kernel math +namespaces sequences strings tools.test vectors words ; +IN: generic.hook.tests + +SYMBOL: my-var +HOOK: my-hook my-var ( -- x ) + +M: integer my-hook "an integer" ; +M: string my-hook "a string" ; + +[ "an integer" ] [ 3 my-var set my-hook ] unit-test +[ "a string" ] [ my-hook my-var set my-hook ] unit-test +[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with + +HOOK: call-next-hooker my-var ( -- x ) + +M: sequence call-next-hooker "sequence" ; + +M: array call-next-hooker call-next-method "array " prepend ; + +M: vector call-next-hooker call-next-method "vector " prepend ; + +M: growable call-next-hooker call-next-method "growable " prepend ; + +[ "vector growable sequence" ] [ + V{ } my-var [ call-next-hooker ] with-variable +] unit-test + +[ t ] [ + { } \ nth effective-method nip M\ sequence nth eq? +] unit-test + +[ t ] [ + \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and +] unit-test + diff --git a/core/generic/math/math-tests.factor b/core/generic/math/math-tests.factor index 2279fd019c..34f09f87d7 100644 --- a/core/generic/math/math-tests.factor +++ b/core/generic/math/math-tests.factor @@ -18,4 +18,4 @@ IN: generic.math.tests [ number ] [ fixnum number math-class-max ] unit-test [ number ] [ number fixnum math-class-max ] unit-test - +[ t ] [ \ + math-generic? ] unit-test diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor deleted file mode 100644 index 6be03042cb..0000000000 --- a/core/generic/single/single-tests.factor +++ /dev/null @@ -1,288 +0,0 @@ -USING: tools.test math math.functions math.constants -generic.standard generic.single strings sequences arrays kernel -accessors words byte-arrays bit-arrays parser namespaces make -quotations stack-checker vectors growable hashtables sbufs -prettyprint byte-vectors bit-vectors specialized-vectors -definitions generic sets graphs assocs grouping see eval ; -QUALIFIED-WITH: alien.c-types c -FROM: namespaces => set ; -SPECIALIZED-VECTOR: c:double -IN: generic.single.tests - -GENERIC: lo-tag-test ( obj -- obj' ) - -M: integer lo-tag-test 3 + ; - -M: float lo-tag-test 4 - ; - -M: rational lo-tag-test 2 - ; - -M: complex lo-tag-test sq ; - -[ 8 ] [ 5 >bignum lo-tag-test ] unit-test -[ 0.0 ] [ 4.0 lo-tag-test ] unit-test -[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test -[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test - -GENERIC: hi-tag-test ( obj -- obj' ) - -M: string hi-tag-test ", in bed" append ; - -M: integer hi-tag-test 3 + ; - -M: array hi-tag-test [ hi-tag-test ] map ; - -M: sequence hi-tag-test reverse ; - -[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test - -[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test - -[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test - -TUPLE: shape ; - -TUPLE: abstract-rectangle < shape width height ; - -TUPLE: rectangle < abstract-rectangle ; - -C: rectangle - -TUPLE: parallelogram < abstract-rectangle skew ; - -C: parallelogram - -TUPLE: circle < shape radius ; - -C: circle - -GENERIC: area ( shape -- n ) - -M: abstract-rectangle area [ width>> ] [ height>> ] bi * ; - -M: circle area radius>> sq pi * ; - -[ 12 ] [ 4 3 area ] unit-test -[ 12 ] [ 4 3 2 area ] unit-test -[ t ] [ 2 area 4 pi * = ] unit-test - -GENERIC: perimiter ( shape -- n ) - -: rectangle-perimiter ( l w -- n ) + 2 * ; - -M: rectangle perimiter - [ width>> ] [ height>> ] bi - rectangle-perimiter ; - -: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ; - -M: parallelogram perimiter - [ width>> ] - [ [ height>> ] [ skew>> ] bi hypotenuse ] bi - rectangle-perimiter ; - -M: circle perimiter 2 * pi * ; - -[ 14 ] [ 4 3 perimiter ] unit-test -[ 30.0 ] [ 10 4 3 perimiter ] unit-test - -GENERIC: big-mix-test ( obj -- obj' ) - -M: object big-mix-test drop "object" ; - -M: tuple big-mix-test drop "tuple" ; - -M: integer big-mix-test drop "integer" ; - -M: float big-mix-test drop "float" ; - -M: complex big-mix-test drop "complex" ; - -M: string big-mix-test drop "string" ; - -M: array big-mix-test drop "array" ; - -M: sequence big-mix-test drop "sequence" ; - -M: rectangle big-mix-test drop "rectangle" ; - -M: parallelogram big-mix-test drop "parallelogram" ; - -M: circle big-mix-test drop "circle" ; - -[ "integer" ] [ 3 big-mix-test ] unit-test -[ "float" ] [ 5.0 big-mix-test ] unit-test -[ "complex" ] [ -1 sqrt big-mix-test ] unit-test -[ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test -[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test -[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test -[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test -[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test -[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test -[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test -[ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test -[ "string" ] [ "hello" big-mix-test ] unit-test -[ "rectangle" ] [ 1 2 big-mix-test ] unit-test -[ "parallelogram" ] [ 10 4 3 big-mix-test ] unit-test -[ "circle" ] [ 100 big-mix-test ] unit-test -[ "tuple" ] [ H{ } big-mix-test ] unit-test -[ "object" ] [ \ + big-mix-test ] unit-test - -GENERIC: small-lo-tag ( obj -- obj ) - -M: fixnum small-lo-tag drop "fixnum" ; - -M: string small-lo-tag drop "string" ; - -M: array small-lo-tag drop "array" ; - -M: double-array small-lo-tag drop "double-array" ; - -M: byte-array small-lo-tag drop "byte-array" ; - -[ "fixnum" ] [ 3 small-lo-tag ] unit-test - -[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test - -! Testing next-method -TUPLE: person ; - -TUPLE: intern < person ; - -TUPLE: employee < person ; - -TUPLE: tape-monkey < employee ; - -TUPLE: manager < employee ; - -TUPLE: junior-manager < manager ; - -TUPLE: middle-manager < manager ; - -TUPLE: senior-manager < manager ; - -TUPLE: executive < senior-manager ; - -TUPLE: ceo < executive ; - -GENERIC: salary ( person -- n ) - -M: intern salary - #! Intentional mistake. - call-next-method ; - -M: employee salary drop 24000 ; - -M: manager salary call-next-method 12000 + ; - -M: middle-manager salary call-next-method 5000 + ; - -M: senior-manager salary call-next-method 15000 + ; - -M: executive salary call-next-method 2 * ; - -M: ceo salary - #! Intentional error. - drop 5 call-next-method 3 * ; - -[ salary ] must-infer - -[ 24000 ] [ employee boa salary ] unit-test - -[ 24000 ] [ tape-monkey boa salary ] unit-test - -[ 36000 ] [ junior-manager boa salary ] unit-test - -[ 41000 ] [ middle-manager boa salary ] unit-test - -[ 51000 ] [ senior-manager boa salary ] unit-test - -[ 102000 ] [ executive boa salary ] unit-test - -[ ceo boa salary ] -[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with - -[ intern boa salary ] -[ no-next-method? ] must-fail-with - -! Weird shit -TUPLE: a ; -TUPLE: b ; -TUPLE: c ; - -UNION: x a b ; -UNION: y a c ; - -UNION: z x y ; - -GENERIC: funky* ( obj -- ) - -M: z funky* "z" , drop ; - -M: x funky* "x" , call-next-method ; - -M: y funky* "y" , call-next-method ; - -M: a funky* "a" , call-next-method ; - -M: b funky* "b" , call-next-method ; - -M: c funky* "c" , call-next-method ; - -: funky ( obj -- seq ) [ funky* ] { } make ; - -[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test - -[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test - -[ t ] [ - T{ a } funky - { { "a" "x" "z" } { "a" "y" "z" } } member? -] unit-test - -! Hooks -SYMBOL: my-var -HOOK: my-hook my-var ( -- x ) - -M: integer my-hook "an integer" ; -M: string my-hook "a string" ; - -[ "an integer" ] [ 3 my-var set my-hook ] unit-test -[ "a string" ] [ my-hook my-var set my-hook ] unit-test -[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with - -HOOK: call-next-hooker my-var ( -- x ) - -M: sequence call-next-hooker "sequence" ; - -M: array call-next-hooker call-next-method "array " prepend ; - -M: vector call-next-hooker call-next-method "vector " prepend ; - -M: growable call-next-hooker call-next-method "growable " prepend ; - -[ "vector growable sequence" ] [ - V{ } my-var [ call-next-hooker ] with-variable -] unit-test - -[ t ] [ - { } \ nth effective-method nip M\ sequence nth eq? -] unit-test - -[ t ] [ - \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and -] unit-test - -[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test -[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test - -[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test -[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test - -! Corner case -[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ] -[ error>> bad-dispatch-position? ] -must-fail-with - -[ ] [ "IN: generic.single.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test - [ "IN: generic.single.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index b39956c731..219c52b75e 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -104,8 +104,23 @@ TUPLE: tuple-dispatch-engine echelons ; #! is always there H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ; +: copy-superclass-methods ( engine superclass assoc -- ) + at* [ [ methods>> ] bi@ assoc-union! drop ] [ 2drop ] if ; + +: copy-superclasses-methods ( class engine assoc -- ) + [ superclasses ] 2dip + [ swapd copy-superclass-methods ] 2curry each ; + +: convert-tuple-inheritance ( assoc -- assoc' ) + #! A method on a superclass A might have a higher precedence + #! than a method on a subclass B, if the methods are + #! defined on incomparable classes that happen to contain + #! A and B, respectively. Copy A's methods into B's set so + #! that they can be sorted and selected properly. + dup dup [ copy-superclasses-methods ] curry assoc-each ; + : ( methods -- engine ) - echelon-sort + convert-tuple-inheritance echelon-sort [ dupd ] assoc-map \ tuple-dispatch-engine boa ; diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor new file mode 100644 index 0000000000..f69cd2a823 --- /dev/null +++ b/core/generic/standard/standard-tests.factor @@ -0,0 +1,569 @@ +USING: tools.test math math.functions math.constants +generic.standard generic.single strings sequences arrays kernel +accessors words byte-arrays bit-arrays parser namespaces make +quotations stack-checker vectors growable hashtables sbufs +prettyprint byte-vectors bit-vectors specialized-vectors +definitions generic sets graphs assocs grouping see eval +classes.union classes.tuple compiler.units io.streams.string +compiler.crossref math.order ; +QUALIFIED-WITH: alien.c-types c +FROM: namespaces => set ; +SPECIALIZED-VECTOR: c:double +IN: generic.standard.tests + +GENERIC: class-of ( x -- y ) + +M: fixnum class-of drop "fixnum" ; +M: word class-of drop "word" ; + +[ "fixnum" ] [ 5 class-of ] unit-test +[ "word" ] [ \ class-of class-of ] unit-test +[ 3.4 class-of ] must-fail + +GENERIC: foobar ( x -- y ) +M: object foobar drop "Hello world" ; +M: fixnum foobar drop "Goodbye cruel world" ; + +[ "Hello world" ] [ 4 foobar foobar ] unit-test +[ "Goodbye cruel world" ] [ 4 foobar ] unit-test + +GENERIC: lo-tag-test ( obj -- obj' ) + +M: integer lo-tag-test 3 + ; +M: float lo-tag-test 4 - ; +M: rational lo-tag-test 2 - ; +M: complex lo-tag-test sq ; + +[ 8 ] [ 5 >bignum lo-tag-test ] unit-test +[ 0.0 ] [ 4.0 lo-tag-test ] unit-test +[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test +[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test + +GENERIC: hi-tag-test ( obj -- obj' ) + +M: string hi-tag-test ", in bed" append ; +M: integer hi-tag-test 3 + ; +M: array hi-tag-test [ hi-tag-test ] map ; +M: sequence hi-tag-test reverse ; + +[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test + +[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test + +[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test + +UNION: funnies quotation float complex ; + +GENERIC: funny ( x -- y ) +M: funnies funny drop 2 ; +M: object funny drop 0 ; + +GENERIC: union-containment ( x -- y ) +M: integer union-containment drop 1 ; +M: number union-containment drop 2 ; + +[ 1 ] [ 1 union-containment ] unit-test +[ 2 ] [ 1.0 union-containment ] unit-test + +[ 2 ] [ [ { } ] funny ] unit-test +[ 0 ] [ { } funny ] unit-test + +TUPLE: shape ; + +TUPLE: abstract-rectangle < shape width height ; + +TUPLE: rectangle < abstract-rectangle ; + +C: rectangle + +TUPLE: parallelogram < abstract-rectangle skew ; + +C: parallelogram + +TUPLE: circle < shape radius ; + +C: circle + +GENERIC: area ( shape -- n ) + +M: abstract-rectangle area [ width>> ] [ height>> ] bi * ; + +M: circle area radius>> sq pi * ; + +[ 12 ] [ 4 3 area ] unit-test +[ 12 ] [ 4 3 2 area ] unit-test +[ t ] [ 2 area 4 pi * = ] unit-test + +GENERIC: perimiter ( shape -- n ) + +: rectangle-perimiter ( l w -- n ) + 2 * ; + +M: rectangle perimiter + [ width>> ] [ height>> ] bi + rectangle-perimiter ; + +: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ; + +M: parallelogram perimiter + [ width>> ] + [ [ height>> ] [ skew>> ] bi hypotenuse ] bi + rectangle-perimiter ; + +M: circle perimiter 2 * pi * ; + +[ 14 ] [ 4 3 perimiter ] unit-test +[ 30.0 ] [ 10 4 3 perimiter ] unit-test + +PREDICATE: very-funny < funnies number? ; + +GENERIC: gooey ( x -- y ) +M: very-funny gooey sq ; + +[ 0.25 ] [ 0.5 gooey ] unit-test + +GENERIC: empty-method-test ( x -- y ) +M: object empty-method-test ; +TUPLE: for-arguments-sake ; +C: for-arguments-sake + +M: for-arguments-sake empty-method-test drop "Hi" ; + +TUPLE: another-one ; +C: another-one + +[ "Hi" ] [ empty-method-test empty-method-test ] unit-test +[ T{ another-one f } ] [ empty-method-test ] unit-test + +GENERIC: big-mix-test ( obj -- obj' ) + +M: object big-mix-test drop "object" ; + +M: tuple big-mix-test drop "tuple" ; + +M: integer big-mix-test drop "integer" ; + +M: float big-mix-test drop "float" ; + +M: complex big-mix-test drop "complex" ; + +M: string big-mix-test drop "string" ; + +M: array big-mix-test drop "array" ; + +M: sequence big-mix-test drop "sequence" ; + +M: rectangle big-mix-test drop "rectangle" ; + +M: parallelogram big-mix-test drop "parallelogram" ; + +M: circle big-mix-test drop "circle" ; + +[ "integer" ] [ 3 big-mix-test ] unit-test +[ "float" ] [ 5.0 big-mix-test ] unit-test +[ "complex" ] [ -1 sqrt big-mix-test ] unit-test +[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test +[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test +[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test +[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test +[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test +[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test +[ "string" ] [ "hello" big-mix-test ] unit-test +[ "rectangle" ] [ 1 2 big-mix-test ] unit-test +[ "parallelogram" ] [ 10 4 3 big-mix-test ] unit-test +[ "circle" ] [ 100 big-mix-test ] unit-test +[ "tuple" ] [ H{ } big-mix-test ] unit-test +[ "object" ] [ \ + big-mix-test ] unit-test + +GENERIC: small-lo-tag ( obj -- obj ) + +M: fixnum small-lo-tag drop "fixnum" ; + +M: string small-lo-tag drop "string" ; + +M: array small-lo-tag drop "array" ; + +M: double-array small-lo-tag drop "double-array" ; + +M: byte-array small-lo-tag drop "byte-array" ; + +[ "fixnum" ] [ 3 small-lo-tag ] unit-test + +[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test + +! Testing recovery from bad method definitions +"IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- ) +[ + "IN: generic.standard.tests M: dictionary unhappy ;" eval( -- ) +] must-fail +[ ] [ "IN: generic.standard.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test + +GENERIC# complex-combination 1 ( a b -- c ) +M: string complex-combination drop ; +M: object complex-combination nip ; + +[ "hi" ] [ "hi" 3 complex-combination ] unit-test +[ "hi" ] [ 3 "hi" complex-combination ] unit-test + +! Regression +TUPLE: first-one ; +TUPLE: second-one ; +UNION: both first-one union-class ; + +GENERIC: wii ( x -- y ) +M: both wii drop 3 ; +M: second-one wii drop 4 ; +M: tuple-class wii drop 5 ; +M: integer wii drop 6 ; + +[ 3 ] [ T{ first-one } wii ] unit-test + +GENERIC: tag-and-f ( x -- x x ) + +M: fixnum tag-and-f 1 ; + +M: bignum tag-and-f 2 ; + +M: float tag-and-f 3 ; + +M: f tag-and-f 4 ; + +[ f 4 ] [ f tag-and-f ] unit-test + +[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test + +! Issues with forget +GENERIC: generic-forget-test ( a -- b ) + +M: f generic-forget-test ; + +[ ] [ \ f \ generic-forget-test method "m" set ] unit-test + +[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test + +[ ] [ "IN: generic.standard.tests M: f generic-forget-test ;" eval( -- ) ] unit-test + +[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test + +[ f ] [ f generic-forget-test ] unit-test + +! erg's regression +[ ] [ + """IN: generic.standard.tests + + GENERIC: jeah ( a -- b ) + TUPLE: boii ; + M: boii jeah ; + GENERIC: jeah* ( a -- b ) + M: boii jeah* jeah ;""" eval( -- ) + + """IN: generic.standard.tests + FORGET: boii""" eval( -- ) + + """IN: generic.standard.tests + TUPLE: boii ; + M: boii jeah ;""" eval( -- ) +] unit-test + +! Testing next-method +TUPLE: person ; + +TUPLE: intern < person ; + +TUPLE: employee < person ; + +TUPLE: tape-monkey < employee ; + +TUPLE: manager < employee ; + +TUPLE: junior-manager < manager ; + +TUPLE: middle-manager < manager ; + +TUPLE: senior-manager < manager ; + +TUPLE: executive < senior-manager ; + +TUPLE: ceo < executive ; + +GENERIC: salary ( person -- n ) + +M: intern salary + #! Intentional mistake. + call-next-method ; + +M: employee salary drop 24000 ; + +M: manager salary call-next-method 12000 + ; + +M: middle-manager salary call-next-method 5000 + ; + +M: senior-manager salary call-next-method 15000 + ; + +M: executive salary call-next-method 2 * ; + +M: ceo salary + #! Intentional error. + drop 5 call-next-method 3 * ; + +[ salary ] must-infer + +[ 24000 ] [ employee boa salary ] unit-test + +[ 24000 ] [ tape-monkey boa salary ] unit-test + +[ 36000 ] [ junior-manager boa salary ] unit-test + +[ 41000 ] [ middle-manager boa salary ] unit-test + +[ 51000 ] [ senior-manager boa salary ] unit-test + +[ 102000 ] [ executive boa salary ] unit-test + +[ ceo boa salary ] +[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with + +[ intern boa salary ] +[ no-next-method? ] must-fail-with + +! Weird shit +TUPLE: a ; +TUPLE: b ; +TUPLE: c ; + +UNION: x a b ; +UNION: y a c ; + +UNION: z x y ; + +GENERIC: funky* ( obj -- ) + +M: z funky* "z" , drop ; + +M: x funky* "x" , call-next-method ; + +M: y funky* "y" , call-next-method ; + +M: a funky* "a" , call-next-method ; + +M: b funky* "b" , call-next-method ; + +M: c funky* "c" , call-next-method ; + +: funky ( obj -- seq ) [ funky* ] { } make ; + +[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test + +[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test + +[ t ] [ + T{ a } funky + { { "a" "x" "z" } { "a" "y" "z" } } member? +] unit-test + +! Changing method combination should not fail +[ ] [ "IN: generic.standard.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test +[ ] [ "IN: generic.standard.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test + +[ f ] [ "xyz" "generic.standard.tests" lookup pic-def>> ] unit-test +[ f ] [ "xyz" "generic.standard.tests" lookup "decision-tree" word-prop ] unit-test + +! Corner case +[ "IN: generic.standard.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ] +[ error>> bad-dispatch-position? ] +must-fail-with + +! Generic words cannot be inlined +[ ] [ "IN: generic.standard.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test +[ "IN: generic.standard.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail + +! Moving a method from one vocab to another didn't always work +GENERIC: move-method-generic ( a -- b ) + +[ ] [ "IN: generic.standard.tests.a USE: strings USE: generic.standard.tests M: string move-method-generic ;" "move-method-test-1" parse-stream drop ] unit-test + +[ ] [ "IN: generic.standard.tests.b USE: strings USE: generic.standard.tests M: string move-method-generic ;" "move-method-test-2" parse-stream drop ] unit-test + +[ ] [ "IN: generic.standard.tests.a" "move-method-test-1" parse-stream drop ] unit-test + +[ { string } ] [ \ move-method-generic order ] unit-test + +! FORGET: on method wrappers +GENERIC: forget-test ( a -- b ) + +M: integer forget-test 3 + ; + +[ ] [ "IN: generic.standard.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test + +[ { } ] [ + \ + effect-dependencies-of keys [ method? ] filter + [ "method-generic" word-prop \ forget-test eq? ] filter +] unit-test + +[ 10 forget-test ] [ no-method? ] must-fail-with + +! Declarations on methods +GENERIC: flushable-generic ( a -- b ) flushable +M: integer flushable-generic ; + +[ t ] [ \ flushable-generic flushable? ] unit-test +[ t ] [ M\ integer flushable-generic flushable? ] unit-test + +GENERIC: non-flushable-generic ( a -- b ) +M: integer non-flushable-generic ; flushable + +[ f ] [ \ non-flushable-generic flushable? ] unit-test +[ t ] [ M\ integer non-flushable-generic flushable? ] unit-test + +! method-for-object, method-for-class, effective-method +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ ] [ reversed \ foozul method-for-class M\ reversed foozul assert= ] unit-test +[ ] [ { 1 2 3 } \ foozul method-for-object M\ reversed foozul assert= ] unit-test +[ ] [ { 1 2 3 } \ foozul effective-method M\ reversed foozul assert= drop ] unit-test + +[ ] [ fixnum \ foozul method-for-class M\ integer foozul assert= ] unit-test +[ ] [ 13 \ foozul method-for-object M\ integer foozul assert= ] unit-test +[ ] [ 13 \ foozul effective-method M\ integer foozul assert= drop ] unit-test + +! Ensure dynamic and static dispatch match in ambiguous cases +UNION: amb-union-1a integer float ; +UNION: amb-union-1b float string ; + +GENERIC: amb-generic-1 ( a -- b ) + +M: amb-union-1a amb-generic-1 drop "a" ; +M: amb-union-1b amb-generic-1 drop "b" ; + +[ ] [ + 5.0 amb-generic-1 + 5.0 \ amb-generic-1 effective-method execute( a -- b ) assert= +] unit-test + +[ ] [ + 5.0 amb-generic-1 + 5.0 float \ amb-generic-1 method-for-class execute( a -- b ) assert= +] unit-test + +UNION: amb-union-2a float string ; +UNION: amb-union-2b integer float ; + +GENERIC: amb-generic-2 ( a -- b ) + +M: amb-union-2a amb-generic-2 drop "a" ; +M: amb-union-2b amb-generic-2 drop "b" ; + +[ ] [ + 5.0 amb-generic-1 + 5.0 \ amb-generic-1 effective-method execute( a -- b ) assert= +] unit-test + +[ ] [ + 5.0 amb-generic-1 + 5.0 float \ amb-generic-1 method-for-class execute( a -- b ) assert= +] unit-test + +TUPLE: amb-tuple-a x ; +TUPLE: amb-tuple-b < amb-tuple-a ; +PREDICATE: amb-tuple-c < amb-tuple-a x>> 3 = ; + +GENERIC: amb-generic-3 ( a -- b ) + +M: amb-tuple-b amb-generic-3 drop "b" ; +M: amb-tuple-c amb-generic-3 drop "c" ; + +[ ] [ + T{ amb-tuple-b f 3 } amb-generic-3 + T{ amb-tuple-b f 3 } \ amb-generic-3 effective-method execute( a -- b ) assert= +] unit-test + +TUPLE: amb-tuple-d ; +UNION: amb-union-4 amb-tuple-a amb-tuple-d ; + +GENERIC: amb-generic-4 ( a -- b ) + +M: amb-tuple-b amb-generic-4 drop "b" ; +M: amb-union-4 amb-generic-4 drop "4" ; + +[ ] [ + T{ amb-tuple-b f 3 } amb-generic-4 + T{ amb-tuple-b f 3 } \ amb-generic-4 effective-method execute( a -- b ) assert= +] unit-test + +[ ] [ + T{ amb-tuple-b f 3 } amb-generic-4 + T{ amb-tuple-b f 3 } amb-tuple-b \ amb-generic-4 method-for-class execute( a -- b ) assert= +] unit-test + +MIXIN: amb-mixin-5 +INSTANCE: amb-tuple-a amb-mixin-5 +INSTANCE: amb-tuple-d amb-mixin-5 + +GENERIC: amb-generic-5 ( a -- b ) + +M: amb-tuple-b amb-generic-5 drop "b" ; +M: amb-mixin-5 amb-generic-5 drop "5" ; + +[ ] [ + T{ amb-tuple-b f 3 } amb-generic-5 + T{ amb-tuple-b f 3 } \ amb-generic-5 effective-method execute( a -- b ) assert= +] unit-test + +[ ] [ + T{ amb-tuple-b f 3 } amb-generic-5 + T{ amb-tuple-b f 3 } amb-tuple-b \ amb-generic-5 method-for-class execute( a -- b ) assert= +] unit-test + +UNION: amb-union-6 amb-tuple-b amb-tuple-d ; + +GENERIC: amb-generic-6 ( a -- b ) + +M: amb-tuple-a amb-generic-6 drop "a" ; +M: amb-union-6 amb-generic-6 drop "6" ; + +[ ] [ + T{ amb-tuple-b f 3 } amb-generic-6 + T{ amb-tuple-b f 3 } \ amb-generic-6 effective-method execute( a -- b ) assert= +] unit-test + +[ ] [ + T{ amb-tuple-b f 3 } amb-generic-6 + T{ amb-tuple-b f 3 } amb-tuple-b \ amb-generic-6 method-for-class execute( a -- b ) assert= +] unit-test + +MIXIN: amb-mixin-7 +INSTANCE: amb-tuple-b amb-mixin-7 +INSTANCE: amb-tuple-d amb-mixin-7 + +GENERIC: amb-generic-7 ( a -- b ) + +M: amb-tuple-a amb-generic-7 drop "a" ; +M: amb-mixin-7 amb-generic-7 drop "7" ; + +[ ] [ + T{ amb-tuple-b f 3 } amb-generic-7 + T{ amb-tuple-b f 3 } \ amb-generic-7 effective-method execute( a -- b ) assert= +] unit-test + +[ ] [ + T{ amb-tuple-b f 3 } amb-generic-7 + T{ amb-tuple-b f 3 } amb-tuple-b \ amb-generic-7 method-for-class execute( a -- b ) assert= +] unit-test + +! Same thing as above but with predicate classes +PREDICATE: amb-predicate-a < integer 10 mod even? ; +PREDICATE: amb-predicate-b < amb-predicate-a 10 mod 4 = ; + +UNION: amb-union-8 amb-predicate-b string ; + +GENERIC: amb-generic-8 ( a -- b ) + +M: amb-union-8 amb-generic-8 drop "8" ; +M: amb-predicate-a amb-generic-8 drop "a" ; + +[ ] [ + 4 amb-generic-8 + 4 \ amb-generic-8 effective-method execute( a -- b ) assert= +] unit-test diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index efebe7bd25..7f6c7e9876 100644 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -8,19 +8,17 @@ IN: io.encodings.utf8.tests : encode-utf8-w/stream ( array -- newarray ) >string utf8 encode >array ; -[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test - -[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11110,101 BIN: 10,111111 BIN: 10,000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test [ "x" ] [ "x" decode-utf8-w/stream >string ] unit-test -[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8-w/stream >array ] unit-test +[ { BIN: 11111000000 } ] [ { BIN: 110,11111 BIN: 10,000000 } decode-utf8-w/stream >array ] unit-test [ { CHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8-w/stream ] unit-test -[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8-w/stream >array ] unit-test +[ { BIN: 1111000000111111 } ] [ { BIN: 1110,1111 BIN: 10,000000 BIN: 10,111111 } decode-utf8-w/stream >array ] unit-test -[ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] +[ { BIN: 11110,101 BIN: 10,111111 BIN: 10,000000 BIN: 10,111111 BIN: 1110,1111 BIN: 10,000000 BIN: 10,111111 BIN: 110,11111 BIN: 10,000000 CHAR: x } ] [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8-w/stream ] unit-test [ 3 ] [ 1 "日本語" >utf8-index ] unit-test @@ -29,3 +27,17 @@ IN: io.encodings.utf8.tests [ 3 ] [ 2 "lápis" >utf8-index ] unit-test [ V{ } ] [ 100000 iota [ [ code-point-length ] [ 1string utf8 encode length ] bi = not ] filter ] unit-test + +[ { CHAR: replacement-character } ] [ { BIN: 110,00000 BIN: 10,000000 } decode-utf8-w/stream ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 110,00001 BIN: 10,111111 } decode-utf8-w/stream ] unit-test +[ { HEX: 80 } ] [ { BIN: 110,00010 BIN: 10,000000 } decode-utf8-w/stream ] unit-test + +[ { CHAR: replacement-character } ] [ { BIN: 1110,0000 BIN: 10,000000 BIN: 10,000000 } decode-utf8-w/stream ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 1110,0000 BIN: 10,011111 BIN: 10,111111 } decode-utf8-w/stream ] unit-test +[ { HEX: 800 } ] [ { BIN: 1110,0000 BIN: 10,100000 BIN: 10,000000 } decode-utf8-w/stream ] unit-test + +[ { CHAR: replacement-character } ] [ { BIN: 11110,000 BIN: 10,000000 BIN: 10,000000 BIN: 10,000000 } decode-utf8-w/stream ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11110,000 BIN: 10,001111 BIN: 10,111111 BIN: 10,111111 } decode-utf8-w/stream ] unit-test +[ { CHAR: replacement-character } ] [ { BIN: 11110,100 BIN: 10,010000 BIN: 10,000000 BIN: 10,000000 } decode-utf8-w/stream ] unit-test +[ { HEX: 10000 } ] [ { BIN: 11110,000 BIN: 10,010000 BIN: 10,000000 BIN: 10,000000 } decode-utf8-w/stream ] unit-test +[ { HEX: 10FFFF } ] [ { BIN: 11110,100 BIN: 10,001111 BIN: 10,111111 BIN: 10,111111 } decode-utf8-w/stream ] unit-test diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index c78a86c072..09e3dd5f4b 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -19,14 +19,24 @@ SINGLETON: utf8 [ swap 6 shift swap BIN: 111111 bitand bitor ] [ 2drop replacement-char ] if ; inline +: minimum-code-point ( char minimum -- char ) + over > [ drop replacement-char ] when ; inline + +: maximum-code-point ( char maximum -- char ) + over < [ drop replacement-char ] when ; inline + : double ( stream byte -- stream char ) - BIN: 11111 bitand append-nums ; inline + BIN: 11111 bitand append-nums + HEX: 80 minimum-code-point ; inline : triple ( stream byte -- stream char ) - BIN: 1111 bitand append-nums append-nums ; inline + BIN: 1111 bitand append-nums append-nums + HEX: 800 minimum-code-point ; inline : quadruple ( stream byte -- stream char ) - BIN: 111 bitand append-nums append-nums append-nums ; inline + BIN: 111 bitand append-nums append-nums append-nums + HEX: 10000 minimum-code-point + HEX: 10FFFF maximum-code-point ; inline : begin-utf8 ( stream byte -- stream char ) { diff --git a/core/io/io.factor b/core/io/io.factor index e074135e8c..ea37c13dd7 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators continuations destructors kernel math namespaces sequences ; @@ -26,20 +26,6 @@ SINGLETONS: seek-absolute seek-relative seek-end ; GENERIC: stream-tell ( stream -- n ) GENERIC: stream-seek ( n seek-type stream -- ) -> length + ] [ i<< ] bi ] } - [ bad-seek-type ] - } case ; - -PRIVATE> - : stream-print ( str stream -- ) [ stream-write ] [ stream-nl ] bi ; ! Default streams @@ -76,12 +62,13 @@ SYMBOL: error-stream [ with-output-stream* ] curry with-disposal ; inline : with-streams* ( input output quot -- ) - [ output-stream set input-stream set ] prepose with-scope ; inline + swapd [ with-output-stream* ] curry with-input-stream* ; inline : with-streams ( input output quot -- ) - [ [ with-streams* ] 3curry ] - [ [ drop dispose dispose ] 3curry ] 3bi - [ ] cleanup ; inline + #! We have to dispose of the output stream first, so that + #! if both streams point to the same FD, we get to flush the + #! buffer before closing the FD. + swapd [ with-output-stream ] curry with-input-stream ; inline : print ( str -- ) output-stream get stream-print ; diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index b307128efb..6285fd716a 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -76,6 +76,8 @@ ERROR: no-parent-directory path ; [ f ] } cond ; +PRIVATE> + : absolute-path? ( path -- ? ) { { [ dup empty? ] [ f ] } @@ -85,7 +87,9 @@ ERROR: no-parent-directory path ; [ f ] } cond nip ; -PRIVATE> +: append-relative-path ( path1 path2 -- path ) + [ trim-tail-separators ] + [ trim-head-separators ] bi* "/" glue ; : append-path ( path1 path2 -- path ) { @@ -101,10 +105,7 @@ PRIVATE> { [ over absolute-path? over first path-separator? and ] [ [ 2 head ] dip append ] } - [ - [ trim-tail-separators ] - [ trim-head-separators ] bi* "/" glue - ] + [ append-relative-path ] } cond ; : prepend-path ( path1 path2 -- path ) diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor index 9772de6262..1c7826719c 100644 --- a/core/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -11,7 +11,7 @@ IN: io.streams.byte-array.tests [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test -[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 stream-contents dup >array swap string? ] unit-test +[ { BIN: 1111111000000111111 } t ] [ { BIN: 11110001 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 stream-contents dup >array swap string? ] unit-test [ B{ 121 120 } 0 ] [ B{ 0 121 120 0 0 0 0 0 0 } binary diff --git a/core/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor index 5ecbc321ce..22882d6a24 100644 --- a/core/io/streams/sequence/sequence.factor +++ b/core/io/streams/sequence/sequence.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: sequences io io.streams.plain kernel accessors math math.order -growable destructors ; +growable destructors combinators ; IN: io.streams.sequence ! Readers @@ -46,3 +46,12 @@ M: growable stream-write push-all ; M: growable stream-flush drop ; INSTANCE: growable plain-writer + +! Seeking +: (stream-seek) ( n seek-type stream -- ) + swap { + { seek-absolute [ i<< ] } + { seek-relative [ [ + ] change-i drop ] } + { seek-end [ [ underlying>> length + ] [ i<< ] bi ] } + [ bad-seek-type ] + } case ; diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index 9fdf95ff3a..7f0667bf74 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -42,11 +42,6 @@ HELP: float* ( x y -- z ) { $description "Primitive version of " { $link * } "." } { $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link * } " instead." } ; -HELP: float-mod ( x y -- z ) -{ $values { "x" float } { "y" float } { "z" float } } -{ $description "Primitive version of " { $link mod } "." } -{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link mod } " instead." } ; - HELP: float/f ( x y -- z ) { $values { "x" float } { "y" float } { "z" float } } { $description "Primitive version of " { $link /f } "." } diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 97c6f7fc87..45fce36ee6 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -38,7 +38,6 @@ M: float * float* ; inline M: float / float/f ; inline M: float /f float/f ; inline M: float /i float/f >integer ; inline -M: float mod float-mod ; inline M: real abs dup 0 < [ neg ] when ; inline diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 55938f5888..ed0f4b16b0 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1746,7 +1746,7 @@ $nl { $subsections "sequences-if" } "For inner loops:" { $subsections "sequences-unsafe" } -"Implemeting sequence combinators:" +"Implementing sequence combinators:" { $subsections "sequences-combinator-implementation" } ; ABOUT: "sequences" diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index 1fcf40aa20..1334954b6b 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -7,7 +7,7 @@ IN: slots ARTICLE: "accessors" "Slot accessors" "For every tuple slot, a " { $emphasis "reader" } " method is defined in the " { $vocab-link "accessors" } " vocabulary. The reader is named " { $snippet { $emphasis "slot" } ">>" } " and given a tuple, pushes the slot value on the stack." $nl -"Writable slots - that is, those not attributed " { $link read-only } " - also have a " { $emphasis "writer" } ". The writer is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } ". If the slot is specialized to a specific class, the writer checks that the value being written into the slot is an instance of that class first. See " { $link "tuple-declarations" } " for details." +"Writable slots—that is, those not attributed " { $link read-only } "—also have a " { $emphasis "writer" } ". The writer is named " { $snippet { $emphasis "slot" } "<<" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } ". If the slot is specialized to a specific class, the writer checks that the value being written into the slot is an instance of that class first. See " { $link "tuple-declarations" } " for details." $nl "In addition, two utility words are defined for each writable slot." $nl diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index f103c377b9..b76d06063d 100644 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math threads io io.sockets io.encodings.ascii io.streams.duplex debugger tools.time @@ -7,13 +7,14 @@ namespaces arrays continuations destructors ; IN: benchmark.sockets SYMBOL: counter -SYMBOL: port-promise +SYMBOL: server-promise SYMBOL: server +SYMBOL: port CONSTANT: number-of-requests 1000 : server-addr ( -- addr ) - "127.0.0.1" port-promise get ?promise ; + "127.0.0.1" port get ; : server-loop ( server -- ) dup accept drop [ @@ -28,13 +29,8 @@ CONSTANT: number-of-requests 1000 ] curry "Client handler" spawn drop server-loop ; : simple-server ( -- ) - [ - "127.0.0.1" 0 ascii - [ server set ] - [ addr>> port>> port-promise get fulfill ] - [ [ server-loop ] with-disposal ] - tri - ] ignore-errors ; + [ server get [ server-loop ] with-disposal ] ignore-errors + t server-promise get fulfill ; : simple-client ( -- ) [ @@ -53,14 +49,17 @@ CONSTANT: number-of-requests 1000 : clients ( n -- ) dup pprint " clients: " write [ - port-promise set + server-promise set dup counter set + "127.0.0.1" 0 ascii + [ server set ] [ addr>> port>> port set ] bi + [ simple-server ] "Simple server" spawn drop - yield yield - [ [ simple-client ] "Simple client" spawn drop ] times + [ yield [ simple-client ] "Simple client" spawn drop ] times + counter get await stop-server - yield yield + server-promise get ?promise drop ] benchmark . flush ; : socket-benchmarks ( -- ) diff --git a/extra/bitcoin/client/authors.txt b/extra/bitcoin/client/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/bitcoin/client/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/bitcoin/client/client-docs.factor b/extra/bitcoin/client/client-docs.factor new file mode 100644 index 0000000000..f5136b66dc --- /dev/null +++ b/extra/bitcoin/client/client-docs.factor @@ -0,0 +1,271 @@ +! Copyright (C) 2010 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: bitcoin.client + +HELP: bitcoin-server +{ $values + { "string" "a string" } +} +{ $description + "Returns the hostname of the json-rpc server for the bitcoin client. " + "This defaults to 'localhost' or the value of the 'bitcoin-server' " + "variable." +} +{ $see-also bitcoin-port bitcoin-user bitcoin-password } ; + +HELP: bitcoin-port +{ $values + { "n" "a number" } +} +{ $description + "Returns the port of the json-rpc server for the bitcoin client. " + "This defaults to '8332' or the value of the 'bitcoin-port' " + "variable." +} +{ $see-also bitcoin-server bitcoin-user bitcoin-password } ; + +HELP: bitcoin-user +{ $values + { "string" "a string" } +} +{ $description + "Returns the username required to authenticate with the json-rpc " + "server for the bitcoin client. This defaults to empty or the " + "value of the 'bitcoin-user' variable." +} +{ $see-also bitcoin-port bitcoin-server bitcoin-password } ; + +HELP: bitcoin-password +{ $values + { "string" "a string" } +} +{ $description + "Returns the password required to authenticate with the json-rpc " + "server for the bitcoin client. This returns the " + "value of the 'bitcoin-password' variable." +} +{ $see-also bitcoin-port bitcoin-server bitcoin-user } ; + +HELP: get-addresses-by-label +{ $values + { "label" "a string" } + { "seq" "a sequence" } +} +{ $description + "Returns the list of addresses with the given label." +} ; + +HELP: get-balance +{ $values + { "n" "a number" } +} +{ $description + "Returns the server's available balance." +} ; + +HELP: get-block-count +{ $values + { "n" "a number" } +} +{ $description + "Returns the number of blocks in the longest block chain." +} ; + +HELP: get-block-number +{ $values + { "n" "a number" } +} +{ $description + "Returns the block number of the latest block in the longest block chain." +} ; + +HELP: get-connection-count +{ $values + { "n" "a number" } +} +{ $description + "Returns the number of connections to other nodes." +} ; + +HELP: get-difficulty +{ $values + { "n" "a number" } +} +{ $description + "Returns the proof-of-work difficulty as a multiple of the minimum " + "difficulty." +} ; + +HELP: get-generate +{ $values + { "?" "a boolean" } +} +{ $description + "Returns true if the server is trying to generate bitcoins, false " + "otherwise." +} ; + +HELP: set-generate +{ $values + { "gen" "a boolean" } + { "n" "a number" } +} +{ $description + "If 'gen' is true, the server starts generating bitcoins. If 'gen' is " + "'false' then the server stops generating bitcoins. 'n' is the number " + "of CPU's to use while generating. A value of '-1' means use all the " + "CPU's available." +} ; + +HELP: get-info +{ $values + { "result" "an assoc" } +} +{ $description + "Returns an assoc containing server information." +} ; + +HELP: get-label +{ $values + { "address" "a string" } + { "label" "a string" } +} +{ $description + "Returns the label associated with the given address." +} ; + +HELP: set-label +{ $values + { "address" "a string" } + { "label" "a string" } +} +{ $description + "Sets the label associateed with the given address." +} ; + +HELP: remove-label +{ $values + { "address" "a string" } +} +{ $description + "Removes the label associated with the given address." +} ; + +HELP: get-new-address +{ $values + { "address" "a string" } +} +{ $description + "Returns a new bitcoin address for receiving payments." +} ; + +HELP: get-new-labelled-address +{ $values + { "label" "a string" } + { "address" "a string" } +} +{ $description + "Returns a new bitcoin address for receiving payments. The given " + "label is associated with the new address." +} ; + +HELP: get-received-by-address +{ $values + { "address" "a string" } + { "amount" "a number" } +} +{ $description + "Returns the total amount received by the address in transactions " + "with at least one confirmation." +} ; + +HELP: get-confirmed-received-by-address +{ $values + { "address" "a string" } + { "minconf" "a number" } + { "amount" "a number" } +} +{ $description + "Returns the total amount received by the address in transactions " + "with at least 'minconf' confirmations." +} ; + +HELP: get-received-by-label +{ $values + { "label" "a string" } + { "amount" "a number" } +} +{ $description + "Returns the total amount received by addresses with 'label' in transactions " + "with at least one confirmation." +} ; + +HELP: get-confirmed-received-by-label +{ $values + { "label" "a string" } + { "minconf" "a number" } + { "amount" "a number" } +} +{ $description + "Returns the total amount received by the addresses with 'label' in transactions " + "with at least 'minconf' confirmations." +} ; + +HELP: list-received-by-address +{ $values + { "minconf" "a number" } + { "include-empty" "a boolean" } + { "seq" "a sequence" } +} +{ $description + "Return a sequence containing an assoc of data about the payments an " + "address has received. 'include-empty' indicates whether addresses that " + "haven't received any payments should be included. 'minconf' is the " + "minimum number of confirmations before payments are included." +} ; + +HELP: list-received-by-label +{ $values + { "minconf" "a number" } + { "include-empty" "a boolean" } + { "seq" "a sequence" } +} +{ $description + "Return a sequence containing an assoc of data about the payments that " + "addresses with the given label have received. 'include-empty' " + " indicates whether addresses that " + "haven't received any payments should be included. 'minconf' is the " + "minimum number of confirmations before payments are included." +} ; + +HELP: send-to-address +{ $values + { "address" "a string" } + { "amount" "a number" } + { "?" "a boolean" } +} +{ $description + "Sends 'amount' from the server's available balance to 'address'. " + "'amount' is rounded to the nearest 0.01. Returns a boolean indicating " + "if the call succeeded." +} ; + +HELP: stop +{ $description + "Stops the bitcoin server." +} ; + +HELP: list-transactions +{ $values + { "count" "a number" } + { "include-generated" "a boolean" } + { "seq" "a sequence" } +} +{ $description + "Return's a sequence containing up to 'count' most recent transactions." + "This requires a patched bitcoin server so may not work with old or unpatched " + "servers." +} ; + + diff --git a/extra/bitcoin/client/client.factor b/extra/bitcoin/client/client.factor new file mode 100644 index 0000000000..b3413d6b3e --- /dev/null +++ b/extra/bitcoin/client/client.factor @@ -0,0 +1,140 @@ +! Copyright (C) 2010 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +! +! bitcoin API documentation at: +! http://www.bitcoin.org/wiki/doku.php?id=api +! +! Donations can be sent to the following bitcoin address: +! 1HVMkUcaPhCeCK3rrBm31EY2bf5r33VHsj +! +USING: + accessors + assocs + base64 + byte-arrays + hashtables + http + http.client + io.encodings.binary + json.reader + json.writer + kernel + locals + namespaces + sequences + strings + urls +; +IN: bitcoin.client + +: bitcoin-server ( -- string ) + \ bitcoin-server get "localhost" or ; + +: bitcoin-port ( -- n ) + \ bitcoin-port get 8332 or ; + +: bitcoin-user ( -- string ) + \ bitcoin-user get "" or ; + +: bitcoin-password ( -- string ) + \ bitcoin-password get ; + + + "http" >>protocol + "/" >>path + bitcoin-server >>host + bitcoin-port >>port ; + +:: payload ( method params -- data ) + "text/plain" + binary >>content-encoding + H{ + { "method" method } + { "params" params } + } clone >json >byte-array >>data ; + +: basic-auth ( -- string ) + bitcoin-user bitcoin-password ":" glue >base64 >string + "Basic " prepend ; + +: bitcoin-request ( method params -- request ) + payload bitcoin-url + basic-auth "Authorization" set-header + dup post-data>> data>> length "Content-Length" set-header + http-request nip >string json> "result" swap at ; + +PRIVATE> + +:: get-addresses-by-label ( label -- seq ) + "getaddressesbylabel" { label } bitcoin-request ; + +: get-balance ( -- n ) + "getbalance" { } bitcoin-request ; + +: get-block-count ( -- n ) + "getblockcount" { } bitcoin-request ; + +: get-block-number ( -- n ) + "getblocknumber" { } bitcoin-request ; + +: get-connection-count ( -- n ) + "getconnectioncount" { } bitcoin-request ; + +: get-difficulty ( -- n ) + "getdifficulty" { } bitcoin-request ; + +: get-generate ( -- ? ) + "getgenerate" { } bitcoin-request ; + +:: set-generate ( gen n -- ) + "setgenerate" { gen n } bitcoin-request drop ; + +: get-info ( -- result ) + "getinfo" { } bitcoin-request ; + +:: get-label ( address -- label ) + "getlabel" { address } bitcoin-request ; + +:: set-label ( address label -- ) + "setlabel" { address label } bitcoin-request drop ; + +:: remove-label ( address -- ) + "setlabel" { address } bitcoin-request drop ; + +: get-new-address ( -- address ) + "getnewaddress" { } bitcoin-request ; + +:: get-new-labelled-address ( label -- address ) + "getnewaddress" { label } bitcoin-request ; + +:: get-received-by-address ( address -- amount ) + "getreceivedbyaddress" { address } bitcoin-request ; + +:: get-confirmed-received-by-address ( address minconf -- amount ) + "getreceivedbyaddress" { address minconf } bitcoin-request ; + +:: get-received-by-label ( label -- amount ) + "getreceivedbylabel" { label } bitcoin-request ; + +:: get-confirmed-received-by-label ( label minconf -- amount ) + "getreceivedbylabel" { label minconf } bitcoin-request ; + +:: list-received-by-address ( minconf include-empty -- seq ) + "listreceivedbyaddress" { minconf include-empty } bitcoin-request ; + +:: list-received-by-label ( minconf include-empty -- seq ) + "listreceivedbylabel" { minconf include-empty } bitcoin-request ; + +:: send-to-address ( address amount -- ? ) + "sendtoaddress" { address amount } bitcoin-request "sent" = ; + +: stop ( -- ) + "stop" { } bitcoin-request drop ; + +#! requires patched bitcoind +:: list-transactions ( count include-generated -- seq ) + "listtransactions" { count include-generated } bitcoin-request ; + diff --git a/extra/bitcoin/client/summary.txt b/extra/bitcoin/client/summary.txt new file mode 100644 index 0000000000..6b6c533607 --- /dev/null +++ b/extra/bitcoin/client/summary.txt @@ -0,0 +1 @@ +Client for getting information from a bitcoin server diff --git a/extra/bitcoin/client/tags.txt b/extra/bitcoin/client/tags.txt new file mode 100644 index 0000000000..53c6fea826 --- /dev/null +++ b/extra/bitcoin/client/tags.txt @@ -0,0 +1,2 @@ +client +bitcoin diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index f1f3ab8508..4eb19a33dd 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -15,6 +15,8 @@ SYMBOL: state DEFER: stream>assoc +ERROR: unknown-bson-type type msg ; + object ] } - { T_Binary_Function [ read ] } - [ drop read >string ] + { T_Binary_Function [ read-sized-string ] } + { T_Binary_MD5 [ read >string ] } + { T_Binary_UUID [ read >string ] } + [ "unknown binary sub-type" unknown-bson-type ] } case ; inline TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp ) @@ -90,6 +94,7 @@ TYPED: element-data-read ( type: integer -- object ) { T_Code [ read-int32 read-sized-string ] } { T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc ] } { T_NULL [ f ] } + [ "type unknown" unknown-bson-type ] } case ; inline recursive TYPED: (read-object) ( type: integer name: string -- ) diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index e02b2c6da2..abc4c0f2d2 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -44,7 +44,7 @@ TYPED: write-int32 ( int: integer -- ) INT32-SIZE (>le) ; inline TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline TYPED: write-utf8-string ( string: string -- ) - output-stream get utf8 stream-write ; inline + get-output utf8 encode-string ; inline TYPED: write-cstring ( string: string -- ) write-utf8-string 0 write1 ; inline diff --git a/extra/chipmunk/demo/demo.factor b/extra/chipmunk/demo/demo.factor index 7d11b116fb..f27d40cc53 100644 --- a/extra/chipmunk/demo/demo.factor +++ b/extra/chipmunk/demo/demo.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2010 Erik Charlebois ! See http:// factorcode.org/license.txt for BSD license. -USING: accessors alien chipmunk.ffi classes.struct game.loop -game.worlds kernel literals locals math method-chains opengl.gl -random sequences specialized-arrays ui ui.gadgets.worlds -ui.pixel-formats ; +USING: accessors alien alien.c-types chipmunk.ffi classes.struct +game.loop game.worlds kernel literals locals math method-chains +opengl.gl random sequences specialized-arrays ui +ui.gadgets.worlds ui.pixel-formats ; SPECIALIZED-ARRAY: void* IN: chipmunk.demo diff --git a/extra/codebook/codebook.factor b/extra/codebook/codebook.factor index 2803169ba8..5056e8453e 100644 --- a/extra/codebook/codebook.factor +++ b/extra/codebook/codebook.factor @@ -1,11 +1,11 @@ ! (c)2010 Joe Groff bsd license USING: accessors arrays assocs calendar calendar.format combinators combinators.short-circuit fry io io.backend -io.directories io.encodings.binary io.encodings.detect -io.encodings.utf8 io.files io.files.info io.files.types -io.files.unique io.launcher io.pathnames kernel locals math -math.parser namespaces sequences sorting strings system -unicode.categories xml.syntax xml.writer xmode.catalog +io.directories io.directories.hierarchy io.encodings.binary +io.encodings.detect io.encodings.utf8 io.files io.files.info +io.files.types io.files.unique io.launcher io.pathnames kernel +locals math math.parser namespaces sequences sorting strings +system unicode.categories xml.syntax xml.writer xmode.catalog xmode.marker xmode.tokens ; IN: codebook diff --git a/basis/cpu/arm/assembler/assembler-tests.factor b/extra/cpu/arm/assembler/assembler-tests.factor similarity index 100% rename from basis/cpu/arm/assembler/assembler-tests.factor rename to extra/cpu/arm/assembler/assembler-tests.factor diff --git a/basis/cpu/arm/assembler/assembler.factor b/extra/cpu/arm/assembler/assembler.factor similarity index 100% rename from basis/cpu/arm/assembler/assembler.factor rename to extra/cpu/arm/assembler/assembler.factor diff --git a/basis/cpu/ppc/assembler/authors.txt b/extra/cpu/arm/assembler/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from basis/cpu/ppc/assembler/authors.txt rename to extra/cpu/arm/assembler/authors.txt diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/extra/cpu/ppc/assembler/assembler-tests.factor similarity index 100% rename from basis/cpu/ppc/assembler/assembler-tests.factor rename to extra/cpu/ppc/assembler/assembler-tests.factor diff --git a/basis/cpu/ppc/assembler/assembler.factor b/extra/cpu/ppc/assembler/assembler.factor similarity index 100% rename from basis/cpu/ppc/assembler/assembler.factor rename to extra/cpu/ppc/assembler/assembler.factor diff --git a/basis/cpu/ppc/authors.txt b/extra/cpu/ppc/assembler/authors.txt similarity index 100% rename from basis/cpu/ppc/authors.txt rename to extra/cpu/ppc/assembler/authors.txt diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/extra/cpu/ppc/assembler/backend/backend.factor similarity index 100% rename from basis/cpu/ppc/assembler/backend/backend.factor rename to extra/cpu/ppc/assembler/backend/backend.factor diff --git a/basis/cpu/ppc/assembler/summary.txt b/extra/cpu/ppc/assembler/summary.txt similarity index 100% rename from basis/cpu/ppc/assembler/summary.txt rename to extra/cpu/ppc/assembler/summary.txt diff --git a/extra/fuel/remote/remote.factor b/extra/fuel/remote/remote.factor index 97ab5b59db..a8007bd858 100644 --- a/extra/fuel/remote/remote.factor +++ b/extra/fuel/remote/remote.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Jose Antonio Ortega Ruiz. +! Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz. ! See http://factorcode.org/license.txt for BSD license. USING: accessors debugger io io.encodings.utf8 io.servers.connection kernel listener math namespaces ; @@ -8,7 +8,7 @@ IN: fuel.remote @@ -24,7 +24,7 @@ IN: fuel.remote PRIVATE> : fuel-start-remote-listener ( port/f -- ) - print-banner integer? [ 9000 ] unless* server start-server ; + print-banner integer? [ 9000 ] unless* server start-server drop ; : fuel-start-remote-listener* ( -- ) f fuel-start-remote-listener ; diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor index ddb5f8b17d..1bdcece936 100644 --- a/extra/game/loop/loop.factor +++ b/extra/game/loop/loop.factor @@ -3,7 +3,7 @@ USING: accessors timers alien.c-types calendar classes.struct continuations destructors fry kernel math math.order memory namespaces sequences specialized-vectors system tools.memory ui ui.gadgets.worlds vm vocabs.loader arrays -benchmark.struct locals ; +tools.time.struct locals ; IN: game.loop TUPLE: game-loop diff --git a/extra/gdbm/ffi/ffi.factor b/extra/gdbm/ffi/ffi.factor old mode 100644 new mode 100755 index e7b02ed2aa..300740c4d9 --- a/extra/gdbm/ffi/ffi.factor +++ b/extra/gdbm/ffi/ffi.factor @@ -7,7 +7,7 @@ IN: gdbm.ffi << "libgdbm" { { [ os macosx? ] [ "libgdbm.dylib" ] } { [ os unix? ] [ "libgdbm.so" ] } - { [ os winnt? ] [ "gdbm.dll" ] } + { [ os winnt? ] [ "gdbm3.dll" ] } } cond cdecl add-library >> LIBRARY: libgdbm diff --git a/extra/geo-ip/geo-ip.factor b/extra/geo-ip/geo-ip.factor index 9dedb6410b..e9e0902e48 100644 --- a/extra/geo-ip/geo-ip.factor +++ b/extra/geo-ip/geo-ip.factor @@ -9,7 +9,7 @@ IN: geo-ip : db-path ( -- path ) "IpToCountry.csv" temp-file ; -CONSTANT: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" +CONSTANT: db-url "http://software77.net/geo-ip/?DL=1" : download-db ( -- path ) db-path dup exists? [ diff --git a/extra/gpu/shaders/shaders-docs.factor b/extra/gpu/shaders/shaders-docs.factor index 54822c2fbb..3ed53c27af 100644 --- a/extra/gpu/shaders/shaders-docs.factor +++ b/extra/gpu/shaders/shaders-docs.factor @@ -39,7 +39,7 @@ HELP: GLSL-SHADER-FILE: { $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from " { $snippet "filename" } " in the current Factor source file's directory." } ; HELP: GLSL-SHADER: -{ $syntax """GLSL-SHADER-FILE: shader-name shader-kind +{ $syntax """GLSL-SHADER: shader-name shader-kind shader source diff --git a/extra/html/parser/analyzer/analyzer-tests.factor b/extra/html/parser/analyzer/analyzer-tests.factor new file mode 100644 index 0000000000..4d2378c7ea --- /dev/null +++ b/extra/html/parser/analyzer/analyzer-tests.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2010 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: html.parser.analyzer math tools.test ; +IN: html.parser.analyzer.tests + +[ 0 3 ] +[ 1 { 3 5 7 9 11 } [ odd? ] find-nth ] unit-test + +[ 2 7 ] +[ 3 { 3 5 7 9 11 } [ odd? ] find-nth ] unit-test + +[ 3 9 ] +[ 3 1 { 3 5 7 9 11 } [ odd? ] find-nth-from ] unit-test + +[ 4 11 ] +[ 1 { 3 5 7 9 11 } [ odd? ] find-last-nth ] unit-test + +[ 2 7 ] +[ 3 { 3 5 7 9 11 } [ odd? ] find-last-nth ] unit-test + +[ 0 3 ] +[ 1 2 { 3 5 7 9 11 } [ odd? ] find-last-nth-from ] unit-test + + +[ 0 { 3 5 7 9 11 } [ odd? ] find-nth ] +[ undefined-find-nth? ] must-fail-with + +[ 0 { 3 5 7 9 11 } [ odd? ] find-last-nth ] +[ undefined-find-nth? ] must-fail-with diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 760fd1e47b..c67a03cbfc 100644 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,23 +1,52 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs html.parser kernel math sequences strings ascii -arrays generalizations shuffle namespaces make -splitting http accessors io combinators http.client urls -urls.encoding fry prettyprint sets combinators.short-circuit ; +USING: accessors assocs combinators combinators.short-circuit +fry html.parser http.client io kernel locals math sequences +sets splitting unicode.case unicode.categories urls +urls.encoding shuffle ; IN: html.parser.analyzer -TUPLE: link attributes clickable ; - : scrape-html ( url -- headers vector ) http-get parse-html ; +: attribute ( tag string -- obj/f ) + swap attributes>> [ at ] [ drop f ] if* ; + +: attribute* ( tag string -- obj ? ) + swap attributes>> [ at* ] [ drop f f ] if* ; + +: attribute? ( tag string -- obj ) + swap attributes>> [ key? ] [ drop f ] if* ; + : find-all ( seq quot -- alist ) [ >alist ] [ '[ second @ ] ] bi* filter ; inline -: find-nth ( seq quot n -- i elt ) - [ >alist ] 2dip -rot - '[ _ [ second @ ] find-from rot drop swap 1 + ] - [ f 0 ] 2dip times drop first2 ; inline +: loopn-index ( n quot -- ) + [ iota ] [ '[ @ not ] ] bi* find 2drop ; inline + +: loopn ( n quot -- ) + [ drop ] prepose loopn-index ; inline + +ERROR: undefined-find-nth m n seq quot ; + +: check-trivial-find ( m n seq quot -- m n seq quot ) + pick 0 = [ undefined-find-nth ] when ; inline + +: find-nth-from ( m n seq quot -- i/f elt/f ) + check-trivial-find [ f ] 3dip '[ + drop _ _ find-from [ dup [ 1 + ] when ] dip over + ] loopn [ dup [ 1 - ] when ] dip ; inline + +: find-nth ( n seq quot -- i/f elt/f ) + [ 0 ] 3dip find-nth-from ; inline + +: find-last-nth-from ( m n seq quot -- i/f elt/f ) + check-trivial-find [ f ] 3dip '[ + drop _ _ find-last-from [ dup [ 1 - ] when ] dip over + ] loopn [ dup [ 1 + ] when ] dip ; inline + +: find-last-nth ( n seq quot -- i/f elt/f ) + [ [ nip length 1 - ] [ ] 2bi ] dip find-last-nth-from ; inline : find-first-name ( vector string -- i/f tag/f ) >lower '[ name>> _ = ] find ; inline @@ -29,8 +58,8 @@ TUPLE: link attributes clickable ; : find-between* ( vector i/f tag/f -- vector ) over integer? [ [ tail-slice ] [ name>> ] bi* - dupd find-matching-close drop dup [ 1 + ] when - [ head ] [ first ] if* + dupd find-matching-close drop [ 1 + ] [ 1 ] if* + head ] [ 3drop V{ } clone ] if ; inline @@ -61,27 +90,31 @@ TUPLE: link attributes clickable ; ] map ; : find-by-id ( vector id -- vector' elt/f ) - '[ attributes>> "id" swap at _ = ] find ; + '[ "id" attribute _ = ] find ; : find-by-class ( vector id -- vector' elt/f ) - '[ attributes>> "class" swap at _ = ] find ; + '[ "class" attribute _ = ] find ; : find-by-name ( vector string -- vector elt/f ) >lower '[ name>> _ = ] find ; : find-by-id-between ( vector string -- vector' ) dupd - '[ attributes>> "id" swap at _ = ] find find-between* ; + '[ "id" attribute _ = ] find find-between* ; : find-by-class-between ( vector string -- vector' ) dupd - '[ attributes>> "class" swap at _ = ] find find-between* ; + '[ "class" attribute _ = ] find find-between* ; : find-by-class-id-between ( vector class id -- vector' ) - '[ - [ attributes>> "class" swap at _ = ] - [ attributes>> "id" swap at _ = ] bi and - ] dupd find find-between* ; + [ + '[ + [ "class" attribute _ = ] + [ "id" attribute _ = ] bi and + ] find + ] [ + 2drop find-between* + ] 3bi ; : find-by-attribute-key ( vector key -- vector' elt/? ) >lower @@ -89,59 +122,44 @@ TUPLE: link attributes clickable ; : find-by-attribute-key-value ( vector value key -- vector' ) >lower - [ attributes>> at over = ] with filter nip - sift ; + [ attributes>> at over = ] with filter nip sift ; : find-first-attribute-key-value ( vector value key -- i/f tag/f ) >lower [ attributes>> at over = ] with find rot drop ; -: tag-link ( tag -- link/f ) - attributes>> [ "href" swap at ] [ f ] if* ; +: tag-link ( tag -- link/f ) "href" attribute ; : find-links ( vector -- vector' ) - [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ] + [ { [ name>> "a" = ] [ "href" attribute ] } 1&& ] find-between-all ; : find-images ( vector -- vector' ) [ { [ name>> "img" = ] - [ attributes>> "src" swap at ] + [ "src" attribute ] } 1&& ] find-all - values [ attributes>> "src" swap at ] map ; - -: ( vector -- link ) - [ first attributes>> ] - [ [ name>> { text "img" } member? ] filter ] bi - link boa ; - -: link. ( vector -- ) - [ attributes>> "href" swap at write nl ] - [ clickable>> [ bl bl text>> print ] each nl ] bi ; + values [ "src" attribute ] map ; : find-by-text ( seq quot -- tag ) [ dup name>> text = ] prepose find drop ; inline : find-opening-tags-by-name ( name seq -- seq ) - [ [ name>> = ] [ closing?>> not ] bi and ] with find-all ; + [ { [ name>> = ] [ closing?>> not ] } 1&& ] with find-all ; : href-contains? ( str tag -- ? ) - attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ; + "href" attribute* [ subseq? ] [ 2drop f ] if ; : find-hrefs ( vector -- vector' ) find-links - [ [ - [ name>> "a" = ] - [ attributes>> "href" swap key? ] bi and ] filter - ] map sift - [ [ attributes>> "href" swap at ] map ] map concat - [ >url ] map ; + [ [ { [ name>> "a" = ] [ "href" attribute? ] } 1&& ] filter ] map sift + [ [ "href" attribute ] map ] map concat [ >url ] map ; : find-frame-links ( vector -- vector' ) [ name>> "frame" = ] find-between-all - [ [ attributes>> "src" swap at ] map sift ] map concat sift + [ [ "src" attribute ] map sift ] map concat sift [ >url ] map ; : find-all-links ( vector -- vector' ) @@ -157,11 +175,10 @@ TUPLE: link attributes clickable ; [ first2 find-between* ] curry map ; : form-action ( vector -- string ) - [ name>> "form" = ] find nip - attributes>> "action" swap at ; + [ name>> "form" = ] find nip "action" attribute ; : hidden-form-values ( vector -- strings ) - [ attributes>> "type" swap at "hidden" = ] filter ; + [ "type" attribute "hidden" = ] filter ; : input. ( tag -- ) dup name>> print @@ -173,7 +190,7 @@ TUPLE: link attributes clickable ; [ { { [ dup name>> "form" = ] - [ "form action: " write attributes>> "action" swap at print ] } + [ "form action: " write "action" attribute print ] } { [ dup name>> "input" = ] [ input. ] } [ drop ] } cond @@ -183,10 +200,21 @@ TUPLE: link attributes clickable ; "?" split1 nip query>assoc ; : html-class? ( tag string -- ? ) - swap attributes>> "class" swap at = ; + swap "class" attribute = ; : html-id? ( tag string -- ? ) - swap attributes>> "id" swap at = ; + swap "id" attribute = ; : opening-tag? ( tag -- ? ) closing?>> not ; + +TUPLE: link attributes clickable ; + +: ( vector -- link ) + [ first attributes>> ] + [ [ name>> { text "img" } member? ] filter ] bi + link boa ; + +: link. ( vector -- ) + [ "href" attribute write nl ] + [ clickable>> [ bl bl text>> print ] each nl ] bi ; diff --git a/extra/images/testing/testing.factor b/extra/images/testing/testing.factor index a6644ed710..4dd271aeef 100644 --- a/extra/images/testing/testing.factor +++ b/extra/images/testing/testing.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Keith Lazuka. ! See http://factorcode.org/license.txt for BSD license. -USING: fry images.loader images.normalization images.viewer io -io.directories io.encodings.binary io.files io.pathnames -io.streams.byte-array kernel locals namespaces quotations -sequences serialize tools.test io.backend ; +USING: accessors fry images images.loader images.normalization +images.viewer io io.backend io.directories io.encodings.binary +io.files io.pathnames io.streams.byte-array kernel locals +namespaces quotations random sequences serialize tools.test ; IN: images.testing [ '[ _ load-reference-image ] ] bi unit-test ] with-variable ; + +: ( -- image ) + + RGB >>component-order + ubyte-components >>component-type ; inline + +: randomize-image ( image -- image ) + dup bytes-per-image random-bytes >>bitmap ; \ No newline at end of file diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index 02337276e6..c6fc67a8c6 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry irc.client irc.client.chats kernel namespaces sequences threads io.launcher io splitting -make mason.common mason.updates calendar math timers +make mason.common mason.git calendar math timers io.encodings.8-bit.latin1 debugger ; IN: irc.gitbot @@ -47,7 +47,9 @@ M: object handle-message drop ; : check-for-updates ( chat -- ) '[ - git-id git-pull-cmd short-running-process git-id + git-id + { "git" "pull" "origin" "master" } short-running-process + git-id _ report-updates ] try ; diff --git a/extra/javascriptcore/ffi/hack/hack.factor b/extra/javascriptcore/ffi/hack/hack.factor index 1866a24e22..1656cb17f6 100644 --- a/extra/javascriptcore/ffi/hack/hack.factor +++ b/extra/javascriptcore/ffi/hack/hack.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.accessors alien.syntax kernel kernel.private -math system ; +USING: alien alien.accessors alien.c-types alien.syntax kernel +kernel.private math system ; IN: javascriptcore.ffi.hack HOOK: set-callstack-bounds os ( -- ) diff --git a/extra/javascriptcore/ffi/hack/platforms.txt b/extra/javascriptcore/ffi/hack/platforms.txt new file mode 100644 index 0000000000..6e806f449e --- /dev/null +++ b/extra/javascriptcore/ffi/hack/platforms.txt @@ -0,0 +1 @@ +macosx diff --git a/extra/javascriptcore/ffi/platforms.txt b/extra/javascriptcore/ffi/platforms.txt new file mode 100644 index 0000000000..6e806f449e --- /dev/null +++ b/extra/javascriptcore/ffi/platforms.txt @@ -0,0 +1 @@ +macosx diff --git a/extra/llvm/types/types.factor b/extra/llvm/types/types.factor index c312e7a173..25995c389b 100644 --- a/extra/llvm/types/types.factor +++ b/extra/llvm/types/types.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2009 Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators kernel llvm.core locals -math.parser math multiline namespaces parser peg.ebnf sequences -sequences.deep specialized-arrays strings vocabs words ; +USING: accessors alien.c-types arrays combinators kernel +llvm.core locals math.parser math multiline namespaces parser +peg.ebnf sequences sequences.deep specialized-arrays strings +vocabs words ; SPECIALIZED-ARRAY: void* IN: llvm.types diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index f2018449fc..1b8089ed5e 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel calendar io.directories io.encodings.utf8 -io.files io.launcher namespaces prettyprint combinators mason.child -mason.cleanup mason.common mason.help mason.release mason.report -mason.email mason.notify ; +io.files io.launcher io.pathnames namespaces prettyprint +combinators mason.child mason.cleanup mason.common mason.config +mason.docs mason.release mason.report mason.email mason.git +mason.notify mason.platform mason.updates ; QUALIFIED: continuations IN: mason.build @@ -11,12 +12,18 @@ IN: mason.build now datestamp stamp set build-dir make-directory ; -: enter-build-dir ( -- ) build-dir set-current-directory ; +: enter-build-dir ( -- ) + build-dir set-current-directory ; -: clone-builds-factor ( -- ) - "git" "clone" builds/factor 3array short-running-process ; +: clone-source ( -- ) + "git" "clone" builds-dir get "factor" append-path 3array + short-running-process ; -: begin-build ( -- ) +: copy-image ( -- ) + builds-dir get boot-image-name append-path + [ "." copy-file-into ] [ "factor" copy-file-into ] bi ; + +: save-git-id ( -- ) "factor" [ git-id ] with-directory { [ "git-id" to-file ] [ "factor/git-id" to-file ] @@ -24,15 +31,24 @@ IN: mason.build [ notify-begin-build ] } cleave ; +: begin-build ( -- ) + clone-source + copy-image + save-git-id ; + : build ( -- ) create-build-dir enter-build-dir - clone-builds-factor [ begin-build build-child - [ notify-report ] - [ status-clean eq? [ upload-help release ] when ] bi - ] [ cleanup ] [ ] continuations:cleanup ; + [ notify-report ] [ + status-clean eq? + [ notify-upload upload-docs release ] when + ] bi + notify-finish + finish-build + ] [ cleanup ] [ ] continuations:cleanup + notify-idle ; MAIN: build diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 1018a1ec40..140288585f 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -17,22 +17,6 @@ USING: mason.child mason.config tools.test namespaces io kernel sequences ; ] with-scope ] unit-test -[ { "gmake" "netbsd-ppc" } ] [ - [ - "netbsd" target-os set - "ppc" target-cpu set - make-cmd - ] with-scope -] unit-test - -[ { "./factor" "-i=boot.macosx-ppc.image" "-no-user-init" } ] [ - [ - "macosx" target-os set - "ppc" target-cpu set - boot-cmd - ] with-scope -] unit-test - [ { "./factor.com" "-i=boot.winnt-x86.32.image" "-no-user-init" } ] [ [ "winnt" target-os set diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index d9821f8fcc..66e6eb3722 100644 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -29,13 +29,6 @@ IN: mason.child try-process ] with-directory ; -: builds-factor-image ( -- img ) - builds/factor boot-image-name append-path ; - -: copy-image ( -- ) - builds-factor-image "." copy-file-into - builds-factor-image "factor" copy-file-into ; - : factor-vm ( -- string ) target-os get "winnt" = "./factor.com" "./factor" ? ; @@ -81,7 +74,6 @@ MACRO: recover-cond ( alist -- ) ] if ; : build-child ( -- status ) - copy-image { { [ notify-make-vm make-vm ] [ compile-failed ] } { [ notify-boot boot ] [ boot-failed ] } diff --git a/extra/mason/common/common-tests.factor b/extra/mason/common/common-tests.factor index b8e01d3993..1d1ea3d891 100644 --- a/extra/mason/common/common-tests.factor +++ b/extra/mason/common/common-tests.factor @@ -5,13 +5,6 @@ io.files.temp io.encodings.utf8 sequences ; [ "00:01:02" ] [ 62,000,000,000 nanos>time ] unit-test -[ "/home/bobby/builds/factor" ] [ - [ - "/home/bobby/builds" builds-dir set - builds/factor - ] with-scope -] unit-test - [ t ] [ [ "/home/bobby/builds" builds-dir set diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index db68a558e0..798f4d166a 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories @@ -20,27 +20,35 @@ SYMBOL: current-git-id #! 30 minutes to complete, to catch hangs. >process 30 minutes >>timeout try-output-process ; -HOOK: really-delete-tree os ( path -- ) +HOOK: (really-delete-tree) os ( path -- ) -M: windows really-delete-tree +M: windows (really-delete-tree) #! Workaround: Cygwin GIT creates read-only files for #! some reason. [ { "chmod" "ug+rw" "-R" } swap absolute-path suffix short-running-process ] [ delete-tree ] bi ; -M: unix really-delete-tree delete-tree ; +M: unix (really-delete-tree) delete-tree ; + +: really-delete-tree ( path -- ) + dup exists? [ (really-delete-tree) ] [ drop ] if ; : retry ( n quot -- ) [ iota ] dip '[ drop @ f ] attempt-all drop ; inline +: upload-process ( process -- ) + #! Give network operations and shell commands at most + #! 30 minutes to complete, to catch hangs. + >process upload-timeout get >>timeout try-output-process ; + :: upload-safely ( local username host remote -- ) remote ".incomplete" append :> temp { username "@" host ":" temp } concat :> scp-remote scp-command get :> scp ssh-command get :> ssh - 5 [ { scp local scp-remote } short-running-process ] retry + 5 [ { scp local scp-remote } upload-process ] retry 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ; : eval-file ( file -- obj ) @@ -65,22 +73,8 @@ M: unix really-delete-tree delete-tree ; SYMBOL: stamp -: builds/factor ( -- path ) builds-dir get "factor" append-path ; : build-dir ( -- path ) builds-dir get stamp get append-path ; -: prepare-build-machine ( -- ) - builds-dir get make-directories - builds-dir get - [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ] - with-directory ; - -: git-id ( -- id ) - { "git" "show" } utf8 [ lines ] with-process-reader - first " " split second ; - -: ?prepare-build-machine ( -- ) - builds/factor exists? [ prepare-build-machine ] unless ; - CONSTANT: load-all-vocabs-file "load-everything-vocabs" CONSTANT: load-all-errors-file "load-everything-errors" diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index b72b949ed5..9d8c8b8692 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system io.files io.pathnames namespaces kernel accessors -assocs ; +USING: calendar system io.files io.pathnames namespaces kernel +accessors assocs ; IN: mason.config ! (Optional) Location for build directories @@ -34,24 +34,36 @@ target-os get-global [ ! Keep test-log around? SYMBOL: builder-debug +! URL for counter notifications. +SYMBOL: counter-url + +counter-url [ "http://builds.factorcode.org/counter" ] initialize + ! URL for status notifications. SYMBOL: status-url +status-url [ "http://builds.factorcode.org/status-update" ] initialize + ! Password for status notifications. SYMBOL: status-secret -SYMBOL: upload-help? +SYMBOL: upload-docs? -! The below are only needed if upload-help is true. +! The below are only needed if upload-docs? is true. -! Host with HTML help -SYMBOL: help-host +! Host to upload docs to +SYMBOL: docs-host ! Username to log in. -SYMBOL: help-username +SYMBOL: docs-username ! Directory to upload docs to. -SYMBOL: help-directory +SYMBOL: docs-directory + +! URL to notify server about new docs +SYMBOL: docs-update-url + +docs-update-url [ "http://builds.factorcode.org/docs-update" ] initialize ! Boolean. Do we release binaries and update the clean branch? SYMBOL: upload-to-factorcode? @@ -85,6 +97,10 @@ SYMBOL: upload-username ! Directory with binary packages. SYMBOL: upload-directory +! Upload timeout +SYMBOL: upload-timeout +1 hours upload-timeout set-global + ! Optional: override ssh and scp command names SYMBOL: scp-command scp-command [ "scp" ] initialize diff --git a/basis/io/pipes/windows/nt/authors.txt b/extra/mason/disk/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/io/pipes/windows/nt/authors.txt rename to extra/mason/disk/authors.txt diff --git a/extra/mason/disk/disk-tests.factor b/extra/mason/disk/disk-tests.factor new file mode 100644 index 0000000000..b1c0a7e28f --- /dev/null +++ b/extra/mason/disk/disk-tests.factor @@ -0,0 +1,6 @@ +USING: mason.disk tools.test strings sequences ; +IN: mason.disk.tests + +[ t ] [ disk-usage string? ] unit-test + +[ t ] [ sufficient-disk-space? { t f } member? ] unit-test diff --git a/extra/mason/disk/disk.factor b/extra/mason/disk/disk.factor new file mode 100644 index 0000000000..ca4a703aaf --- /dev/null +++ b/extra/mason/disk/disk.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors io.files.info io.pathnames kernel math +math.parser namespaces sequences mason.config ; +IN: mason.disk + +: gb ( -- n ) 30 2^ ; inline + +: sufficient-disk-space? ( -- ? ) + ! We want at least 300Mb to be available before starting + ! a build. + current-directory get file-system-info available-space>> + gb > ; + +: check-disk-space ( -- ) + sufficient-disk-space? [ + "Less than 1 Gb free disk space." throw + ] unless ; + +: mb-str ( n -- string ) gb /i number>string ; + +: disk-usage ( -- string ) + builds-dir get file-system-info + [ used-space>> ] [ total-space>> ] bi + [ [ mb-str ] bi@ " / " glue " Gb used" append ] + [ [ 100 * ] dip /i number>string "(" "%)" surround ] 2bi + " " glue ; diff --git a/extra/mason/docs/docs.factor b/extra/mason/docs/docs.factor new file mode 100644 index 0000000000..0c3feaa4e9 --- /dev/null +++ b/extra/mason/docs/docs.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008, 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays hashtables help.html http.client io.directories +io.files io.launcher kernel make mason.common mason.config +namespaces sequences ; +IN: mason.docs + +: make-docs-archive ( -- ) + "factor/temp" [ + { "tar" "cfz" "docs.tar.gz" "docs" } short-running-process + ] with-directory ; + +: upload-docs-archive ( -- ) + "factor/temp/docs.tar.gz" + docs-username get + docs-host get + docs-directory get "/docs.tar.gz" append + upload-safely ; + +: notify-docs ( -- ) + status-secret get "secret" associate + docs-update-url get + http-post + 2drop ; + +: upload-docs ( -- ) + upload-docs? get [ + make-docs-archive + upload-docs-archive + notify-docs + ] when ; \ No newline at end of file diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index 1389a2e27c..68724b3ffa 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -1,18 +1,24 @@ ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces accessors combinators make smtp debugger -prettyprint sequences io io.streams.string io.encodings.utf8 io.files -io.sockets mason.common mason.platform mason.config ; +USING: accessors calendar combinators continuations debugger fry +io io.encodings.utf8 io.files io.sockets kernel make +mason.common mason.config mason.platform math.order namespaces +prettyprint sequences smtp ; IN: mason.email : mason-email ( body content-type subject -- ) - - builder-from get >>from - builder-recipients get >>to - swap >>subject - swap >>content-type - swap >>body - send-email ; + '[ + + builder-from get >>from + builder-recipients get >>to + _ >>body + _ >>content-type + _ >>subject + send-email + ] [ + "E-MAILING FAILED:" print + error. flush + ] recover ; : subject-prefix ( -- string ) "mason on " platform ": " 3append ; @@ -32,11 +38,52 @@ IN: mason.email : email-report ( report status -- ) [ "text/html" ] dip report-subject mason-email ; -: email-error ( error callstack -- ) +! Some special logic to throttle the amount of fatal errors +! coming in, if eg git-daemon goes down on factorcode.org and +! it fails pulling every 5 minutes. + +SYMBOL: last-email-time + +SYMBOL: next-email-time + +: send-email-throttled? ( -- ? ) + ! We sent too many errors. See if its time to send a new + ! one again. + now next-email-time get-global after? + [ f next-email-time set-global t ] [ f ] if ; + +: throttle-time ( -- dt ) 6 hours ; + +: throttle-emails ( -- ) + ! Last e-mail was less than 20 minutes ago. Don't send any + ! errors for 4 hours. + throttle-time hence next-email-time set-global + f last-email-time set-global ; + +: maximum-frequency ( -- dt ) 30 minutes ; + +: send-email-capped? ( -- ? ) + ! We're about to send an error after sending another one. + ! See if we should start throttling emails. + last-email-time get-global + maximum-frequency ago + after? + [ throttle-emails f ] [ t ] if ; + +: email-fatal? ( -- ? ) + { + { [ next-email-time get-global ] [ send-email-throttled? ] } + { [ last-email-time get-global ] [ send-email-capped? ] } + [ now last-email-time set-global t ] + } cond + dup [ now last-email-time set-global ] when ; + +: email-fatal ( string subject -- ) + [ print nl print flush ] [ - "Fatal error on " write host-name print nl - [ error. ] [ callstack. ] bi* - ] with-string-writer - "text/plain" - subject-prefix "fatal error" append - mason-email ; + email-fatal? [ + now last-email-time set-global + [ "text/plain" subject-prefix ] dip append + mason-email + ] [ 2drop ] if + ] 2bi ; diff --git a/extra/mason/version/authors.txt b/extra/mason/git/authors.txt similarity index 100% rename from extra/mason/version/authors.txt rename to extra/mason/git/authors.txt diff --git a/extra/mason/git/git.factor b/extra/mason/git/git.factor new file mode 100644 index 0000000000..df344be12e --- /dev/null +++ b/extra/mason/git/git.factor @@ -0,0 +1,102 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit continuations +debugger io io.directories io.encodings.utf8 io.files +io.launcher io.sockets io.streams.string kernel mason.common +mason.email sequences splitting ; +IN: mason.git + +: git-id ( -- id ) + { "git" "show" } utf8 [ lines ] with-process-reader + first " " split second ; + +> "not uptodate. Cannot merge." swap start + [ git-repo-corrupted ] + [ rethrow ] + if + ] [ rethrow ] if ; + +: with-process-reader* ( desc encoding quot -- ) + [ ] dip swap [ with-input-stream ] dip + dup wait-for-process dup { 0 1 } member? + [ 2drop ] [ process-failed ] if ; inline + +: git-status-cmd ( -- cmd ) + { "git" "status" } ; + +: git-status-failed ( error -- ) + #! Exit code 1 means there's nothing to commit. + dup { [ process-failed? ] [ code>> 1 = ] } 1&& + [ drop ] [ rethrow ] if ; + +: git-status ( -- seq ) + [ + git-status-cmd utf8 [ lines ] with-process-reader* + [ "#\t" head? ] filter + ] [ git-status-failed { } ] recover ; + +: check-repository ( -- seq ) + "factor" [ git-status ] with-directory ; + +: repo-dirty-body ( error -- string ) + [ + "Dirty repository on " write host-name write " will be re-cloned." print + "Modified and untracked files:" print nl + [ print ] each + ] with-string-writer ; + +: git-repo-dirty ( files -- ) + repo-dirty-body "dirty repo" email-fatal + "factor" really-delete-tree + git-clone ; + +PRIVATE> + +: git-pull ( -- id ) + #! Must be run from builds-dir. + "factor" exists? [ + check-repository [ + "factor" [ + [ git-pull-cmd short-running-process ] + [ git-pull-failed ] + recover + ] with-directory + ] [ git-repo-dirty ] if-empty + ] [ git-clone ] if + "factor" [ git-id ] with-directory ; diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor deleted file mode 100644 index 6b44e49c61..0000000000 --- a/extra/mason/help/help.factor +++ /dev/null @@ -1,23 +0,0 @@ -! Copyright (C) 2008, 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays help.html io.directories io.files io.launcher -kernel make mason.common mason.config namespaces sequences ; -IN: mason.help - -: make-help-archive ( -- ) - "factor/temp" [ - { "tar" "cfz" "docs.tar.gz" "docs" } short-running-process - ] with-directory ; - -: upload-help-archive ( -- ) - "factor/temp/docs.tar.gz" - help-username get - help-host get - help-directory get "/docs.tar.gz" append - upload-safely ; - -: upload-help ( -- ) - upload-help? get [ - make-help-archive - upload-help-archive - ] when ; \ No newline at end of file diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor index 3afa56290b..c08e330218 100755 --- a/extra/mason/mason.factor +++ b/extra/mason/mason.factor @@ -1,33 +1,46 @@ ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors calendar continuations debugger io -io.directories io.files kernel mason.common -mason.email mason.updates mason.notify namespaces threads ; +io.directories io.pathnames io.sockets io.streams.string kernel +mason.config mason.disk mason.email mason.notify mason.updates +namespaces prettyprint threads ; FROM: mason.build => build ; IN: mason -: build-loop-error ( error -- ) - [ "Build loop error:" print flush error. flush :c flush ] - [ error-continuation get call>> email-error ] bi ; +: heartbeat-loop ( -- ) + notify-heartbeat + 5 minutes sleep + heartbeat-loop ; -: build-loop-fatal ( error -- ) - "FATAL BUILDER ERROR:" print - error. flush ; +: fatal-error-body ( error callstack -- string ) + [ + "Fatal error on " write host-name print nl + [ error. ] [ callstack. ] bi* + ] with-string-writer ; + +: build-loop-error ( error callstack -- ) + fatal-error-body + "build loop error" + email-fatal ; : build-loop ( -- ) - ?prepare-build-machine [ - notify-heartbeat - [ - builds/factor set-current-directory - new-code-available? [ build ] when - ] [ - build-loop-error - ] recover + builds-dir get make-directories + builds-dir get [ + check-disk-space + update-sources + build? [ build ] [ 5 minutes sleep ] if + ] with-directory ] [ - build-loop-fatal + error-continuation get call>> build-loop-error + 5 minutes sleep ] recover - 5 minutes sleep + build-loop ; -MAIN: build-loop \ No newline at end of file +: mason ( -- * ) + [ heartbeat-loop ] "Heartbeat loop" spawn + [ build-loop ] "Build loop" spawn + stop ; + +MAIN: mason \ No newline at end of file diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 144f0de122..cdde08f979 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -2,24 +2,34 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors fry http.client io io.encodings.utf8 io.files kernel mason.common mason.config mason.email mason.twitter -namespaces prettyprint sequences ; +namespaces prettyprint sequences debugger continuations ; IN: mason.notify : status-notify ( report arg message -- ) - [ - short-host-name "host-name" set - target-cpu get "target-cpu" set - target-os get "target-os" set - status-secret get "secret" set - "message" set - "arg" set - "report" set - ] H{ } make-assoc - [ 5 ] dip '[ _ status-url get http-post 2drop ] retry ; + '[ + 5 [ + [ + short-host-name "host-name" set + target-cpu get "target-cpu" set + target-os get "target-os" set + status-secret get "secret" set + _ "report" set + _ "arg" set + _ "message" set + ] H{ } make-assoc + status-url get http-post 2drop + ] retry + ] [ + "STATUS NOTIFY FAILED:" print + error. flush + ] recover ; : notify-heartbeat ( -- ) f f "heartbeat" status-notify ; +: notify-idle ( -- ) + f f "idle" status-notify ; + : notify-begin-build ( git-id -- ) [ "Starting build of GIT ID " write print flush ] [ f swap "git-id" status-notify ] @@ -44,6 +54,12 @@ IN: mason.notify [ name>> "report" status-notify ] [ email-report ] 2bi ] bi ; +: notify-upload ( -- ) + f f "upload" status-notify ; + +: notify-finish ( -- ) + f f "finish" status-notify ; + : notify-release ( archive-name -- ) [ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ] [ f swap "release" status-notify ] diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor index 07ec5a8bcd..06923b5d2b 100644 --- a/extra/mason/release/branch/branch.factor +++ b/extra/mason/release/branch/branch.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.directories io.files io.launcher kernel make namespaces prettyprint sequences mason.common mason.config @@ -11,7 +11,7 @@ IN: mason.release.branch : push-to-clean-branch-cmd ( -- args ) [ - "git" , "push" , + { "git" "push" "-f" } % [ branch-username get % "@" % branch-host get % ":" % diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index c5567c9c97..926207be00 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: benchmark combinators.smart debugger fry io assocs io.encodings.utf8 io.files io.sockets io.streams.string kernel -locals mason.common mason.config mason.platform math namespaces -prettyprint sequences xml.syntax xml.writer combinators.short-circuit -literals splitting ; +locals mason.common mason.config mason.disk mason.platform math +namespaces prettyprint sequences xml.syntax xml.writer +combinators.short-circuit literals splitting ; IN: mason.report : git-link ( id -- link ) @@ -15,12 +15,14 @@ IN: mason.report target-os get target-cpu get short-host-name + disk-usage build-dir current-git-id get git-link [XML

Build report for <->/<->

+
Build machine:<->
Disk usage:<->
Build directory:<->
GIT ID:<->
diff --git a/extra/mason/updates/updates.factor b/extra/mason/updates/updates.factor index 4221bd4376..016c1a6d79 100644 --- a/extra/mason/updates/updates.factor +++ b/extra/mason/updates/updates.factor @@ -1,26 +1,38 @@ ! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: bootstrap.image.download io.directories io.launcher -kernel mason.common mason.platform ; +USING: bootstrap.image.download http.client init kernel +math.parser namespaces mason.config mason.common mason.git +mason.platform ; IN: mason.updates -: git-pull-cmd ( -- cmd ) - { - "git" - "pull" - "--no-summary" - "git://factorcode.org/git/factor.git" - "master" - } ; +TUPLE: sources git-id boot-image counter ; -: updates-available? ( -- ? ) - git-id - git-pull-cmd short-running-process - git-id - = not ; +C: sources -: new-image-available? ( -- ? ) - boot-image-name maybe-download-image ; +SYMBOLS: latest-sources last-built-sources ; -: new-code-available? ( -- ? ) - updates-available? new-image-available? or ; +[ + f latest-sources set-global + f last-built-sources set-global +] "mason.updates" add-startup-hook + +: latest-boot-image ( -- boot-image ) + boot-image-name + [ maybe-download-image drop ] [ file-checksum ] bi ; + +: latest-counter ( -- counter ) + counter-url get-global http-get nip string>number ; + +: update-sources ( -- ) + #! Must be run from builds-dir + git-pull latest-boot-image latest-counter + latest-sources set-global ; + +: build? ( -- ? ) + latest-sources get-global last-built-sources get-global = not ; + +: finish-build ( -- ) + #! If the build completed (successfully or not) without + #! mason crashing or being killed, don't build this git ID + #! and boot image hash again. + latest-sources get-global last-built-sources set-global ; diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor index 2f13237c9d..0bf09633a4 100644 --- a/extra/math/floating-point/floating-point-tests.factor +++ b/extra/math/floating-point/floating-point-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: tools.test math.floating-point kernel -math.constants fry sequences math ; +math.constants fry sequences math random ; IN: math.floating-point.tests [ t ] [ pi >double< >double pi = ] unit-test @@ -13,3 +13,19 @@ IN: math.floating-point.tests [ f ] [ 10. infinity? ] unit-test [ f ] [ -10. infinity? ] unit-test [ f ] [ 0. infinity? ] unit-test + +[ 0 ] [ 0.0 double>ratio ] unit-test +[ 1 ] [ 1.0 double>ratio ] unit-test +[ 1/2 ] [ 0.5 double>ratio ] unit-test +[ 3/4 ] [ 0.75 double>ratio ] unit-test +[ 12+1/2 ] [ 12.5 double>ratio ] unit-test +[ -12-1/2 ] [ -12.5 double>ratio ] unit-test +[ 3+39854788871587/281474976710656 ] [ pi double>ratio ] unit-test + +: roundtrip ( n -- ) + [ '[ _ ] ] keep '[ _ double>ratio >float ] unit-test ; + +{ 1 12 123 1234 } [ bits>double roundtrip ] each + +100 [ -10.0 10.0 uniform-random-float roundtrip ] times + diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor index e6e92919e2..fb9b258038 100644 --- a/extra/math/floating-point/floating-point.factor +++ b/extra/math/floating-point/floating-point.factor @@ -44,3 +44,14 @@ IN: math.floating-point [ (double-exponent-bits) 11 on-bits = ] [ (double-mantissa-bits) 0 = ] } 1&& ; + +: check-special ( n -- n ) + dup fp-special? [ "cannot be special" throw ] when ; + +: double>ratio ( double -- a/b ) + check-special double>bits + [ (double-sign) zero? 1 -1 ? ] + [ (double-mantissa-bits) 52 2^ / ] + [ (double-exponent-bits) ] tri + dup zero? [ 1 + ] [ [ 1 + ] dip ] if 1023 - 2 swap ^ * * ; + diff --git a/extra/mongodb/connection/connection.factor b/extra/mongodb/connection/connection.factor index 2918d58664..17a0494bf7 100644 --- a/extra/mongodb/connection/connection.factor +++ b/extra/mongodb/connection/connection.factor @@ -1,9 +1,9 @@ USING: accessors arrays assocs byte-vectors checksums -checksums.md5 constructors destructors fry hashtables -io.encodings.binary io.encodings.string io.encodings.utf8 -io.sockets io.streams.duplex kernel locals math math.parser -mongodb.cmd mongodb.msg namespaces sequences -splitting ; +checksums.md5 constructors continuations destructors fry +hashtables io.encodings.binary io.encodings.string +io.encodings.utf8 io.sockets io.streams.duplex kernel locals +math math.parser mongodb.cmd mongodb.msg +namespaces sequences splitting ; IN: mongodb.connection : md5-checksum ( string -- digest ) @@ -101,9 +101,9 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; ] with-connection ; inline : open-connection ( mdb-connection node -- mdb-connection ) - [ >>node ] [ address>> ] bi - [ >>remote ] keep binary - [ >>handle ] dip >>local 4096 >>buffer ; + [ >>node ] [ address>> ] bi + [ >>remote ] keep binary + [ >>handle ] dip >>local 4096 >>buffer ; : get-ismaster ( -- result ) "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ; @@ -119,8 +119,8 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; : check-node ( mdb node -- ) [ &dispose ] dip - [ open-connection ] keep swap - [ get-ismaster eval-ismaster-result ] with-connection ; + [ [ open-connection ] [ 3drop f ] recover ] keep swap + [ [ get-ismaster eval-ismaster-result ] with-connection ] [ drop ] if* ; : nodelist>table ( seq -- assoc ) [ [ master?>> ] keep 2array ] map >hashtable ; @@ -134,19 +134,21 @@ PRIVATE> mdb node1 remote>> [ [ check-node ] keep ] [ drop f ] if* :> node2 - node1 [ acc push ] when* node2 [ acc push ] when* mdb acc nodelist>table >>nodes drop - ] with-destructors ; + ] with-destructors ; + +ERROR: mongod-connection-error address message ; : mdb-open ( mdb -- mdb-connection ) - clone [ ] keep - master-node open-connection - [ authenticate-connection ] keep ; + clone [ verify-nodes ] [ ] [ ] tri + master-node [ + open-connection [ authenticate-connection ] keep + ] [ drop nip address>> "Could not open connection to mongod" mongod-connection-error ] recover ; : mdb-close ( mdb-connection -- ) - [ dispose f ] change-handle drop ; + [ [ dispose ] when* f ] change-handle drop ; M: mdb-connection dispose mdb-close ; diff --git a/extra/mongodb/driver/driver-docs.factor b/extra/mongodb/driver/driver-docs.factor index 95acd523b3..11d37e1c64 100644 --- a/extra/mongodb/driver/driver-docs.factor +++ b/extra/mongodb/driver/driver-docs.factor @@ -81,15 +81,13 @@ HELP: create-collection HELP: delete { $values - { "collection" "a collection" } - { "selector" "assoc which identifies the objects to be removed from the collection" } + { "mdb-delete-msg" "a delete msg" } } { $description "removes objects from the collection (with lasterror check)" } ; HELP: delete-unsafe { $values - { "collection" "a collection" } - { "selector" "assoc which identifies the objects to be removed from the collection" } + { "mdb-delete-msg" "a delete msg" } } { $description "removes objects from the collection (without error check)" } ; diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 0bd22ee7fe..28e6e2c0aa 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -5,6 +5,7 @@ mongodb.cmd mongodb.connection mongodb.msg namespaces parser prettyprint prettyprint.custom prettyprint.sections sequences sets splitting strings ; FROM: ascii => ascii? ; +FROM: math.bitwise => set-bit ; IN: mongodb.driver TUPLE: mdb-pool < pool mdb ; @@ -184,6 +185,15 @@ PRIVATE> : ( collection assoc -- mdb-query-msg ) ; inline +: >slave-ok ( mdb-query-msg -- mdb-query-msg ) + [ 2 set-bit ] change-flags ; + +: >await-data ( mdb-query-msg -- mdb-query-msg ) + [ 5 set-bit ] change-flags ; + +: >tailable ( mdb-query-msg -- mdb-query-msg ) + [ 1 set-bit ] change-flags ; + : limit ( mdb-query-msg limit# -- mdb-query-msg ) >>return# ; inline @@ -278,7 +288,10 @@ PRIVATE> [ check-collection ] 2dip ; : >upsert ( mdb-update-msg -- mdb-update-msg ) - 1 >>upsert? ; + [ 0 set-bit ] change-update-flags ; + +: >multi ( mdb-update-msg -- mdb-update-msg ) + [ 1 set-bit ] change-update-flags ; : update ( mdb-update-msg -- ) send-message-check-error ; @@ -295,13 +308,17 @@ PRIVATE> : run-cmd ( cmd -- result ) send-cmd ; inline -: delete ( collection selector -- ) - [ check-collection ] dip - send-message-check-error ; +: ( collection selector -- mdb-delete-msg ) + [ check-collection ] dip ; -: delete-unsafe ( collection selector -- ) - [ check-collection ] dip - send-message ; +: >single-remove ( mdb-delete-msg -- mdb-delete-msg ) + [ 0 set-bit ] change-delete-flags ; + +: delete ( mdb-delete-msg -- ) + send-message-check-error ; + +: delete-unsafe ( mdb-delete-msg -- ) + send-message ; : kill-cursor ( mdb-cursor -- ) id>> send-message ; diff --git a/extra/mongodb/mongodb-docs.factor b/extra/mongodb/mongodb-docs.factor index 6bddc2f496..6a74392596 100644 --- a/extra/mongodb/mongodb-docs.factor +++ b/extra/mongodb/mongodb-docs.factor @@ -20,7 +20,7 @@ ARTICLE: "mongodb" "MongoDB factor integration" "person \"persons\" { } { $[ \"ageIdx\" [ \"age\" asc ] key-spec ] } define-persistent " "\"db\" \"127.0.0.1\" 27017 " "person new \"Alfred\" >>name 57 >>age" - "'[ _ save-tuple person new 57 >>age select-tuple ] with-db" + "'[ person ensure-table _ save-tuple person new 57 >>age select-tuple ] with-db" "" } ; diff --git a/extra/mongodb/msg/msg.factor b/extra/mongodb/msg/msg.factor index ca9393a108..5011e8897c 100644 --- a/extra/mongodb/msg/msg.factor +++ b/extra/mongodb/msg/msg.factor @@ -38,12 +38,13 @@ TUPLE: mdb-insert-msg < mdb-msg TUPLE: mdb-update-msg < mdb-msg { collection string } - { upsert? integer initial: 0 } + { update-flags integer initial: 0 } { selector assoc } { object assoc } ; TUPLE: mdb-delete-msg < mdb-msg { collection string } + { delete-flags integer initial: 0 } { selector assoc } ; TUPLE: mdb-getmore-msg < mdb-msg diff --git a/extra/mongodb/operations/operations.factor b/extra/mongodb/operations/operations.factor index 7d16b4c40a..cb41ae5ea9 100644 --- a/extra/mongodb/operations/operations.factor +++ b/extra/mongodb/operations/operations.factor @@ -120,7 +120,7 @@ PRIVATE> { [ flags>> write-int32 ] [ collection>> write-cstring ] - [ upsert?>> write-int32 ] + [ update-flags>> write-int32 ] [ selector>> assoc>stream ] [ object>> assoc>stream ] } cleave @@ -128,9 +128,12 @@ PRIVATE> : write-delete-message ( message -- ) [ - [ flags>> write-int32 ] - [ collection>> write-cstring ] - [ 0 write-int32 selector>> assoc>stream ] tri + { + [ flags>> write-int32 ] + [ collection>> write-cstring ] + [ delete-flags>> write-int32 ] + [ selector>> assoc>stream ] + } cleave ] (write-message) ; inline : write-getmore-message ( message -- ) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 2f235f74a0..3b0392b70d 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -7,8 +7,6 @@ FROM: mongodb.tuple.persistent => assoc>tuple ; IN: mongodb.tuple -SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ +unique+ ; - SYNTAX: MDBTUPLE: parse-tuple-definition mdb-check-slots @@ -75,7 +73,7 @@ PRIVATE> : delete-tuple ( tuple -- ) [ tuple-collection name>> ] keep - id-selector delete ; + id-selector delete ; : delete-tuples ( seq -- ) [ delete-tuple ] each ; diff --git a/extra/openal/alut/macosx/macosx.factor b/extra/openal/alut/macosx/macosx.factor index 3c0a4672cb..54439b762c 100755 --- a/extra/openal/alut/macosx/macosx.factor +++ b/extra/openal/alut/macosx/macosx.factor @@ -6,7 +6,7 @@ IN: openal.alut.macosx LIBRARY: alut -FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ; +FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ; M: macosx load-wav-file ( path -- format data size frequency ) 0 f 0 0 diff --git a/extra/openal/alut/other/other.factor b/extra/openal/alut/other/other.factor index b19579286b..8b1cbd0cb3 100755 --- a/extra/openal/alut/other/other.factor +++ b/extra/openal/alut/other/other.factor @@ -6,7 +6,7 @@ IN: openal.alut.other LIBRARY: alut -FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ; +FUNCTION: void alutLoadWAVFile ( c-string fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ; M: object load-wav-file ( filename -- format data size frequency ) 0 f 0 0 diff --git a/extra/ping/authors.txt b/extra/ping/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/ping/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/ping/ping-tests.factor b/extra/ping/ping-tests.factor new file mode 100644 index 0000000000..51250cd02f --- /dev/null +++ b/extra/ping/ping-tests.factor @@ -0,0 +1,7 @@ +USING: continuations destructors io.sockets kernel ping +tools.test ; +IN: ping.tests + +[ t ] [ "localhost" alive? ] unit-test +[ t ] [ "127.0.0.1" alive? ] unit-test +[ f ] [ "0.0.0.0" alive? ] unit-test diff --git a/extra/ping/ping.factor b/extra/ping/ping.factor new file mode 100644 index 0000000000..4988a486b0 --- /dev/null +++ b/extra/ping/ping.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license +USING: accessors byte-arrays calendar checksums +checksums.internet combinators combinators.smart continuations +destructors io.sockets io.sockets.icmp io.timeouts kernel +locals pack random sequences system ; +IN: ping + + ( sequence data -- echo ) + [ 8 16 random-bits ] 2dip echo boa ; + +: echo>byte-array ( echo -- byte-array ) + [ + [ + [ type>> 0 0 ] ! code checksum + [ identifier>> ] + [ sequence>> ] tri + ] output>array "CCSSS" pack-be + ] [ data>> ] bi append [ + internet checksum-bytes 2 4 + ] keep replace-slice ; + +: byte-array>echo ( byte-array -- echo ) + dup internet checksum-bytes B{ 0 0 } assert= + 8 cut [ + "CCSSS" unpack-be { 0 3 4 } swap nths first3 + ] dip echo boa ; + +: send-ping ( addr raw -- ) + [ 0 { } echo>byte-array ] 2dip send ; + +:: recv-ping ( addr raw -- echo ) + raw receive addr = [ + 20 tail byte-array>echo + ] [ + drop addr raw recv-ping + ] if ; + +PRIVATE> + +HOOK: os ( inet -- port ) + +M: object ; + +M: macosx ; + +: ping ( host -- reply ) + resolve-host [ icmp4? ] filter random + f + 1 seconds over set-timeout + [ [ send-ping ] [ recv-ping ] 2bi ] with-disposal ; + +: local-ping ( -- reply ) + "127.0.0.1" ping ; + +: alive? ( host -- ? ) + [ ping drop t ] [ 2drop f ] recover ; + diff --git a/extra/ping/platforms.txt b/extra/ping/platforms.txt new file mode 100644 index 0000000000..6aa71e7b1f --- /dev/null +++ b/extra/ping/platforms.txt @@ -0,0 +1,2 @@ +windows +macosx diff --git a/extra/ping/summary.txt b/extra/ping/summary.txt new file mode 100644 index 0000000000..f59b1f44b6 --- /dev/null +++ b/extra/ping/summary.txt @@ -0,0 +1 @@ +Uses ICMP to test the reachability of a network host. diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 2a0b2946e5..bc9114ee50 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -8,9 +8,23 @@ continuations calendar prettyprint dlists deques locals spider.unique-deque combinators concurrency.semaphores ; IN: spider -TUPLE: spider base count max-count sleep max-depth initial-links -filters spidered todo nonmatching quiet currently-spidering -#threads semaphore follow-robots? robots ; +TUPLE: spider + base + { count integer initial: 0 } + { max-count number initial: 1/0. } + sleep + { max-depth integer initial: 0 } + initial-links + filters + spidered + todo + nonmatching + quiet? + currently-spidering + { #threads integer initial: 1 } + semaphore + follow-robots? + robots ; TUPLE: spider-result url depth headers fetched-in parsed-html links processed-in fetched-at ; @@ -22,21 +36,20 @@ fetched-in parsed-html links processed-in fetched-at ; over >>currently-spidering swap 0 [ push-url ] keep >>todo >>nonmatching - 0 >>max-depth - 0 >>count - 1/0. >>max-count H{ } clone >>spidered - 1 [ >>#threads ] [ >>semaphore ] bi ; + 1 >>semaphore ; : ( url depth -- spider-result ) spider-result new swap >>depth - swap >>url ; + swap >>url ; inline > [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ; + filters>> [ + '[ [ _ 1&& ] filter ] call( seq -- seq' ) + ] when* ; : push-links ( links level unique-deque -- ) '[ _ _ push-url ] each ; @@ -51,13 +64,18 @@ fetched-in parsed-html links processed-in fetched-at ; [ base>> host>> ] [ links>> members ] bi* [ host>> = ] with partition ; -: add-spidered ( spider spider-result -- ) - [ [ 1 + ] change-count ] dip - 2dup [ spidered>> ] [ dup url>> ] bi* rot set-at - [ filter-base-links ] 2keep - depth>> 1 + swap - [ add-nonmatching ] - [ dup '[ _ apply-filters ] curry 2dip add-todo ] 2bi ; +:: add-spidered ( spider spider-result -- ) + spider [ 1 + ] change-count drop + + spider-result dup url>> + spider spidered>> set-at + + spider spider-result filter-base-links :> ( matching nonmatching ) + spider-result depth>> 1 + :> depth + + nonmatching depth spider add-nonmatching + + matching spider apply-filters depth spider add-todo ; : normalize-hrefs ( base links -- links' ) [ derive-url ] with map ; @@ -84,24 +102,24 @@ fetched-in parsed-html links processed-in fetched-at ; now >>fetched-at drop ; :: spider-page ( spider spider-result -- ) - spider quiet>> [ spider-result print-spidering ] unless + spider quiet?>> [ spider-result print-spidering ] unless spider spider-result fill-spidered-result - spider quiet>> [ spider-result describe ] unless + spider quiet?>> [ spider-result describe ] unless spider spider-result add-spidered ; \ spider-page ERROR add-error-logging : spider-sleep ( spider -- ) sleep>> [ sleep ] when* ; -: queue-initial-links ( spider -- ) - [ - [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0 - ] keep add-todo ; +: queue-initial-links ( spider -- spider ) + [ [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0 ] + [ add-todo ] + [ ] tri ; : spider-page? ( spider -- ? ) { [ todo>> deque>> deque-empty? not ] - [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ] + [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi <= ] [ [ count>> ] [ max-count>> ] bi < ] } 1&& ; @@ -123,5 +141,6 @@ PRIVATE> : run-spider ( spider -- spider ) "spider" [ - dup queue-initial-links [ run-spider-loop ] keep + queue-initial-links + [ run-spider-loop ] keep ] with-logging ; diff --git a/extra/time-server/time-server.factor b/extra/time-server/time-server.factor index 500f0276d7..935c1ee868 100644 --- a/extra/time-server/time-server.factor +++ b/extra/time-server/time-server.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors calendar calendar.format io io.encodings.ascii -io.servers.connection threads ; +io.servers.connection kernel threads ; IN: time-server : handle-time-client ( -- ) @@ -13,7 +13,7 @@ IN: time-server 1234 >>insecure [ handle-time-client ] >>handler ; -: start-time-server ( -- threaded-server ) - [ start-server ] in-thread ; +: start-time-server ( -- ) + start-server drop ; MAIN: start-time-server diff --git a/extra/benchmark/struct/authors.txt b/extra/tools/time/struct/authors.txt similarity index 100% rename from extra/benchmark/struct/authors.txt rename to extra/tools/time/struct/authors.txt diff --git a/extra/benchmark/struct/struct.factor b/extra/tools/time/struct/struct.factor similarity index 97% rename from extra/benchmark/struct/struct.factor rename to extra/tools/time/struct/struct.factor index addc40ddba..1f63fc0528 100644 --- a/extra/benchmark/struct/struct.factor +++ b/extra/tools/time/struct/struct.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types classes.struct kernel memory system vm ; -IN: benchmark.struct +IN: tools.time.struct STRUCT: benchmark-data { time ulonglong } diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index 0c7395f7f0..24fadef5bf 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -7,7 +7,7 @@ IN: tty-server "tty-server" >>name swap local-server >>insecure [ listener ] >>handler - start-server ; + start-server drop ; : tty-server ( -- ) 9999 ; diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index aacdd8d839..9236cc9504 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators hashtables http http.client json.reader kernel macros namespaces sequences -urls.secure fry oauth urls ; +urls.secure fry oauth urls system ; IN: twitter ! Configuration @@ -19,26 +19,27 @@ twitter-source [ "factor" ] initialize call ] with-scope ; inline -PRIVATE> +: twitter-url ( string -- string' ) + os windows? + "http://twitter.com/" + "https://twitter.com/" ? prepend ; -! obtain-twitter-request-token and obtain-twitter-access-token -! should use https: URLs but Twitter sends a 301 Redirect back -! to the same URL. Twitter bug? +PRIVATE> : obtain-twitter-request-token ( -- request-token ) [ - "https://twitter.com/oauth/request_token" + "oauth/request_token" twitter-url obtain-request-token ] with-twitter-oauth ; : twitter-authorize-url ( token -- url ) - "https://twitter.com/oauth/authorize" >url + "oauth/authorize" twitter-url >url swap key>> "oauth_token" set-query-param ; : obtain-twitter-access-token ( request-token verifier -- access-token ) [ - [ "https://twitter.com/oauth/access_token" ] 2dip + [ "oauth/access_token" twitter-url ] 2dip swap >>verifier swap >>request-token @@ -52,8 +53,8 @@ MACRO: keys-boa ( keys class -- ) [ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ; ! Twitter requests -: twitter-url ( string -- url ) - "https://twitter.com/statuses/" ".json" surround ; +: status-url ( string -- url ) + "statuses/" ".json" surround twitter-url ; : set-request-twitter-auth ( request -- request ) [ set-oauth ] with-twitter-oauth ; @@ -135,7 +136,7 @@ PRIVATE> ] H{ } make-assoc ; : (tweet) ( string -- json ) - update-post-data "update" twitter-url + update-post-data "update" status-url twitter-request ; PRIVATE> @@ -149,7 +150,7 @@ PRIVATE> + status-url twitter-request json>twitter-statuses ; PRIVATE> diff --git a/extra/webapps/calculator/calculator.factor b/extra/webapps/calculator/calculator.factor index a8c8383e62..95f48109b1 100644 --- a/extra/webapps/calculator/calculator.factor +++ b/extra/webapps/calculator/calculator.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: furnace furnace.actions furnace.redirection http.server.dispatchers html.forms validators urls accessors -math ; +math kernel ; IN: webapps.calculator TUPLE: calculator < dispatcher ; @@ -39,6 +39,6 @@ USING: db.sqlite furnace.alloy namespaces http.server ; calculator-db main-responder set-global - 8080 httpd ; + 8080 httpd drop ; MAIN: run-calculator diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index 2fa9b5fb1d..a2a3d73ff6 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -38,6 +38,6 @@ USING: db.sqlite furnace.alloy namespaces ; counter-db main-responder set-global - 8080 httpd ; + 8080 httpd drop ; MAIN: run-counter diff --git a/extra/webapps/ip/ip.factor b/extra/webapps/ip/ip.factor index c2ae0f8520..d2bd1ecea7 100644 --- a/extra/webapps/ip/ip.factor +++ b/extra/webapps/ip/ip.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors furnace.actions http.server http.server.dispatchers html.forms io.sockets -namespaces prettyprint ; +namespaces prettyprint kernel ; IN: webapps.ip TUPLE: ip-app < dispatcher ; @@ -18,6 +18,6 @@ TUPLE: ip-app < dispatcher ; : run-ip-app ( -- ) main-responder set-global - 8080 httpd ; + 8080 httpd drop ; MAIN: run-ip-app diff --git a/extra/mason/server/authors.txt b/extra/webapps/mason/backend/authors.txt similarity index 100% rename from extra/mason/server/authors.txt rename to extra/webapps/mason/backend/authors.txt diff --git a/extra/webapps/mason/backend/backend-tests.factor b/extra/webapps/mason/backend/backend-tests.factor new file mode 100644 index 0000000000..000ed4024e --- /dev/null +++ b/extra/webapps/mason/backend/backend-tests.factor @@ -0,0 +1,15 @@ +USING: continuations db db.sqlite io.directories io.files.temp +webapps.mason.backend tools.test ; +IN: webapps.mason.backend.tests + +[ "test.db" temp-file delete-file ] ignore-errors + +[ 0 1 2 ] [ + "test.db" temp-file [ + init-mason-db + + counter-value + increment-counter-value + increment-counter-value + ] with-db +] unit-test diff --git a/extra/mason/server/server.factor b/extra/webapps/mason/backend/backend.factor similarity index 51% rename from extra/mason/server/server.factor rename to extra/webapps/mason/backend/backend.factor index d0fe29b917..fa01b3a2c6 100644 --- a/extra/mason/server/server.factor +++ b/extra/webapps/mason/backend/backend.factor @@ -1,18 +1,23 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: db db.sqlite db.tuples db.types kernel ; -IN: mason.server +USING: accessors calendar db db.sqlite db.tuples db.types kernel +math math.order sequences combinators.short-circuit ; +IN: webapps.mason.backend +CONSTANT: +idle+ "idle" CONSTANT: +starting+ "starting" CONSTANT: +make-vm+ "make-vm" CONSTANT: +boot+ "boot" CONSTANT: +test+ "test" -CONSTANT: +clean+ "status-clean" +CONSTANT: +upload+ "upload" +CONSTANT: +finish+ "finish" + CONSTANT: +dirty+ "status-dirty" CONSTANT: +error+ "status-error" +CONSTANT: +clean+ "status-clean" TUPLE: builder -host-name os cpu +host-name os cpu heartbeat-timestamp clean-git-id clean-timestamp last-release release-git-id last-git-id last-timestamp last-report @@ -23,13 +28,14 @@ builder "BUILDERS" { { "host-name" "HOST_NAME" TEXT +user-assigned-id+ } { "os" "OS" TEXT +user-assigned-id+ } { "cpu" "CPU" TEXT +user-assigned-id+ } - + { "heartbeat-timestamp" "HEARTBEAT_TIMESTAMP" TIMESTAMP } + { "clean-git-id" "CLEAN_GIT_ID" TEXT } { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP } { "last-release" "LAST_RELEASE" TEXT } { "release-git-id" "RELEASE_GIT_ID" TEXT } - + { "last-git-id" "LAST_GIT_ID" TEXT } { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP } { "last-report" "LAST_REPORT" TEXT } @@ -40,7 +46,38 @@ builder "BUILDERS" { { "status" "STATUS" TEXT } } define-persistent +TUPLE: counter id value ; + +counter "COUNTER" { + { "id" "ID" INTEGER +db-assigned-id+ } + { "value" "VALUE" INTEGER } +} define-persistent + +: counter-tuple ( -- counter ) + counter new select-tuple + [ counter new dup insert-tuple ] unless* ; + +: counter-value ( -- n ) + [ counter-tuple value>> 0 or ] with-transaction ; + +: increment-counter-value ( -- n ) + [ + counter-tuple [ 0 or 1 + dup ] change-value update-tuple + ] with-transaction ; + +: funny-builders ( -- crashed broken ) + builder new select-tuples + [ [ heartbeat-timestamp>> 30 minutes ago before? ] filter ] + [ [ [ clean-git-id>> ] [ last-git-id>> ] bi = not ] filter ] + bi ; + +: os/cpu ( builder -- string ) + [ os>> ] [ cpu>> ] bi "/" glue ; + : mason-db ( -- db ) "resource:mason.db" ; : with-mason-db ( quot -- ) - [ mason-db ] dip with-db ; inline + mason-db [ with-transaction ] with-db ; inline + +: init-mason-db ( -- ) + { builder counter } ensure-tables ; diff --git a/extra/mason/version/binary/authors.txt b/extra/webapps/mason/backend/watchdog/authors.txt similarity index 100% rename from extra/mason/version/binary/authors.txt rename to extra/webapps/mason/backend/watchdog/authors.txt diff --git a/extra/webapps/mason/backend/watchdog/watchdog.factor b/extra/webapps/mason/backend/watchdog/watchdog.factor new file mode 100644 index 0000000000..799c4a4f35 --- /dev/null +++ b/extra/webapps/mason/backend/watchdog/watchdog.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.parser sequences xml.syntax xml.writer +mason.email webapps.mason.backend ; +IN: webapps.mason.backend.watchdog + +: crashed-builder-body ( crashed-builders -- string content-type ) + [ os/cpu [XML
  • <->
    • XML] ] map + + +

    Machines which are not sending heartbeats:

    +
      <->
    + Dashboard + + + XML> xml>string + "text/html" ; + +: s ( n before after -- string ) + pick 1 > [ "s" append ] when + [ number>string ] 2dip surround ; + +: crashed-builder-subject ( crashed-builders -- string ) + length "Take note: " " crashed build machine" s ; + +: send-crashed-builder-email ( crashed-builders -- ) + [ crashed-builder-body ] + [ crashed-builder-subject ] bi + mason-email ; + +: check-builders ( -- ) + [ + funny-builders drop + [ send-crashed-builder-email ] unless-empty + ] with-mason-db ; diff --git a/extra/webapps/mason/counter/counter.factor b/extra/webapps/mason/counter/counter.factor new file mode 100644 index 0000000000..b0ef5a8005 --- /dev/null +++ b/extra/webapps/mason/counter/counter.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors furnace.actions http.server.responses +webapps.mason.backend math.parser ; +IN: webapps.mason.counter + +: ( -- action ) + + [ + [ + counter-value number>string + "text/plain" + ] with-mason-db + ] >>display ; diff --git a/extra/webapps/mason/dashboard.xml b/extra/webapps/mason/dashboard.xml new file mode 100644 index 0000000000..0a4908cced --- /dev/null +++ b/extra/webapps/mason/dashboard.xml @@ -0,0 +1,32 @@ + + + + Mason dashboard + +

    Crashed build machines

    +

    Machines which are not sending heartbeats:

    + + +

    Broken build machines

    +

    Machines with failing builds:

    + + +

    Force build now

    +

    Requires build engineer status.

    + + +

    +     + +

    Make a release

    +

    Requires build engineer status.

    + + + + + +
    Version:
    Announcement URL:
    + +

    +     +     diff --git a/extra/webapps/mason/dashboard/dashboard.factor b/extra/webapps/mason/dashboard/dashboard.factor new file mode 100644 index 0000000000..7a98bc881f --- /dev/null +++ b/extra/webapps/mason/dashboard/dashboard.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel furnace.actions html.forms sequences +xml.syntax webapps.mason.backend webapps.mason.utils ; +IN: webapps.mason.downloads + +: builder-list ( seq -- xml ) + [ + [ package-url ] [ os/cpu ] bi + [XML
  • ><->
    • XML] + ] map + [ [XML

    No machines.

    XML] ] + [ [XML
      <->
    XML] ] + if-empty ; + +: ( -- action ) + + [ + [ + funny-builders + [ builder-list ] tri@ + [ "crashed" set-value ] + [ "broken" set-value ] bi* + ] with-mason-db + ] >>init ; diff --git a/extra/mason/version/common/authors.txt b/extra/webapps/mason/docs-update/authors.txt similarity index 100% rename from extra/mason/version/common/authors.txt rename to extra/webapps/mason/docs-update/authors.txt diff --git a/extra/webapps/mason/docs-update/docs-update.factor b/extra/webapps/mason/docs-update/docs-update.factor new file mode 100644 index 0000000000..7b685890e7 --- /dev/null +++ b/extra/webapps/mason/docs-update/docs-update.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors continuations furnace.actions help.html +http.server.responses io.directories io.directories.hierarchy +io.launcher io.files io.pathnames kernel memoize threads +webapps.mason.utils ; +IN: webapps.mason.docs-update + +: update-docs ( -- ) + home [ + "newdocs" make-directory + "newdocs" [ { "tar" "xfz" "../docs.tar.gz" } try-process ] with-directory + + "docs" exists? [ "docs" "docs.old" move-file ] when + "newdocs/docs" "docs" move-file + + "newdocs" delete-directory + "docs.old" exists? [ "docs.old" delete-tree ] when + + \ load-index reset-memoized + ] with-directory ; + +: ( -- action ) + + [ validate-secret ] >>validate + [ + [ update-docs ] "Documentation update" spawn drop + "OK" "text/plain" + ] >>submit ; diff --git a/extra/webapps/mason/download-package.xml b/extra/webapps/mason/download-package.xml index 27102056f8..ff366fb4f4 100644 --- a/extra/webapps/mason/download-package.xml +++ b/extra/webapps/mason/download-package.xml @@ -5,39 +5,33 @@ - - - - Factor binary package for <t:label t:name="platform" /> - - -
    Logo
    + Factor binary package for -

    Factor binary package for

    +
    Logo
    -

    Requirements:

    - +

    Factor binary package for

    -

    Download

    +

    Requirements:

    + -

    This package was built from GIT ID .

    +

    Download

    -

    Once you download Factor, you can get started with the language.

    +

    This package was built from GIT ID .

    -

    Build machine information

    +

    Once you download Factor, you can start learning the language!

    - - - - - - - - -
    Host name:
    Last heartbeat:
    Current status:
    Last build:
    Last clean build:
    Binaries:
    Clean images:
    +

    Build machine information

    -

    - - + + + + + + + + +
    Host name:
    Last heartbeat:
    Current status:
    Last build:
    Last clean build:
    Binaries:
    Clean images:
    + +

    diff --git a/extra/webapps/mason/download-release.xml b/extra/webapps/mason/download-release.xml index 751bb14c77..ffb485e173 100644 --- a/extra/webapps/mason/download-release.xml +++ b/extra/webapps/mason/download-release.xml @@ -5,25 +5,19 @@ - - - - Factor binary package for <t:label t:name="platform" /> - - -
    Logo
    + Factor binary package for -

    Factor binary package for

    +
    Logo
    -

    Requirements:

    - +

    Factor binary package for

    -

    Download

    +

    Requirements:

    + -

    This release was built from GIT ID .

    +

    Download

    -

    Once you download Factor, you can get started with the language.

    - - +

    This release was built from GIT ID .

    + +

    Once you download Factor, you can start learning the language!

     diff --git a/extra/webapps/mason/downloads.xml b/extra/webapps/mason/downloads.xml index 82d6572579..60a268435e 100644 --- a/extra/webapps/mason/downloads.xml +++ b/extra/webapps/mason/downloads.xml @@ -1,8 +1,3 @@ - - - -

    Stable release:

    @@ -19,4 +14,6 @@ +

    Stable and development releases are built and uploaded by the build farm. Follow @FactorBuilds on Twitter to receive notifications. If you're curious, take a look at the build farm dashboard.

    +     diff --git a/extra/webapps/mason/downloads/downloads.factor b/extra/webapps/mason/downloads/downloads.factor index 7ff9e64f6b..de9bc21fa4 100644 --- a/extra/webapps/mason/downloads/downloads.factor +++ b/extra/webapps/mason/downloads/downloads.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors furnace.actions html.components html.forms -kernel mason.server mason.version.data webapps.mason.grids -webapps.mason.utils ; +kernel webapps.mason.backend webapps.mason.version.data +webapps.mason.grids webapps.mason.utils ; IN: webapps.mason.downloads : stable-release ( version -- link ) diff --git a/extra/webapps/mason/grids/grids.factor b/extra/webapps/mason/grids/grids.factor index d9d12ef745..dfa2cf9b4b 100644 --- a/extra/webapps/mason/grids/grids.factor +++ b/extra/webapps/mason/grids/grids.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs db.tuples furnace.actions -furnace.utilities http.server.responses kernel locals -mason.server mason.version.data sequences splitting urls -webapps.mason.utils xml.syntax xml.writer ; +furnace.utilities http.server.responses kernel locals sequences +splitting urls xml.syntax xml.writer webapps.mason.backend +webapps.mason.version.data webapps.mason.utils ; IN: webapps.mason.grids : render-grid-cell ( cpu os quot -- xml ) @@ -26,7 +26,6 @@ CONSTANT: cpus { { "x86.32" "x86" } { "x86.64" "x86-64" } - { "ppc" "PowerPC" } } : render-grid-header ( -- xml ) @@ -46,12 +45,6 @@ CONSTANT: cpus XML] ; -: package-url ( builder -- url ) - [ URL" $mason-app/package" ] dip - [ os>> "os" set-query-param ] - [ cpu>> "cpu" set-query-param ] bi - adjust-url ; - : package-date ( filename -- date ) "." split1 drop 16 tail* 6 head* ; @@ -73,12 +66,6 @@ CONSTANT: cpus ] with-mason-db ] >>display ; -: release-url ( builder -- url ) - [ URL" $mason-app/release" ] dip - [ os>> "os" set-query-param ] - [ cpu>> "cpu" set-query-param ] bi - adjust-url ; - : release-version ( filename -- release ) ".tar.gz" ?tail drop ".zip" ?tail drop ".dmg" ?tail drop "-" split1-last nip ; diff --git a/extra/webapps/mason/increment-counter/increment-counter.factor b/extra/webapps/mason/increment-counter/increment-counter.factor new file mode 100644 index 0000000000..8cc6be0aad --- /dev/null +++ b/extra/webapps/mason/increment-counter/increment-counter.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors furnace.actions math.parser +http.server.responses webapps.mason.backend ; +IN: webapps.mason.increment-counter + +: ( -- action ) + + [ + [ + increment-counter-value + number>string "text/plain" + ] with-mason-db + ] >>submit ; diff --git a/extra/webapps/mason/make-release.xml b/extra/webapps/mason/make-release.xml deleted file mode 100644 index 7143d819ab..0000000000 --- a/extra/webapps/mason/make-release.xml +++ /dev/null @@ -1,24 +0,0 @@ - - - - - - - - - Make release - - - - - - -
    Version:
    Announcement URL:
    - -

    -     - - - -     diff --git a/extra/webapps/mason/make-release/make-release.factor b/extra/webapps/mason/make-release/make-release.factor index e7cd13a895..e0b4c13a1a 100644 --- a/extra/webapps/mason/make-release/make-release.factor +++ b/extra/webapps/mason/make-release/make-release.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors furnace.actions html.forms -http.server.responses mason.server mason.version validators ; +http.server.responses validators webapps.mason.backend +webapps.mason.version ; IN: webapps.mason.make-release : ( -- action ) - + [ { { "version" [ v-one-line ] } diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor index 81eb36a17d..06f09af6ed 100644 --- a/extra/webapps/mason/mason.factor +++ b/extra/webapps/mason/mason.factor @@ -1,17 +1,24 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors furnace.auth furnace.db -http.server.dispatchers mason.server webapps.mason.grids -webapps.mason.make-release webapps.mason.package -webapps.mason.release webapps.mason.report -webapps.mason.downloads webapps.mason.status-update ; +USING: accessors furnace.actions furnace.auth furnace.db +http.server.dispatchers webapps.mason.backend webapps.mason.grids +webapps.mason.package webapps.mason.release webapps.mason.report +webapps.mason.downloads webapps.mason.counter +webapps.mason.status-update webapps.mason.docs-update +webapps.mason.dashboard webapps.mason.make-release +webapps.mason.increment-counter ; IN: webapps.mason TUPLE: mason-app < dispatcher ; -SYMBOL: can-make-releases? +SYMBOL: build-engineer? -can-make-releases? define-capability +build-engineer? define-capability + +: ( responder -- responder' ) + + "access the build farm dashboard" >>description + { build-engineer? } >>capabilities ; : ( -- dispatcher ) mason-app new-dispatcher @@ -30,12 +37,24 @@ can-make-releases? define-capability { mason-app "downloads" } >>template "downloads" add-responder - - { mason-app "make-release" } >>template - - "make releases" >>description - { can-make-releases? } >>capabilities - "make-release" add-responder - - "status-update" add-responder ; + "status-update" add-responder + + + "docs-update" add-responder + + + "counter" add-responder + + + + { mason-app "dashboard" } >>template + "" add-responder + + + "make-release" add-responder + + + "increment-counter" add-responder + + "dashboard" add-responder ; diff --git a/extra/webapps/mason/package/package.factor b/extra/webapps/mason/package/package.factor index 504ba7093f..224c586f2f 100644 --- a/extra/webapps/mason/package/package.factor +++ b/extra/webapps/mason/package/package.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators furnace.actions html.forms -kernel mason.platform mason.report mason.server present -sequences webapps.mason webapps.mason.report webapps.mason.utils -xml.syntax ; -FROM: mason.version.files => platform ; +kernel xml.syntax mason.platform mason.report present +sequences webapps.mason webapps.mason.report +webapps.mason.backend webapps.mason.utils ; +FROM: webapps.mason.version.files => platform ; IN: webapps.mason.package : building ( builder string -- xml ) @@ -13,13 +13,16 @@ IN: webapps.mason.package : status-string ( builder -- string ) dup status>> { - { +dirty+ [ drop "Dirty" ] } - { +clean+ [ drop "Clean" ] } - { +error+ [ drop "Error" ] } + { +idle+ [ drop "Idle" ] } { +starting+ [ "Starting build" building ] } { +make-vm+ [ "Compiling VM" building ] } { +boot+ [ "Bootstrapping" building ] } { +test+ [ "Testing" building ] } + { +upload+ [ "Uploading package" building ] } + { +finish+ [ "Finishing build" building ] } + { +dirty+ [ drop "Dirty" ] } + { +clean+ [ drop "Clean" ] } + { +error+ [ drop "Error" ] } [ 2drop "Unknown" ] } case ; @@ -63,6 +66,7 @@ IN: webapps.mason.package [ release-git-id>> git-link "git-id" set-value ] [ requirements "requirements" set-value ] [ host-name>> "host-name" set-value ] + [ heartbeat-timestamp>> "heartbeat-timestamp" set-value ] [ current-status "status" set-value ] [ last-build-status "last-build" set-value ] [ clean-build-status "last-clean-build" set-value ] diff --git a/extra/webapps/mason/release/release.factor b/extra/webapps/mason/release/release.factor index 98fa42b68c..b20a115777 100644 --- a/extra/webapps/mason/release/release.factor +++ b/extra/webapps/mason/release/release.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors furnace.actions html.forms kernel -mason.platform mason.report mason.server sequences webapps.mason -webapps.mason.utils io.pathnames ; +USING: accessors furnace.actions html.forms io.pathnames kernel +mason.platform mason.report sequences webapps.mason +webapps.mason.backend webapps.mason.utils ; IN: webapps.mason.release : release-link ( builder -- xml ) diff --git a/extra/webapps/mason/report/report.factor b/extra/webapps/mason/report/report.factor index 291ccb9bdb..64511d7f05 100644 --- a/extra/webapps/mason/report/report.factor +++ b/extra/webapps/mason/report/report.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors furnace.actions http.server.responses kernel -urls mason.server webapps.mason.utils xml.syntax ; +urls xml.syntax webapps.mason.backend webapps.mason.utils ; IN: webapps.mason.report : ( -- action ) diff --git a/extra/webapps/mason/status-update/status-update.factor b/extra/webapps/mason/status-update/status-update.factor index 5156b1ef70..668db6ebd3 100644 --- a/extra/webapps/mason/status-update/status-update.factor +++ b/extra/webapps/mason/status-update/status-update.factor @@ -2,27 +2,41 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors calendar combinators db.tuples furnace.actions furnace.redirection html.forms http.server.responses io kernel -mason.config mason.server namespaces validators ; +namespaces validators webapps.mason.utils webapps.mason.backend ; IN: webapps.mason.status-update -: find-builder ( -- builder ) +: find-builder ( host-name os cpu -- builder ) builder new - "host-name" value >>host-name - "target-os" value >>os - "target-cpu" value >>cpu + swap >>cpu + swap >>os + swap >>host-name dup select-tuple [ ] [ dup insert-tuple ] ?if ; -: git-id ( builder id -- ) >>current-git-id +starting+ >>status drop ; +: heartbeat ( builder -- ) + now >>heartbeat-timestamp + drop ; -: make-vm ( builder -- ) +make-vm+ >>status drop ; +: status ( builder status -- ) + >>status + now >>current-timestamp + drop ; -: boot ( builder -- ) +boot+ >>status drop ; +: idle ( builder -- ) +idle+ status ; -: test ( builder -- ) +test+ >>status drop ; +: git-id ( builder id -- ) >>current-git-id +starting+ status ; -: report ( builder status content -- ) - [ >>status ] [ >>last-report ] bi* - dup status>> +clean+ = [ +: make-vm ( builder -- ) +make-vm+ status ; + +: boot ( builder -- ) +boot+ status ; + +: test ( builder -- ) +test+ status ; + +: report ( builder content status -- ) + [ + >>last-report + now >>current-timestamp + ] dip + +clean+ = [ dup current-git-id>> >>clean-git-id dup current-timestamp>> >>clean-timestamp ] when @@ -30,6 +44,10 @@ IN: webapps.mason.status-update dup current-timestamp>> >>last-timestamp drop ; +: upload ( builder -- ) +upload+ status ; + +: finish ( builder -- ) +finish+ status ; + : release ( builder name -- ) >>last-release dup clean-git-id>> >>release-git-id @@ -37,12 +55,15 @@ IN: webapps.mason.status-update : update-builder ( builder -- ) "message" value { - { "heartbeat" [ drop ] } + { "heartbeat" [ heartbeat ] } + { "idle" [ idle ] } { "git-id" [ "arg" value git-id ] } { "make-vm" [ make-vm ] } { "boot" [ boot ] } { "test" [ test ] } - { "report" [ "arg" value "report" value report ] } + { "report" [ "report" value "arg" value report ] } + { "upload" [ upload ] } + { "finish" [ finish ] } { "release" [ "arg" value release ] } } case ; @@ -56,19 +77,18 @@ IN: webapps.mason.status-update { "message" [ v-one-line ] } { "arg" [ [ v-one-line ] v-optional ] } { "report" [ ] } - { "secret" [ v-one-line ] } } validate-params - "secret" value status-secret get = [ validation-failed ] unless + validate-secret ] >>validate [ [ - [ - find-builder - now >>current-timestamp - [ update-builder ] [ update-tuple ] bi - ] with-mason-db - "OK" "text/html" - ] if-secure + "host-name" value + "target-os" value + "target-cpu" value + find-builder + [ update-builder ] [ update-tuple ] bi + ] with-mason-db + "OK" "text/plain" ] >>submit ; diff --git a/extra/webapps/mason/utils/utils.factor b/extra/webapps/mason/utils/utils.factor index ad56737bc1..05435893f5 100644 --- a/extra/webapps/mason/utils/utils.factor +++ b/extra/webapps/mason/utils/utils.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs db.tuples furnace.actions -html.forms kernel mason.server mason.version.data sequences -validators xml.syntax ; +furnace.utilities html.forms kernel namespaces sequences +validators xml.syntax urls mason.config +webapps.mason.version.data webapps.mason.backend ; IN: webapps.mason.utils : link ( url label -- xml ) @@ -41,3 +42,20 @@ IN: webapps.mason.utils : download-url ( string -- string' ) "http://downloads.factorcode.org/" prepend ; + +: package-url ( builder -- url ) + [ URL" $mason-app/package" ] dip + [ os>> "os" set-query-param ] + [ cpu>> "cpu" set-query-param ] bi + adjust-url ; + +: release-url ( builder -- url ) + [ URL" $mason-app/release" ] dip + [ os>> "os" set-query-param ] + [ cpu>> "cpu" set-query-param ] bi + adjust-url ; + +: validate-secret ( -- ) + { { "secret" [ v-one-line ] } } validate-params + "secret" value status-secret get = + [ validation-failed ] unless ; diff --git a/extra/mason/version/data/authors.txt b/extra/webapps/mason/version/authors.txt similarity index 100% rename from extra/mason/version/data/authors.txt rename to extra/webapps/mason/version/authors.txt diff --git a/extra/mason/version/files/authors.txt b/extra/webapps/mason/version/binary/authors.txt similarity index 100% rename from extra/mason/version/files/authors.txt rename to extra/webapps/mason/version/binary/authors.txt diff --git a/extra/mason/version/binary/binary.factor b/extra/webapps/mason/version/binary/binary.factor similarity index 81% rename from extra/mason/version/binary/binary.factor rename to extra/webapps/mason/version/binary/binary.factor index 5273b644ee..239011c8f1 100644 --- a/extra/mason/version/binary/binary.factor +++ b/extra/webapps/mason/version/binary/binary.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel make mason.version.common mason.version.files -sequences ; -IN: mason.version.binary +USING: io kernel make sequences webapps.mason.version.common +webapps.mason.version.files ; +IN: webapps.mason.version.binary : binary-release-command ( version builder -- command ) [ diff --git a/extra/mason/version/source/authors.txt b/extra/webapps/mason/version/common/authors.txt similarity index 100% rename from extra/mason/version/source/authors.txt rename to extra/webapps/mason/version/common/authors.txt diff --git a/extra/mason/version/common/common.factor b/extra/webapps/mason/version/common/common.factor similarity index 92% rename from extra/mason/version/common/common.factor rename to extra/webapps/mason/version/common/common.factor index 65d01c3f71..035cee92ca 100644 --- a/extra/mason/version/common/common.factor +++ b/extra/webapps/mason/version/common/common.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors calendar io io.encodings.ascii io.launcher kernel make mason.config namespaces ; -IN: mason.version.common +IN: webapps.mason.version.common : execute-on-server ( string -- ) [ "ssh" , upload-host get , "-l" , upload-username get , ] { } make diff --git a/unmaintained/ce/files/authors.txt b/extra/webapps/mason/version/data/authors.txt old mode 100755 new mode 100644 similarity index 50% rename from unmaintained/ce/files/authors.txt rename to extra/webapps/mason/version/data/authors.txt index 5674120196..1901f27a24 --- a/unmaintained/ce/files/authors.txt +++ b/extra/webapps/mason/version/data/authors.txt @@ -1,2 +1 @@ -Doug Coleman Slava Pestov diff --git a/extra/mason/version/data/data.factor b/extra/webapps/mason/version/data/data.factor similarity index 95% rename from extra/mason/version/data/data.factor rename to extra/webapps/mason/version/data/data.factor index eb735c918c..579c91b951 100644 --- a/extra/mason/version/data/data.factor +++ b/extra/webapps/mason/version/data/data.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors calendar db db.tuples db.types kernel locals -mason.version.files sequences ; -IN: mason.version.data +webapps.mason.version.files sequences ; +IN: webapps.mason.version.data TUPLE: release host-name os cpu diff --git a/unmaintained/ce/sockets/authors.txt b/extra/webapps/mason/version/files/authors.txt old mode 100755 new mode 100644 similarity index 50% rename from unmaintained/ce/sockets/authors.txt rename to extra/webapps/mason/version/files/authors.txt index 5674120196..1901f27a24 --- a/unmaintained/ce/sockets/authors.txt +++ b/extra/webapps/mason/version/files/authors.txt @@ -1,2 +1 @@ -Doug Coleman Slava Pestov diff --git a/extra/mason/version/files/files.factor b/extra/webapps/mason/version/files/files.factor similarity index 97% rename from extra/mason/version/files/files.factor rename to extra/webapps/mason/version/files/files.factor index 6e762e5af2..d86c57bd38 100644 --- a/extra/mason/version/files/files.factor +++ b/extra/webapps/mason/version/files/files.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors fry kernel make mason.config mason.platform mason.release.archive namespaces sequences ; -IN: mason.version.files +IN: webapps.mason.version.files : release-directory ( string version -- string ) [ "releases/" % % "/" % % ] "" make ; diff --git a/extra/webapps/mason/version/source/authors.txt b/extra/webapps/mason/version/source/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/mason/version/source/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/mason/version/source/source.factor b/extra/webapps/mason/version/source/source.factor similarity index 76% rename from extra/mason/version/source/source.factor rename to extra/webapps/mason/version/source/source.factor index 13bd0cffd9..7050950614 100644 --- a/extra/mason/version/source/source.factor +++ b/extra/webapps/mason/version/source/source.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image bootstrap.image.download io io.directories io.directories.hierarchy io.files.unique -io.launcher io.pathnames kernel mason.common mason.config -mason.version.files namespaces sequences ; -IN: mason.version.source +io.launcher io.pathnames kernel namespaces sequences +mason.common mason.config webapps.mason.version.files ; +IN: webapps.mason.version.source : clone-factor ( -- ) { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ; @@ -20,7 +20,7 @@ IN: mason.version.source ".gitignore" delete-file ; : download-images ( -- ) - images [ download-image ] each ; + images [ boot-image-name download-image ] each ; : prepare-source ( git-id -- ) "factor" [ @@ -36,8 +36,10 @@ IN: mason.version.source : make-source-release ( version git-id -- path ) "Creating source release..." print flush [ - clone-factor prepare-source (make-source-release) - "Package created: " write absolute-path dup print + current-temporary-directory get [ + clone-factor prepare-source (make-source-release) + "Package created: " write absolute-path dup print + ] with-directory ] with-unique-directory drop ; : upload-source-release ( package version -- ) diff --git a/extra/mason/version/version.factor b/extra/webapps/mason/version/version.factor similarity index 83% rename from extra/mason/version/version.factor rename to extra/webapps/mason/version/version.factor index bb0fcbf2c3..cdb4ebb5f9 100644 --- a/extra/mason/version/version.factor +++ b/extra/webapps/mason/version/version.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors bit.ly combinators db.tuples debugger fry -grouping io io.streams.string kernel locals make mason.email -mason.server mason.twitter mason.version.binary -mason.version.common mason.version.data mason.version.files -mason.version.source sequences threads ; -IN: mason.version +grouping io io.streams.string kernel locals make sequences +threads mason.email mason.twitter webapps.mason.backend +webapps.mason.version.common webapps.mason.version.data +webapps.mason.version.files webapps.mason.version.source +webapps.mason.version.binary ; +IN: webapps.mason.version : check-releases ( builders -- ) [ release-git-id>> ] map all-equal? diff --git a/extra/webapps/site-watcher/site-watcher.factor b/extra/webapps/site-watcher/site-watcher.factor index 5ecd3bc6a8..05fabfcf9d 100644 --- a/extra/webapps/site-watcher/site-watcher.factor +++ b/extra/webapps/site-watcher/site-watcher.factor @@ -90,4 +90,4 @@ M: site-watcher-app init-user-profile : start-site-watcher ( -- ) init-db site-watcher-db run-site-watcher - start-server ; + start-server drop ; diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor index 4f6edee031..e5753f3c53 100644 --- a/extra/webapps/todo/todo.factor +++ b/extra/webapps/todo/todo.factor @@ -162,6 +162,6 @@ io.sockets.secure ; : run-todo ( -- ) main-responder set-global todo-db start-expiring - start-server ; + start-server drop ; MAIN: run-todo diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index c0cd601af5..700cf56e20 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors namespaces combinators words -assocs db.tuples arrays splitting strings validators urls +assocs db.tuples arrays splitting strings validators urls fry html.forms html.components furnace @@ -158,8 +158,10 @@ can-administer-users? define-capability "administer users" >>description { can-administer-users? } >>capabilities ; -: make-admin ( username -- ) - - select-tuple - [ can-administer-users? suffix ] change-capabilities +: give-capability ( username capability -- ) + [ select-tuple ] dip + '[ _ suffix ] change-capabilities update-tuple ; + +: make-admin ( username -- ) + can-administer-users? give-capability ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index f3a3784465..a150a6505b 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -225,7 +225,7 @@ M: revision feed-entry-url id>> revision-url ; [ list-revisions ] >>entries ; : rollback-description ( description -- description' ) - [ "Rollback of '" "'" surround ] [ "Rollback" ] if* ; + [ "Rollback to '" "'" surround ] [ "Rollback" ] if* ; : ( -- action ) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index efa4c4b635..35e4150ba9 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -25,12 +25,15 @@ webapps.planet webapps.wiki webapps.user-admin webapps.help -webapps.mason ; +webapps.mason +webapps.mason.backend ; IN: websites.concatenative : test-db ( -- db ) "resource:test.db" ; : init-factor-db ( -- ) + mason-db [ init-mason-db ] with-db + test-db [ init-furnace-tables @@ -86,7 +89,7 @@ SYMBOL: dh-file "user-admin" add-responder "pastebin" add-responder "planet" add-responder - "mason" add-responder + "mason" add-responder "/tmp/docs/" "docs" add-responder test-db main-responder set-global ; @@ -105,7 +108,7 @@ SYMBOL: dh-file test-db "concatenative.org" add-responder test-db "paste.factorcode.org" add-responder test-db "planet.factorcode.org" add-responder - test-db "builds.factorcode.org" add-responder + test-db "builds.factorcode.org" add-responder home "docs" append-path "docs.factorcode.org" add-responder home "cgi" append-path "gitweb.factorcode.org" add-responder main-responder set-global ; @@ -122,7 +125,7 @@ SYMBOL: dh-file 8080 >>insecure 8431 >>secure ; -: start-website ( -- ) +: start-website ( -- server ) test-db start-expiring test-db start-update-task http-insomniac diff --git a/misc/fuel/README b/misc/fuel/README index ccaa7a676a..e952176f2c 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -89,74 +89,74 @@ beast. * Quick key reference Triple chords ending in a single letter accept also C- (e.g. - C-cC-eC-r is the same as C-cC-er). + C-c C-e C-r is the same as C-c C-e r). *** In factor source files: Commands in parenthesis can be invoked interactively with M-x , not necessarily in a factor buffer. - |-----------------+------------------------------------------------------------| - | C-cz | switch to listener (run-factor) | - | C-co | cycle between code, tests and docs files | - | C-ct | run the unit tests for a vocabulary | - | C-cr | switch to listener and refresh all loaded vocabs | - | C-cs | switch to other factor buffer (fuel-switch-to-buffer) | - | C-x4s | switch to other factor buffer in other window | - | C-x5s | switch to other factor buffer in other frame | - |-----------------+------------------------------------------------------------| - | M-. | edit word at point in Emacs (fuel-edit-word) | - | M-, | go back to where M-. was last invoked | - | M-TAB | complete word at point | - | C-cC-eu | update USING: line (fuel-update-usings) | - | C-cC-ev | edit vocabulary (fuel-edit-vocabulary) | - | C-cC-ew | edit word (fuel-edit-word-at-point) | - | C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) | - | C-cC-el | load vocabs in USING: form | - |-----------------+------------------------------------------------------------| - | C-cC-er | eval region | - | C-M-r, C-cC-ee | eval region, extending it to definition boundaries | - | C-M-x, C-cC-ex | eval definition around point | - | C-ck, C-cC-ek | run file (fuel-run-file) | - |-----------------+------------------------------------------------------------| - | C-cC-da | toggle autodoc mode (fuel-autodoc-mode) | - | C-cC-dd | help for word at point (fuel-help) | - | C-cC-ds | short help word at point (fuel-help-short) | - | C-cC-de | show stack effect of current sexp (with prefix, region) | - | C-cC-dp | find words containing given substring (fuel-apropos) | - | C-cC-dv | show words in current file (with prefix, ask for vocab) | - |-----------------+------------------------------------------------------------| - | C-cM-<, C-cC-d< | show callers of word or vocabulary at point | - | | (fuel-show-callers, fuel-vocab-usage) | - | C-cM->, C-cC-d> | show callees of word or vocabulary at point | - | | (fuel-show-callees, fuel-vocab-uses) | - |-----------------+------------------------------------------------------------| - | C-cC-xs | extract innermost sexp (up to point) as a separate word | - | | (fuel-refactor-extract-sexp) | - | C-cC-xr | extract region as a separate word | - | | (fuel-refactor-extract-region) | - | C-cC-xv | extract region as a separate vocabulary | - | | (fuel-refactor-extract-vocab) | - | C-cC-xi | replace word by its definition (fuel-refactor-inline-word) | - | C-cC-xw | rename all uses of a word (fuel-refactor-rename-word) | - | C-cC-xa | extract region as a separate ARTICLE: form | - | C-cC-xg | convert current word definition into GENERIC + method | - | | (fuel-refactor-make-generic) | - |-----------------+------------------------------------------------------------| + |--------------------+------------------------------------------------------------| + | C-c C-z | switch to listener (run-factor) | + | C-c C-o | cycle between code, tests and docs files | + | C-c C-t | run the unit tests for a vocabulary | + | C-c C-r | switch to listener and refresh all loaded vocabs | + | C-c C-s | switch to other factor buffer (fuel-switch-to-buffer) | + | C-x 4 s | switch to other factor buffer in other window | + | C-x 5 s | switch to other factor buffer in other frame | + |--------------------+------------------------------------------------------------| + | M-. | edit word at point in Emacs (fuel-edit-word) | + | M-, | go back to where M-. was last invoked | + | M-TAB | complete word at point | + | C-c C-e u | update USING: line (fuel-update-usings) | + | C-c C-e v | edit vocabulary (fuel-edit-vocabulary) | + | C-c C-e w | edit word (fuel-edit-word-at-point) | + | C-c C-e d | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) | + | C-c C-e l | load vocabs in USING: form | + |--------------------+------------------------------------------------------------| + | C-c C-e r | eval region | + | C-M-r, C-c C-e e | eval region, extending it to definition boundaries | + | C-M-x, C-c C-e x | eval definition around point | + | C-c C-k, C-c C-e k | run file (fuel-run-file) | + |--------------------+------------------------------------------------------------| + | C-c C-d a | toggle autodoc mode (fuel-autodoc-mode) | + | C-c C-d d | help for word at point (fuel-help) | + | C-c C-d s | short help word at point (fuel-help-short) | + | C-c C-d e | show stack effect of current sexp (with prefix, region) | + | C-c C-d p | find words containing given substring (fuel-apropos) | + | C-c C-d v | show words in current file (with prefix, ask for vocab) | + |--------------------+------------------------------------------------------------| + | C-c M-< | show callers of word or vocabulary at point | + | | (fuel-show-callers, fuel-vocab-usage) | + | C-c M-> | show callees of word or vocabulary at point | + | | (fuel-show-callees, fuel-vocab-uses) | + |--------------------+------------------------------------------------------------| + | C-c C-x s | extract innermost sexp (up to point) as a separate word | + | | (fuel-refactor-extract-sexp) | + | C-c C-x r | extract region as a separate word | + | | (fuel-refactor-extract-region) | + | C-c C-x v | extract region as a separate vocabulary | + | | (fuel-refactor-extract-vocab) | + | C-c C-x i | replace word by its definition (fuel-refactor-inline-word) | + | C-c C-x w | rename all uses of a word (fuel-refactor-rename-word) | + | C-c C-x a | extract region as a separate ARTICLE: form | + | C-c C-x g | convert current word definition into GENERIC + method | + | | (fuel-refactor-make-generic) | + |--------------------+------------------------------------------------------------| *** In the listener: - |------+----------------------------------------------------------| - | TAB | complete word at point | - | M-. | edit word at point in Emacs | - | C-cr | refresh all loaded vocabs | - | C-ca | toggle autodoc mode | - | C-cp | find words containing given substring (M-x fuel-apropos) | - | C-cs | toggle stack mode | - | C-cv | edit vocabulary | - | C-ch | help for word at point | - | C-ck | run file | - |------+----------------------------------------------------------| + |---------+----------------------------------------------------------| + | TAB | complete word at point | + | M-. | edit word at point in Emacs | + | C-c C-r | refresh all loaded vocabs | + | C-c C-a | toggle autodoc mode | + | C-c C-p | find words containing given substring (M-x fuel-apropos) | + | C-c C-s | toggle stack mode | + | C-c C-v | edit vocabulary | + | C-c C-w | help for word at point | + | C-c C-k | run file | + |---------+----------------------------------------------------------| *** In the debugger (it pops up upon eval/compilation errors): @@ -174,9 +174,9 @@ beast. | v | help for a vocabulary | | a | find words containing given substring (M-x fuel-apropos) | | e | edit current article | - | ba | bookmark current page | - | bb | display bookmarks | - | bd | delete bookmark at point | + | b a | bookmark current page | + | b b | display bookmarks | + | b d | delete bookmark at point | | n/p | next/previous page | | l | previous page | | SPC/S-SPC | scroll up/down | @@ -185,7 +185,7 @@ beast. | r | refresh page | | c | clean browsing history | | M-. | edit word at point in Emacs | - | C-cz | switch to listener | + | C-c C-z | switch to listener | | q | bury buffer | |-----------+----------------------------------------------------------| diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index c26abab997..c461b5fe94 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -1,6 +1,6 @@ ;;; factor-mode.el -- mode for editing Factor source -;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009, 2010 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -271,7 +271,6 @@ With prefix, non-existing files will be created." (define-key map [?\]] 'factor-mode--insert-and-indent) (define-key map [?}] 'factor-mode--insert-and-indent) (define-key map "\C-m" 'newline-and-indent) - (define-key map "\C-co" 'factor-mode-visit-other-file) (define-key map "\C-c\C-o" 'factor-mode-visit-other-file) map)) diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index 611884e087..07da0d2d3c 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -1,6 +1,6 @@ ;;; fuel-debug.el -- debugging factor code -;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009, 2010 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -17,6 +17,7 @@ (require 'fuel-eval) (require 'fuel-popup) (require 'fuel-font-lock) +(require 'fuel-menu) (require 'fuel-base) @@ -314,11 +315,6 @@ the debugger." (defvar fuel-debug-mode-map (let ((map (make-keymap))) (suppress-keymap map) - (define-key map "g" 'fuel-debug-goto-error) - (define-key map "\C-c\C-c" 'fuel-debug-goto-error) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - (define-key map "u" 'fuel-debug-update-usings) (dotimes (n 9) (define-key map (vector (+ ?1 n)) `(lambda () (interactive) @@ -328,6 +324,12 @@ the debugger." `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci))))) map)) +(fuel-menu--defmenu fuel-debug fuel-debug-mode-map + ("Go to error" ("g" "\C-c\C-c") fuel-debug-goto-error) + ("Next line" "n" next-line) + ("Previous line" "p" previous-line) + ("Update USINGs" "u" fuel-debug-update-usings)) + (defun fuel-debug-mode () "A major mode for displaying Factor's compilation results and invoking restarts as needed. diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index cfc8cab7f1..5edcea651f 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -1,6 +1,6 @@ ;;; fuel-help.el -- accessing Factor's help system -;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009, 2010 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -22,6 +22,7 @@ (require 'fuel-syntax) (require 'fuel-font-lock) (require 'fuel-popup) +(require 'fuel-menu) (require 'fuel-base) (require 'button) @@ -314,26 +315,31 @@ With prefix, the current page is deleted from history." (let ((map (make-sparse-keymap))) (suppress-keymap map) (set-keymap-parent map button-buffer-map) - (define-key map "a" 'fuel-apropos) - (define-key map "ba" 'fuel-help-bookmark-page) - (define-key map "bb" 'fuel-help-display-bookmarks) - (define-key map "bd" 'fuel-help-delete-bookmark) - (define-key map "c" 'fuel-help-clean-history) - (define-key map "e" 'fuel-help-edit) - (define-key map "h" 'fuel-help) - (define-key map "k" 'fuel-help-kill-page) - (define-key map "n" 'fuel-help-next) - (define-key map "l" 'fuel-help-previous) - (define-key map "p" 'fuel-help-previous) - (define-key map "r" 'fuel-help-refresh) - (define-key map "v" 'fuel-help-vocab) - (define-key map (kbd "SPC") 'scroll-up) - (define-key map (kbd "S-SPC") 'scroll-down) - (define-key map "\M-." 'fuel-edit-word-at-point) - (define-key map "\C-cz" 'run-factor) - (define-key map "\C-c\C-z" 'run-factor) map)) +(fuel-menu--defmenu fuel-help fuel-help-mode-map + ("Help on word..." "h" fuel-help) + ("Help on vocab..." "v" fuel-help-vocab) + ("Apropos..." "a" fuel-apropos) + -- + ("Bookmark this page" "ba" fuel-help-bookmark-page) + ("Delete bookmark" "bd" fuel-help-delete-bookmark) + ("Show bookmarks..." "bb" fuel-help-display-bookmarks) + ("Clean browsing history" "c" fuel-help-clean-history) + -- + ("Edit word at point" "\M-." fuel-edit-word-at-point) + ("Edit help file" "e" fuel-help-edit) + -- + ("Next page" "n" fuel-help-next) + ("Previous page" ("p" "l") fuel-help-previous) + ("Refresh page" "r" fuel-help-refresh) + ("Kill page" "k" fuel-help-kill-page) + -- + ("Scroll page up" ((kbd "SPC")) scroll-up) + ("Scroll page down" ((kbd "S-SPC")) scroll-down) + -- + ("Switch to listener" "\C-c\C-z" run-factor)) + ;;; IN: support diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index 485d97e81f..d9c3a0d16f 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -1,6 +1,6 @@ ;;; fuel-listener.el --- starting the fuel listener -;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009, 2010 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -19,6 +19,7 @@ (require 'fuel-eval) (require 'fuel-connection) (require 'fuel-syntax) +(require 'fuel-menu) (require 'fuel-base) (require 'comint) @@ -69,6 +70,11 @@ buffer." :type 'integer :group 'fuel-listener) +(defcustom fuel-listener-prompt-read-only-p t + "Whether listener's prompt should be read-only." + :type 'boolean + :group 'fuel-listener) + ;;; Listener history: @@ -79,14 +85,17 @@ buffer." (comint-write-input-ring) (when (buffer-name (current-buffer)) (insert "\nBye bye. It's been nice listening to you!\n") - (insert "Press C-cz to bring me back.\n" )))))) + (insert "Press C-c C-z to bring me back.\n" )))))) (defun fuel-listener--history-setup () - (set (make-local-variable 'comint-input-ring-file-name) fuel-listener-history-filename) - (set (make-local-variable 'comint-input-ring-size) fuel-listener-history-size) + (set (make-local-variable 'comint-input-ring-file-name) + fuel-listener-history-filename) + (set (make-local-variable 'comint-input-ring-size) + fuel-listener-history-size) (add-hook 'kill-buffer-hook 'comint-write-input-ring nil t) (comint-read-input-ring t) - (set-process-sentinel (get-buffer-process (current-buffer)) 'fuel-listener--sentinel)) + (set-process-sentinel (get-buffer-process (current-buffer)) + 'fuel-listener--sentinel)) ;;; Fuel listener buffer/process: @@ -235,24 +244,30 @@ the vocabulary name." "Major mode for interacting with an inferior Factor listener process. \\{fuel-listener-mode-map}" (set (make-local-variable 'comint-prompt-regexp) fuel-con--prompt-regex) - (set (make-local-variable 'comint-use-prompt-regexp) t) - (set (make-local-variable 'comint-prompt-read-only) t) + (set (make-local-variable 'comint-use-prompt-regexp) nil) + (set (make-local-variable 'comint-prompt-read-only) + fuel-listener-prompt-read-only-p) (fuel-listener--setup-completion) (fuel-listener--setup-stack-mode)) -(define-key fuel-listener-mode-map "\C-cz" 'run-factor) -(define-key fuel-listener-mode-map "\C-c\C-z" 'run-factor) (define-key fuel-listener-mode-map "\C-a" 'fuel-listener--bol) -(define-key fuel-listener-mode-map "\C-ca" 'fuel-autodoc-mode) -(define-key fuel-listener-mode-map "\C-ch" 'fuel-help) -(define-key fuel-listener-mode-map "\C-cr" 'fuel-refresh-all) -(define-key fuel-listener-mode-map "\C-cs" 'fuel-stack-mode) -(define-key fuel-listener-mode-map "\C-cp" 'fuel-apropos) -(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point) -(define-key fuel-listener-mode-map "\C-cv" 'fuel-edit-vocabulary) -(define-key fuel-listener-mode-map "\C-c\C-v" 'fuel-edit-vocabulary) -(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file) -(define-key fuel-listener-mode-map (kbd "TAB") 'fuel-completion--complete-symbol) + +(fuel-menu--defmenu listener fuel-listener-mode-map + ("Complete symbol" ((kbd "TAB") (kbd "M-TAB")) + fuel-completion--complete-symbol :enable (symbol-at-point)) + ("Edit word definition" "\M-." fuel-edit-word-at-point + :enable (symbol-at-point)) + ("Edit vocabulary" "\C-c\C-v" fuel-edit-vocabulary) + -- + ("Word help" "\C-c\C-w" fuel-help) + ("Apropos" "\C-c\C-p" fuel-apropos) + (mode "Autodoc mode" "\C-c\C-a" fuel-autodoc-mode) + (mode "Show stack mode" "\C-c\C-s" fuel-stack-mode) + -- + ("Run file" "\C-c\C-k" fuel-run-file) + ("Refresh vocabs" "\C-c\C-r" fuel-refresh-all)) + +(define-key fuel-listener-mode-map [menu-bar completion] 'undefined) (provide 'fuel-listener) diff --git a/misc/fuel/fuel-menu.el b/misc/fuel/fuel-menu.el new file mode 100644 index 0000000000..6abcd82172 --- /dev/null +++ b/misc/fuel/fuel-menu.el @@ -0,0 +1,102 @@ +;;; fuel-menu.el -- menu utilities + +;; Copyright (c) 2010 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Sat Jun 12, 2010 03:01 + + +(require 'fuel-base) + + +;;; Top-level menu + +(defmacro fuel-menu--add-item (keymap map kd) + (cond ((or (eq '-- kd) (eq 'line kd)) `(fuel-menu--add-line ,map)) + ((stringp (car kd)) `(fuel-menu--add-basic-item ,keymap ,map ,kd)) + ((eq 'menu (car kd)) `(fuel-menu--add-submenu ,(cadr kd) + ,keymap ,map ,(cddr kd))) + ((eq 'custom (car kd)) `(fuel-menu--add-custom ,(nth 1 kd) + ,(nth 2 kd) + ,keymap + ,map)) + ((eq 'mode (car kd)) `(fuel-menu--mode-toggle ,(nth 1 kd) + ,(nth 2 kd) + ,(nth 3 kd) + ,keymap + ,map)) + (t (error "Bad item form: %s" kd)))) + +(defmacro fuel-menu--add-basic-item (keymap map kd) + (let* ((title (nth 0 kd)) + (binding (nth 1 kd)) + (cmd (nth 2 kd)) + (hlp (nth 3 kd)) + (item (make-symbol title)) + (hlp (and (stringp hlp) (list :help hlp))) + (rest (or (and hlp (nthcdr 4 kd)) + (nthcdr 3 kd))) + (binding (if (listp binding) + binding + (list binding)))) + `(progn (define-key ,map [,item] + '(menu-item ,title ,cmd ,@hlp ,@rest)) + ,@(and (car binding) + `((put ',cmd + :advertised-binding + ,(car binding)))) + ,@(mapcar (lambda (b) + `(define-key ,keymap ,b ',cmd)) + binding)))) + +(defmacro fuel-menu--add-items (keymap map keys) + `(progn ,@(mapcar (lambda (k) (list 'fuel-menu--add-item keymap map k)) + (reverse keys)))) + +(defmacro fuel-menu--add-submenu (name keymap map keys) + (let ((ev (make-symbol name)) + (map2 (make-symbol "map2"))) + `(progn + (let ((,map2 (make-sparse-keymap ,name))) + (define-key ,map [,ev] (cons ,name ,map2)) + (fuel-menu--add-items ,keymap ,map2 ,keys))))) + +(defvar fuel-menu--line-counter 0) + +(defun fuel-menu--add-line (&optional map) + (let ((line (make-symbol (format "line%s" + (setq fuel-menu--line-counter + (1+ fuel-menu--line-counter)))))) + (define-key (or map global-map) `[,line] + `(menu-item "--single-line")))) + +(defmacro fuel-menu--add-custom (title group keymap map) + `(fuel-menu--add-item ,keymap ,map + (,title nil (lambda () (interactive) (customize-group ',group))))) + +(defmacro fuel-menu--mode-toggle (title bindings mode keymap map) + `(fuel-menu--add-item ,keymap ,map + (,title ,bindings ,mode + :button (:toggle . (and (boundp ',mode) ,mode))))) + +(defmacro fuel-menu--defmenu (name keymap &rest keys) + (let ((mmap (make-symbol "mmap"))) + `(progn + (let ((,mmap (make-sparse-keymap "FUEL"))) + (define-key ,keymap [menu-bar ,name] (cons "FUEL" ,mmap)) + (define-key ,mmap [customize] + (cons "Customize FUEL" + `(lambda () (interactive) (customize-group 'fuel)))) + (fuel-menu--add-line ,mmap) + (fuel-menu--add-items ,keymap ,mmap ,keys) + ,mmap)))) + +(put 'fuel-menu--defmenu 'lisp-indent-function 2) + + + +(provide 'fuel-menu) +;;; fuel-menu.el ends here + diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 98aad10e22..ecee020b54 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -1,6 +1,6 @@ ;;; fuel-mode.el -- Minor mode enabling FUEL niceties -;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009, 2010 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -27,6 +27,7 @@ (require 'fuel-font-lock) (require 'fuel-edit) (require 'fuel-syntax) +(require 'fuel-menu) (require 'fuel-base) @@ -181,59 +182,64 @@ interacting with a factor listener is at your disposal. (fuel-scaffold--maybe-insert)))) -;;; Keys: +;;; Keys and menu: -(defun fuel-mode--key-1 (k c) - (define-key fuel-mode-map (vector '(control ?c) k) c) - (define-key fuel-mode-map (vector '(control ?c) `(control ,k)) c)) - -(defun fuel-mode--key (p k c) - (define-key fuel-mode-map (vector '(control ?c) `(control ,p) k) c) - (define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c)) - -(fuel-mode--key-1 ?k 'fuel-run-file) -(fuel-mode--key-1 ?l 'fuel-run-file) -(fuel-mode--key-1 ?r 'fuel-refresh-all) -(fuel-mode--key-1 ?t 'fuel-test-vocab) -(fuel-mode--key-1 ?z 'run-factor) -(fuel-mode--key-1 ?s 'fuel-switch-to-buffer) -(define-key fuel-mode-map "\C-x4s" 'fuel-switch-to-buffer-other-window) -(define-key fuel-mode-map "\C-x5s" 'fuel-switch-to-buffer-other-frame) - -(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition) -(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region) -(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point) -(define-key fuel-mode-map "\M-," 'fuel-edit-pop-edit-word-stack) -(define-key fuel-mode-map "\C-c\M-<" 'fuel-show-callers) -(define-key fuel-mode-map "\C-c\M->" 'fuel-show-callees) -(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol) - -(fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point) -(fuel-mode--key ?e ?e 'fuel-eval-extended-region) -(fuel-mode--key ?e ?k 'fuel-run-file) -(fuel-mode--key ?e ?l 'fuel-load-usings) -(fuel-mode--key ?e ?r 'fuel-eval-region) -(fuel-mode--key ?e ?u 'fuel-update-usings) -(fuel-mode--key ?e ?v 'fuel-edit-vocabulary) -(fuel-mode--key ?e ?w 'fuel-edit-word) -(fuel-mode--key ?e ?x 'fuel-eval-definition) - -(fuel-mode--key ?x ?a 'fuel-refactor-extract-article) -(fuel-mode--key ?x ?i 'fuel-refactor-inline-word) -(fuel-mode--key ?x ?g 'fuel-refactor-make-generic) -(fuel-mode--key ?x ?r 'fuel-refactor-extract-region) -(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp) -(fuel-mode--key ?x ?v 'fuel-refactor-extract-vocab) -(fuel-mode--key ?x ?w 'fuel-refactor-rename-word) - -(fuel-mode--key ?d ?> 'fuel-show-callees) -(fuel-mode--key ?d ?< 'fuel-show-callers) -(fuel-mode--key ?d ?v 'fuel-show-file-words) -(fuel-mode--key ?d ?a 'fuel-autodoc-mode) -(fuel-mode--key ?d ?p 'fuel-apropos) -(fuel-mode--key ?d ?d 'fuel-help) -(fuel-mode--key ?d ?e 'fuel-stack-effect-sexp) -(fuel-mode--key ?d ?s 'fuel-help-short) +(fuel-menu--defmenu fuel fuel-mode-map + ("Complete symbol" ((kbd "M-TAB")) + fuel-completion--complete-symbol :enable (symbol-at-point)) + ("Update USING:" ("\C-c\C-e\C-u" "\C-c\C-eu") fuel-update-usings) + -- + ("Eval definition" ("\C-\M-x" "\C-c\C-e\C-x" "\C-c\C-ex") + fuel-eval-definition) + ("Eval extended region" ("\C-\M-r" "\C-c\C-e\C-e" "\C-c\C-ee") + fuel-eval-extended-region :enable mark-active) + ("Eval region" ("\C-c\C-r" "\C-c\C-e\C-r" "\C-c\C-er") + fuel-eval-region :enable mark-active) + -- + ("Edit word at point" ("\M-." "\C-c\C-e\C-d" "\C-c\C-ed") + fuel-edit-word-at-point :enable (symbol-at-point)) + ("Edit word..." ("\C-c\C-e\C-w" "\C-c\C-ew") fuel-edit-word) + ("Edit vocab..." ("\C-c\C-e\C-v" "\C-c\C-ev") fuel-edit-vocabulary) + ("Jump back" "\M-," fuel-edit-pop-edit-word-stack) + -- + ("Help on word" ("\C-c\C-d\C-d" "\C-c\C-dd") fuel-help) + ("Short help on word" ("\C-c\C-d\C-s" "\C-c\C-ds") fuel-help) + ("Apropos..." ("\C-c\C-d\C-p" "\C-c\C-dp") fuel-apropos) + ("Show stack effect" ("\C-c\C-d\C-e" "\C-c\C-de") fuel-stack-effect-sexp) + -- + ("Show all words" ("\C-c\C-d\C-v" "\C-c\C-dv") fuel-show-file-words) + ("Word callers" "\C-c\M-<" fuel-show-callers :enable (symbol-at-point)) + ("Word callees" "\C-c\M->" fuel-show-callees :enable (symbol-at-point)) + (mode "Autodoc mode" ("\C-c\C-d\C-a" "\C-c\C-da") fuel-autodoc-mode) + -- + (menu "Refactor" + ("Rename word" ("\C-c\C-x\C-w" "\C-c\C-xw") fuel-refactor-rename-word) + ("Inline word" ("\C-c\C-x\C-i" "\C-c\C-xi") fuel-refactor-inline-word) + ("Extract region" ("\C-c\C-x\C-r" "\C-c\C-xr") + fuel-refactor-extract-region :enable mark-active) + ("Extract subregion" ("\C-c\C-x\C-s" "\C-c\C-xs") + fuel-refactor-extract-sexp) + ("Extract vocab" ("\C-c\C-x\C-v" "\C-c\C-xv") + fuel-refactor-extract-vocab) + ("Make generic" ("\C-c\C-x\C-g" "\C-c\C-xg") + fuel-refactor-make-generic) + -- + ("Extract article" ("\C-c\C-x\C-a" "\C-c\C-xa") + fuel-refactor-extract-article)) + -- + ("Load used vocabs" ("\C-c\C-e\C-l" "\C-c\C-el") fuel-load-usings) + ("Run file" ("\C-c\C-k" "\C-c\C-l" "\C-c\C-e\C-k") fuel-run-file) + ("Run unit tests" "\C-c\C-t" fuel-test-vocab) + ("Refresh vocabs" "\C-c\C-r" fuel-refresh-all) + -- + (menu "Switch to" + ("Listener" "\C-c\C-z" run-factor) + ("Related Factor file" "\C-c\C-o" factor-mode-visit-other-file) + ("Other Factor buffer" "\C-c\C-s" fuel-switch-to-buffer) + ("Other Factor buffer other window" "\C-x4s" + fuel-switch-to-buffer-other-window) + ("Other Factor buffer other frame" "\C-x5s" + fuel-switch-to-buffer-other-frame))) (provide 'fuel-mode) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index faf1897304..480540262f 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -1,6 +1,6 @@ ;;; fuel-xref.el -- showing cross-reference info -;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009, 2010 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -20,6 +20,7 @@ (require 'fuel-syntax) (require 'fuel-popup) (require 'fuel-font-lock) +(require 'fuel-menu) (require 'fuel-base) (require 'button) @@ -275,7 +276,8 @@ With prefix argument, ask for the vocab." (set-syntax-table fuel-syntax--syntax-table) (setq mode-name "FUEL Xref") (setq major-mode 'fuel-xref-mode) - (font-lock-add-keywords nil '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab))) + (font-lock-add-keywords nil + '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab))) (setq buffer-read-only t)) diff --git a/unmaintained/ce/authors.txt b/unmaintained/ce/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/unmaintained/ce/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/unmaintained/ce/backend/authors.txt b/unmaintained/ce/backend/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/unmaintained/ce/backend/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/unmaintained/ce/backend/backend.factor b/unmaintained/ce/backend/backend.factor deleted file mode 100644 index 7209a68ebf..0000000000 --- a/unmaintained/ce/backend/backend.factor +++ /dev/null @@ -1,50 +0,0 @@ -USING: io.ports io.windows threads.private kernel -io.backend windows.winsock windows.kernel32 windows -io.streams.duplex io namespaces alien.syntax system combinators -io.buffers io.encodings io.encodings.utf8 combinators.lib ; -IN: io.windows.ce.backend - -: port-errored ( port -- ) - win32-error-string swap set-port-error ; - -M: wince io-multiplex ( ms -- ) - 60 60 * 1000 * or (sleep) ; - -M: wince add-completion ( handle -- ) drop ; - -GENERIC: wince-read ( port port-handle -- ) - -M: input-port (wait-to-read) ( port -- ) - dup dup port-handle wince-read pending-error ; - -GENERIC: wince-write ( port port-handle -- ) - -M: port port-flush - dup buffer-empty? over port-error or [ - drop - ] [ - dup dup port-handle wince-write port-flush - ] if ; - -M: wince init-io ( -- ) - init-winsock ; - -LIBRARY: libc -FUNCTION: void* _getstdfilex int fd ; -FUNCTION: void* _fileno void* file ; - -M: wince (init-stdio) ( -- ) - #! We support Windows NT too, to make this I/O backend - #! easier to debug. - 512 default-buffer-size [ - os winnt? [ - STD_INPUT_HANDLE GetStdHandle - STD_OUTPUT_HANDLE GetStdHandle - STD_ERROR_HANDLE GetStdHandle - ] [ - 0 _getstdfilex _fileno - 1 _getstdfilex _fileno - 2 _getstdfilex _fileno - ] if [ f ] 3apply - [ ] [ ] [ ] tri* - ] with-variable ; diff --git a/unmaintained/ce/ce.factor b/unmaintained/ce/ce.factor deleted file mode 100644 index a0a8de8513..0000000000 --- a/unmaintained/ce/ce.factor +++ /dev/null @@ -1,11 +0,0 @@ -USE: io.backend -USE: io.windows -USE: io.windows.ce.backend -USE: io.windows.ce.files -USE: io.windows.ce.sockets -USE: io.windows.ce.launcher -USE: io.windows.mmap system -USE: io.windows.files -USE: system - -wince set-io-backend diff --git a/unmaintained/ce/files/files.factor b/unmaintained/ce/files/files.factor deleted file mode 100644 index 83d456832b..0000000000 --- a/unmaintained/ce/files/files.factor +++ /dev/null @@ -1,32 +0,0 @@ -USING: alien alien.c-types combinators io io.backend io.buffers -io.files io.ports io.windows kernel libc math namespaces -prettyprint sequences strings threads threads.private -windows windows.kernel32 io.windows.ce.backend system ; -IN: windows.ce.files - -! M: wince normalize-path ( string -- string ) - ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ; - -M: wince CreateFile-flags ( DWORD -- DWORD ) - FILE_ATTRIBUTE_NORMAL bitor ; -M: wince FileArgs-overlapped ( port -- f ) drop f ; - -: finish-read ( port status bytes-ret -- ) - swap [ drop port-errored ] [ swap n>buffer ] if ; - -M: win32-file wince-read - drop - dup make-FileArgs dup setup-read ReadFile zero? - swap FileArgs-lpNumberOfBytesRet *uint dup zero? [ - 2drop t swap set-port-eof? - ] [ - finish-read - ] if ; - -M: win32-file wince-write ( port port-handle -- ) - drop dup make-FileArgs dup setup-write WriteFile zero? [ - drop port-errored - ] [ - FileArgs-lpNumberOfBytesRet *uint - swap buffer-consume - ] if ; diff --git a/unmaintained/ce/privileges/privileges.factor b/unmaintained/ce/privileges/privileges.factor deleted file mode 100644 index e0aa186b3d..0000000000 --- a/unmaintained/ce/privileges/privileges.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: io.windows.ce.privileges -USING: io.windows.privileges system ; - -M: wince set-privilege 2drop ; diff --git a/unmaintained/ce/sockets/sockets.factor b/unmaintained/ce/sockets/sockets.factor deleted file mode 100644 index b3117dcde1..0000000000 --- a/unmaintained/ce/sockets/sockets.factor +++ /dev/null @@ -1,113 +0,0 @@ -USING: alien alien.c-types combinators io io.backend io.buffers -io.ports io.sockets io.windows kernel libc -math namespaces prettyprint qualified sequences strings threads -threads.private windows windows.kernel32 io.windows.ce.backend -byte-arrays system ; -QUALIFIED: windows.winsock -IN: io.windows.ce - -M: wince WSASocket-flags ( -- DWORD ) 0 ; - -M: win32-socket wince-read ( port port-handle -- ) - win32-file-handle over buffer-end pick buffer-capacity 0 - windows.winsock:recv - dup windows.winsock:SOCKET_ERROR = [ - drop port-errored - ] [ - dup zero? - [ drop t swap set-port-eof? ] [ swap n>buffer ] if - ] if ; - -M: win32-socket wince-write ( port port-handle -- ) - win32-file-handle over buffer@ pick buffer-length 0 - windows.winsock:send - dup windows.winsock:SOCKET_ERROR = - [ drop port-errored ] [ swap buffer-consume ] if ; - -: do-connect ( addrspec -- socket ) - [ tcp-socket dup ] keep - make-sockaddr/size - f f f f - windows.winsock:WSAConnect - windows.winsock:winsock-error!=0/f ; - -M: wince (client) ( addrspec -- reader writer ) - do-connect dup ; - -M: wince (server) ( addrspec -- handle ) - windows.winsock:SOCK_STREAM server-fd - dup listen-on-socket - ; - -M: wince (accept) ( server -- client ) - [ - [ - dup port-handle win32-file-handle - swap server-port-addr sockaddr-type heap-size - dup [ - swap f 0 - windows.winsock:WSAAccept - dup windows.winsock:INVALID_SOCKET = - [ windows.winsock:winsock-error ] when - ] keep - ] keep server-port-addr parse-sockaddr swap - - ] with-timeout ; - -M: wince ( addrspec -- datagram ) - [ - windows.winsock:SOCK_DGRAM server-fd - ] keep ; - -: packet-size 65536 ; inline - -: receive-buffer ( -- buf ) - \ receive-buffer get-global expired? [ - packet-size malloc \ receive-buffer set-global - ] when - \ receive-buffer get-global ; - -: make-WSABUF ( len buf -- ptr ) - "WSABUF" - [ windows.winsock:set-WSABUF-buf ] keep - [ windows.winsock:set-WSABUF-len ] keep ; - -: receive-WSABUF ( -- buf ) - packet-size receive-buffer make-WSABUF ; - -: packet-data ( len -- byte-array ) - receive-buffer swap memory>byte-array ; - -packet-size receive-buffer set-global - -M: wince receive ( datagram -- packet addrspec ) - dup check-datagram-port - [ - port-handle win32-file-handle - receive-WSABUF - 1 - 0 [ - 0 - 64 "char" [ - 64 - f - f - windows.winsock:WSARecvFrom - windows.winsock:winsock-error!=0/f - ] keep - ] keep *uint packet-data swap - ] keep datagram-port-addr parse-sockaddr ; - -: send-WSABUF ( byte-array -- ptr ) - dup length packet-size > [ "UDP packet too long" throw ] when - dup length receive-buffer rot pick memcpy - receive-buffer make-WSABUF ; - -M: wince send ( packet addrspec datagram -- ) - 3dup check-datagram-send - port-handle win32-file-handle - rot send-WSABUF - rot make-sockaddr/size - >r >r 1 0 0 r> r> f f - windows.winsock:WSASendTo - windows.winsock:winsock-error!=0/f ; diff --git a/unmaintained/ce/summary.txt b/unmaintained/ce/summary.txt deleted file mode 100644 index 0c660f75a5..0000000000 --- a/unmaintained/ce/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Microsoft Windows CE native I/O implementation diff --git a/extra/math/transforms/fft/authors.txt b/unmaintained/math/transforms/fft/authors.txt similarity index 100% rename from extra/math/transforms/fft/authors.txt rename to unmaintained/math/transforms/fft/authors.txt diff --git a/extra/math/transforms/fft/fft-docs.factor b/unmaintained/math/transforms/fft/fft-docs.factor similarity index 100% rename from extra/math/transforms/fft/fft-docs.factor rename to unmaintained/math/transforms/fft/fft-docs.factor diff --git a/extra/math/transforms/fft/fft.factor b/unmaintained/math/transforms/fft/fft.factor similarity index 100% rename from extra/math/transforms/fft/fft.factor rename to unmaintained/math/transforms/fft/fft.factor diff --git a/extra/math/transforms/fft/summary.txt b/unmaintained/math/transforms/fft/summary.txt similarity index 100% rename from extra/math/transforms/fft/summary.txt rename to unmaintained/math/transforms/fft/summary.txt diff --git a/unmaintained/ppc/authors.txt b/unmaintained/ppc/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/unmaintained/ppc/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/cpu/ppc/bootstrap.factor b/unmaintained/ppc/bootstrap.factor similarity index 100% rename from basis/cpu/ppc/bootstrap.factor rename to unmaintained/ppc/bootstrap.factor diff --git a/basis/cpu/ppc/linux/bootstrap.factor b/unmaintained/ppc/linux/bootstrap.factor similarity index 100% rename from basis/cpu/ppc/linux/bootstrap.factor rename to unmaintained/ppc/linux/bootstrap.factor diff --git a/basis/cpu/ppc/linux/linux.factor b/unmaintained/ppc/linux/linux.factor similarity index 100% rename from basis/cpu/ppc/linux/linux.factor rename to unmaintained/ppc/linux/linux.factor diff --git a/basis/cpu/ppc/linux/summary.txt b/unmaintained/ppc/linux/summary.txt similarity index 100% rename from basis/cpu/ppc/linux/summary.txt rename to unmaintained/ppc/linux/summary.txt diff --git a/basis/cpu/ppc/linux/tags.txt b/unmaintained/ppc/linux/tags.txt similarity index 100% rename from basis/cpu/ppc/linux/tags.txt rename to unmaintained/ppc/linux/tags.txt diff --git a/basis/cpu/ppc/macosx/bootstrap.factor b/unmaintained/ppc/macosx/bootstrap.factor similarity index 100% rename from basis/cpu/ppc/macosx/bootstrap.factor rename to unmaintained/ppc/macosx/bootstrap.factor diff --git a/basis/cpu/ppc/macosx/macosx.factor b/unmaintained/ppc/macosx/macosx.factor similarity index 100% rename from basis/cpu/ppc/macosx/macosx.factor rename to unmaintained/ppc/macosx/macosx.factor diff --git a/basis/cpu/ppc/macosx/summary.txt b/unmaintained/ppc/macosx/summary.txt similarity index 100% rename from basis/cpu/ppc/macosx/summary.txt rename to unmaintained/ppc/macosx/summary.txt diff --git a/basis/cpu/ppc/macosx/tags.txt b/unmaintained/ppc/macosx/tags.txt similarity index 100% rename from basis/cpu/ppc/macosx/tags.txt rename to unmaintained/ppc/macosx/tags.txt diff --git a/basis/cpu/ppc/ppc.factor b/unmaintained/ppc/ppc.factor similarity index 100% rename from basis/cpu/ppc/ppc.factor rename to unmaintained/ppc/ppc.factor diff --git a/basis/cpu/ppc/summary.txt b/unmaintained/ppc/summary.txt similarity index 100% rename from basis/cpu/ppc/summary.txt rename to unmaintained/ppc/summary.txt diff --git a/basis/cpu/ppc/tags.txt b/unmaintained/ppc/tags.txt similarity index 100% rename from basis/cpu/ppc/tags.txt rename to unmaintained/ppc/tags.txt diff --git a/vm/Config.windows b/vm/Config.windows index 11df403541..1886ee77d6 100644 --- a/vm/Config.windows +++ b/vm/Config.windows @@ -1,10 +1,17 @@ -CFLAGS += -mno-cygwin -LIBS = -lm -PLAF_DLL_OBJS += vm/os-windows.o +CFLAGS += -mno-cygwin -mwindows +CFLAGS_CONSOLE += -mconsole SHARED_FLAG = -shared -EXE_EXTENSION=.exe -CONSOLE_EXTENSION=.com -DLL_EXTENSION=.dll SHARED_DLL_EXTENSION=.dll + +LIBS = -lm + +PLAF_EXE_OBJS += vm/resources.o vm/main-windows.o + +EXE_SUFFIX= +EXE_EXTENSION=.exe +DLL_SUFFIX= +DLL_EXTENSION=.dll +CONSOLE_EXTENSION=.com + LINKER = $(CPP) -shared -mno-cygwin -o LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) diff --git a/vm/Config.windows.ce b/vm/Config.windows.ce deleted file mode 100644 index 2e3204a589..0000000000 --- a/vm/Config.windows.ce +++ /dev/null @@ -1,5 +0,0 @@ -CFLAGS += -DWINCE -LIBS = -lm -PLAF_DLL_OBJS += vm/os-windows-ce.o -PLAF_EXE_OBJS += vm/main-windows-ce.o -include vm/Config.windows diff --git a/vm/Config.windows.ce.arm b/vm/Config.windows.ce.arm deleted file mode 100644 index 98e08e8f61..0000000000 --- a/vm/Config.windows.ce.arm +++ /dev/null @@ -1,4 +0,0 @@ -CC = arm-wince-mingw32ce-gcc -DLL_SUFFIX=-ce -EXE_SUFFIX=-ce -include vm/Config.windows.ce vm/Config.arm diff --git a/vm/Config.windows.nt b/vm/Config.windows.nt deleted file mode 100644 index 322649dc06..0000000000 --- a/vm/Config.windows.nt +++ /dev/null @@ -1,10 +0,0 @@ -LIBS = -lm -EXE_SUFFIX= -DLL_SUFFIX= -PLAF_DLL_OBJS += vm/os-windows-nt.o vm/mvm-windows-nt.o -PLAF_EXE_OBJS += vm/resources.o -PLAF_EXE_OBJS += vm/main-windows-nt.o -CFLAGS += -mwindows -CFLAGS_CONSOLE += -mconsole -CONSOLE_EXTENSION = .com -include vm/Config.windows diff --git a/vm/Config.windows.nt.x86.32 b/vm/Config.windows.x86.32 similarity index 51% rename from vm/Config.windows.nt.x86.32 rename to vm/Config.windows.x86.32 index 73bf064ce5..6ba2955d79 100644 --- a/vm/Config.windows.nt.x86.32 +++ b/vm/Config.windows.x86.32 @@ -1,5 +1,5 @@ -PLAF_DLL_OBJS += vm/os-windows-nt-x86.32.o +PLAF_DLL_OBJS += vm/os-windows-x86.32.o DLL_PATH=http://factorcode.org/dlls WINDRES=windres -include vm/Config.windows.nt +include vm/Config.windows include vm/Config.x86.32 diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.x86.64 similarity index 63% rename from vm/Config.windows.nt.x86.64 rename to vm/Config.windows.x86.64 index 495a3ccac9..f3dc9b0b77 100644 --- a/vm/Config.windows.nt.x86.64 +++ b/vm/Config.windows.x86.64 @@ -1,6 +1,6 @@ -PLAF_DLL_OBJS += vm/os-windows-nt-x86.64.o +PLAF_DLL_OBJS += vm/os-windows-x86.64.o DLL_PATH=http://factorcode.org/dlls/64 CC=$(WIN64_PATH)-gcc.exe WINDRES=$(WIN64_PATH)-windres.exe -include vm/Config.windows.nt +include vm/Config.windows include vm/Config.x86.64 diff --git a/vm/aging_collector.cpp b/vm/aging_collector.cpp index c832ca792f..c747592f42 100644 --- a/vm/aging_collector.cpp +++ b/vm/aging_collector.cpp @@ -22,15 +22,17 @@ void factor_vm::collect_aging() to_tenured_collector collector(this); - current_gc->event->started_card_scan(); + gc_event *event = current_gc->event; + + if(event) event->started_card_scan(); collector.trace_cards(data->tenured, card_points_to_aging, full_unmarker()); - current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned); + if(event) event->ended_card_scan(collector.cards_scanned,collector.decks_scanned); - current_gc->event->started_code_scan(); + if(event) event->started_code_scan(); collector.trace_code_heap_roots(&code->points_to_aging); - current_gc->event->ended_code_scan(collector.code_blocks_scanned); + if(event) event->ended_code_scan(collector.code_blocks_scanned); collector.tenure_reachable_objects(); } diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 64c17d8661..5bec7f17cf 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -127,6 +127,18 @@ void factor_vm::set_frame_offset(stack_frame *frame, cell offset) FRAME_RETURN_ADDRESS(frame,this) = entry_point + offset; } +void factor_vm::scrub_return_address() +{ + stack_frame *top = ctx->callstack_top; + stack_frame *bottom = ctx->callstack_bottom; + stack_frame *frame = bottom - 1; + + while(frame >= top && frame_successor(frame) >= top) + frame = frame_successor(frame); + + set_frame_offset(frame,0); +} + cell factor_vm::frame_scan(stack_frame *frame) { switch(frame_type(frame)) diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index b42261619b..b67da28922 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -13,7 +13,7 @@ code_heap::code_heap(cell size) allocator = new free_list_allocator(seg->end - start,start); - /* See os-windows-nt-x86.64.cpp for seh_area usage */ + /* See os-windows-x86.64.cpp for seh_area usage */ seh_area = (char *)seg->start; } diff --git a/vm/compaction.cpp b/vm/compaction.cpp index 9d26062a5c..343a61b8ba 100644 --- a/vm/compaction.cpp +++ b/vm/compaction.cpp @@ -190,7 +190,9 @@ void factor_vm::update_code_roots_for_compaction() /* Compact data and code heaps */ void factor_vm::collect_compact_impl(bool trace_contexts_p) { - current_gc->event->started_compaction(); + gc_event *event = current_gc->event; + + if(event) event->started_compaction(); tenured_space *tenured = data->tenured; mark_bits *data_forwarding_map = &tenured->state; @@ -232,7 +234,7 @@ void factor_vm::collect_compact_impl(bool trace_contexts_p) update_code_roots_for_compaction(); callbacks->update(); - current_gc->event->ended_compaction(); + if(event) event->ended_compaction(); } struct code_compaction_fixup { diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 8359e09307..3d3008c2ab 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -111,8 +111,8 @@ void factor_vm::init_contexts(cell datastack_size_, cell retainstack_size_, cell void factor_vm::delete_contexts() { assert(!ctx); - std::vector::const_iterator iter = unused_contexts.begin(); - std::vector::const_iterator end = unused_contexts.end(); + std::list::const_iterator iter = unused_contexts.begin(); + std::list::const_iterator end = unused_contexts.end(); while(iter != end) { delete *iter; @@ -159,6 +159,13 @@ void factor_vm::delete_context(context *old_context) { unused_contexts.push_back(old_context); active_contexts.erase(old_context); + + while(unused_contexts.size() > 10) + { + context *stale_context = unused_contexts.front(); + unused_contexts.pop_front(); + delete stale_context; + } } VM_C_API void delete_context(factor_vm *parent, context *old_context) @@ -166,6 +173,12 @@ VM_C_API void delete_context(factor_vm *parent, context *old_context) parent->delete_context(old_context); } +VM_C_API void reset_context(factor_vm *parent, context *ctx) +{ + ctx->reset(); + parent->init_context(ctx); +} + cell factor_vm::begin_callback(cell quot_) { data_root quot(quot_,this); diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 4aa7d7c221..1098bb892f 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -73,6 +73,7 @@ struct context { VM_C_API context *new_context(factor_vm *parent); VM_C_API void delete_context(factor_vm *parent, context *old_context); +VM_C_API void reset_context(factor_vm *parent, context *ctx); VM_C_API cell begin_callback(factor_vm *parent, cell quot); VM_C_API void end_callback(factor_vm *parent); diff --git a/vm/debug.cpp b/vm/debug.cpp index bb3a8b0ce5..d00e248e71 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -228,6 +228,8 @@ void factor_vm::dump_generation(const char *name, Generation *gen) void factor_vm::dump_generations() { + std::cout << std::hex; + dump_generation("Nursery",&nursery); dump_generation("Aging",data->aging); dump_generation("Tenured",data->tenured); @@ -235,6 +237,8 @@ void factor_vm::dump_generations() std::cout << "Cards:"; std::cout << "base=" << (cell)data->cards << ", "; std::cout << "size=" << (cell)(data->cards_end - data->cards) << std::endl; + + std::cout << std::dec; } struct object_dumper { @@ -377,9 +381,10 @@ void factor_vm::factorbug() char cmd[1024]; std::cout << "READY\n"; - fflush(stdout); + std::cout.flush(); - if(scanf("%1000s",cmd) <= 0) + std::cin >> std::setw(1024) >> cmd >> std::setw(0); + if(!std::cin.good()) { if(!seen_command) { @@ -402,7 +407,10 @@ void factor_vm::factorbug() if(strcmp(cmd,"d") == 0) { cell addr = read_cell_hex(); - if(scanf(" ") < 0) break; + if (std::cin.peek() == ' ') + std::cin.ignore(); + + if(!std::cin.good()) break; cell count = read_cell_hex(); dump_memory(addr,addr+count); } diff --git a/vm/entry_points.cpp b/vm/entry_points.cpp old mode 100644 new mode 100755 index e07e343a96..9f4c827ddf --- a/vm/entry_points.cpp +++ b/vm/entry_points.cpp @@ -19,11 +19,29 @@ void factor_vm::c_to_factor(cell quot) c_to_factor_func(quot); } +template Func factor_vm::get_entry_point(cell n) +{ + /* We return word->code->entry_point() and not word->entry_point, + because if profiling is enabled, we don't want to go through the + entry point's profiling stub. This clobbers registers, since entry + points use the C ABI and not the Factor ABI. */ + tagged entry_point_word(special_objects[n]); + return (Func)entry_point_word->code->entry_point(); +} + void factor_vm::unwind_native_frames(cell quot, stack_frame *to) { - tagged unwind_native_frames_word(special_objects[UNWIND_NATIVE_FRAMES_WORD]); - unwind_native_frames_func_type unwind_native_frames_func = (unwind_native_frames_func_type)unwind_native_frames_word->entry_point; - unwind_native_frames_func(quot,to); + get_entry_point(UNWIND_NATIVE_FRAMES_WORD)(quot,to); +} + +cell factor_vm::get_fpu_state() +{ + return get_entry_point(GET_FPU_STATE_WORD)(); +} + +void factor_vm::set_fpu_state(cell state) +{ + get_entry_point(GET_FPU_STATE_WORD)(state); } } diff --git a/vm/entry_points.hpp b/vm/entry_points.hpp old mode 100644 new mode 100755 index 873501f235..7c7a1b9394 --- a/vm/entry_points.hpp +++ b/vm/entry_points.hpp @@ -3,5 +3,7 @@ namespace factor typedef void (* c_to_factor_func_type)(cell quot); typedef void (* unwind_native_frames_func_type)(cell quot, stack_frame *to); +typedef cell (* get_fpu_state_func_type)(); +typedef void (* set_fpu_state_func_type)(cell state); } diff --git a/vm/errors.cpp b/vm/errors.cpp index 61d4a73194..7c4b043423 100755 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -27,54 +27,51 @@ void out_of_memory() exit(1); } -void factor_vm::throw_error(cell error, stack_frame *stack) +void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2) { - assert(stack); + /* Reset local roots before allocating anything */ + data_roots.clear(); + bignum_roots.clear(); + code_roots.clear(); + + /* If we had an underflow or overflow, data or retain stack + pointers might be out of bounds, so fix them before allocating + anything */ + ctx->fix_stacks(); + + /* If error was thrown during heap scan, we re-enable the GC */ + gc_off = false; /* If the error handler is set, we rewind any C stack frames and pass the error to user-space. */ if(!current_gc && to_boolean(special_objects[ERROR_HANDLER_QUOT])) { - /* If error was thrown during heap scan, we re-enable the GC */ - gc_off = false; +#ifdef FACTOR_DEBUG + /* Doing a GC here triggers all kinds of funny errors */ + primitive_compact_gc(); +#endif - /* Reset local roots */ - data_roots.clear(); - bignum_roots.clear(); - code_roots.clear(); + /* Now its safe to allocate and GC */ + cell error_object = allot_array_4(special_objects[OBJ_ERROR], + tag_fixnum(error),arg1,arg2); - /* If we had an underflow or overflow, data or retain stack - pointers might be out of bounds */ - ctx->fix_stacks(); + ctx->push(error_object); - ctx->push(error); - - unwind_native_frames(special_objects[ERROR_HANDLER_QUOT],stack); + unwind_native_frames(special_objects[ERROR_HANDLER_QUOT], + ctx->callstack_top); } /* Error was thrown in early startup before error handler is set, just crash. */ else { std::cout << "You have triggered a bug in Factor. Please report.\n"; - std::cout << "early_error: "; - print_obj(error); - std::cout << std::endl; + std::cout << "error: " << error << std::endl; + std::cout << "arg 1: "; print_obj(arg1); std::cout << std::endl; + std::cout << "arg 2: "; print_obj(arg2); std::cout << std::endl; factorbug(); } } -void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *stack) -{ - throw_error(allot_array_4(special_objects[OBJ_ERROR], - tag_fixnum(error),arg1,arg2),stack); -} - -void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2) -{ - throw_error(allot_array_4(special_objects[OBJ_ERROR], - tag_fixnum(error),arg1,arg2),ctx->callstack_top); -} - void factor_vm::type_error(cell type, cell tagged) { general_error(ERROR_TYPE,tag_fixnum(type),tagged); @@ -85,29 +82,29 @@ void factor_vm::not_implemented_error() general_error(ERROR_NOT_IMPLEMENTED,false_object,false_object); } -void factor_vm::memory_protection_error(cell addr, stack_frame *stack) +void factor_vm::memory_protection_error(cell addr) { /* Retain and call stack underflows are not supposed to happen */ if(ctx->datastack_seg->underflow_p(addr)) - general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object,stack); + general_error(ERROR_DATASTACK_UNDERFLOW,false_object,false_object); else if(ctx->datastack_seg->overflow_p(addr)) - general_error(ERROR_DATASTACK_OVERFLOW,false_object,false_object,stack); + general_error(ERROR_DATASTACK_OVERFLOW,false_object,false_object); else if(ctx->retainstack_seg->underflow_p(addr)) - general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object,stack); + general_error(ERROR_RETAINSTACK_UNDERFLOW,false_object,false_object); else if(ctx->retainstack_seg->overflow_p(addr)) - general_error(ERROR_RETAINSTACK_OVERFLOW,false_object,false_object,stack); + general_error(ERROR_RETAINSTACK_OVERFLOW,false_object,false_object); else if(ctx->callstack_seg->underflow_p(addr)) - general_error(ERROR_CALLSTACK_OVERFLOW,false_object,false_object,stack); + general_error(ERROR_CALLSTACK_OVERFLOW,false_object,false_object); else if(ctx->callstack_seg->overflow_p(addr)) - general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object,stack); + general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object); else - general_error(ERROR_MEMORY,from_unsigned_cell(addr),false_object,stack); + general_error(ERROR_MEMORY,from_unsigned_cell(addr),false_object); } -void factor_vm::signal_error(cell signal, stack_frame *stack) +void factor_vm::signal_error(cell signal) { - general_error(ERROR_SIGNAL,from_unsigned_cell(signal),false_object,stack); + general_error(ERROR_SIGNAL,from_unsigned_cell(signal),false_object); } void factor_vm::divide_by_zero_error() @@ -115,9 +112,9 @@ void factor_vm::divide_by_zero_error() general_error(ERROR_DIVIDE_BY_ZERO,false_object,false_object); } -void factor_vm::fp_trap_error(unsigned int fpu_status, stack_frame *stack) +void factor_vm::fp_trap_error(unsigned int fpu_status) { - general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object,stack); + general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),false_object); } /* For testing purposes */ @@ -128,7 +125,8 @@ void factor_vm::primitive_unimplemented() void factor_vm::memory_signal_handler_impl() { - memory_protection_error(signal_fault_addr,signal_callstack_top); + scrub_return_address(); + memory_protection_error(signal_fault_addr); } void memory_signal_handler_impl() @@ -138,7 +136,8 @@ void memory_signal_handler_impl() void factor_vm::misc_signal_handler_impl() { - signal_error(signal_number,signal_callstack_top); + scrub_return_address(); + signal_error(signal_number); } void misc_signal_handler_impl() @@ -148,7 +147,11 @@ void misc_signal_handler_impl() void factor_vm::fp_signal_handler_impl() { - fp_trap_error(signal_fpu_status,signal_callstack_top); + /* Clear pending exceptions to avoid getting stuck in a loop */ + set_fpu_state(get_fpu_state()); + + scrub_return_address(); + fp_trap_error(signal_fpu_status); } void fp_signal_handler_impl() diff --git a/vm/factor.cpp b/vm/factor.cpp index 6a6d7f55f9..3f85c71a05 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -23,7 +23,7 @@ void factor_vm::default_parameters(vm_parameters *p) p->callstack_size = 128 * sizeof(cell); #endif - p->code_size = 8 * sizeof(cell); + p->code_size = 64; p->young_size = sizeof(cell) / 4; p->aging_size = sizeof(cell) / 2; p->tenured_size = 24 * sizeof(cell); diff --git a/vm/full_collector.cpp b/vm/full_collector.cpp index 19d8b576a5..852c058bd2 100644 --- a/vm/full_collector.cpp +++ b/vm/full_collector.cpp @@ -92,15 +92,17 @@ void factor_vm::collect_mark_impl(bool trace_contexts_p) void factor_vm::collect_sweep_impl() { - current_gc->event->started_data_sweep(); + gc_event *event = current_gc->event; + + if(event) event->started_data_sweep(); data->tenured->sweep(); - current_gc->event->ended_data_sweep(); + if(event) event->ended_data_sweep(); update_code_roots_for_sweep(); - current_gc->event->started_code_sweep(); + if(event) event->started_code_sweep(); code->allocator->sweep(); - current_gc->event->ended_code_sweep(); + if(event) event->ended_code_sweep(); } void factor_vm::collect_full(bool trace_contexts_p) @@ -110,14 +112,12 @@ void factor_vm::collect_full(bool trace_contexts_p) if(data->low_memory_p()) { - current_gc->op = collect_growing_heap_op; - current_gc->event->op = collect_growing_heap_op; + set_current_gc_op(collect_growing_heap_op); collect_growing_heap(0,trace_contexts_p); } else if(data->high_fragmentation_p()) { - current_gc->op = collect_compact_op; - current_gc->event->op = collect_compact_op; + set_current_gc_op(collect_compact_op); collect_compact_impl(trace_contexts_p); } diff --git a/vm/gc.cpp b/vm/gc.cpp index 766940a2d7..0de3dac91f 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -80,23 +80,33 @@ void gc_event::ended_gc(factor_vm *parent) total_time = (cell)(nano_count() - start_time); } -gc_state::gc_state(gc_op op_, factor_vm *parent) : op(op_), start_time(nano_count()) +gc_state::gc_state(gc_op op_, factor_vm *parent) : op(op_) { - event = new gc_event(op,parent); + if(parent->gc_events) + { + event = new gc_event(op,parent); + start_time = nano_count(); + } + else + event = NULL; } gc_state::~gc_state() { - delete event; - event = NULL; + if(event) + { + delete event; + event = NULL; + } } void factor_vm::end_gc() { - current_gc->event->ended_gc(this); - if(gc_events) gc_events->push_back(*current_gc->event); - delete current_gc->event; - current_gc->event = NULL; + if(gc_events) + { + current_gc->event->ended_gc(this); + gc_events->push_back(*current_gc->event); + } } void factor_vm::start_gc_again() @@ -123,7 +133,14 @@ void factor_vm::start_gc_again() break; } - current_gc->event = new gc_event(current_gc->op,this); + if(gc_events) + current_gc->event = new gc_event(current_gc->op,this); +} + +void factor_vm::set_current_gc_op(gc_op op) +{ + current_gc->op = op; + if(gc_events) current_gc->event->op = op; } void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p) @@ -139,7 +156,7 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p) { try { - current_gc->event->op = current_gc->op; + if(gc_events) current_gc->event->op = current_gc->op; switch(current_gc->op) { @@ -150,8 +167,7 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p) collect_aging(); if(data->high_fragmentation_p()) { - current_gc->op = collect_full_op; - current_gc->event->op = collect_full_op; + set_current_gc_op(collect_full_op); collect_full(trace_contexts_p); } break; @@ -159,8 +175,7 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p) collect_to_tenured(); if(data->high_fragmentation_p()) { - current_gc->op = collect_full_op; - current_gc->event->op = collect_full_op; + set_current_gc_op(collect_full_op); collect_full(trace_contexts_p); } break; diff --git a/vm/gc.hpp b/vm/gc.hpp index f6e9a875a6..76029d81ee 100755 --- a/vm/gc.hpp +++ b/vm/gc.hpp @@ -28,7 +28,7 @@ struct gc_event { cell compaction_time; u64 temp_time; - explicit gc_event(gc_op op_, factor_vm *parent); + gc_event(gc_op op_, factor_vm *parent); void started_card_scan(); void ended_card_scan(cell cards_scanned_, cell decks_scanned_); void started_code_scan(); diff --git a/vm/io.cpp b/vm/io.cpp index ba1e429802..2ea927bc05 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -190,7 +190,10 @@ void factor_vm::primitive_fgetc() int c = safe_fgetc(file); if(c == EOF && feof(file)) + { + clearerr(file); ctx->push(false_object); + } else ctx->push(tag_fixnum(c)); } @@ -210,11 +213,15 @@ void factor_vm::primitive_fread() size_t c = safe_fread(buf.untagged() + 1,1,size,file); if(c == 0) + { + clearerr(file); ctx->push(false_object); + } else { if(feof(file)) { + clearerr(file); byte_array *new_buf = allot_byte_array(c); memcpy(new_buf->data(), buf->data(),c); buf = new_buf; diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp old mode 100644 new mode 100755 index af14c3a49a..f87c0c8635 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -37,7 +37,7 @@ void factor_vm::call_fault_handler( { MACH_STACK_POINTER(thread_state) = (cell)fix_callstack_top((stack_frame *)MACH_STACK_POINTER(thread_state)); - signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state); + ctx->callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state); /* Now we point the program counter at the right handler function. */ if(exception == EXC_BAD_ACCESS) diff --git a/vm/mach_signal.hpp b/vm/mach_signal.hpp index e17fbf3996..a1961359d1 100644 --- a/vm/mach_signal.hpp +++ b/vm/mach_signal.hpp @@ -44,36 +44,36 @@ extern "C" boolean_t exc_server (mach_msg_header_t *request_msg, mach_msg_header extern "C" kern_return_t catch_exception_raise (mach_port_t exception_port, - mach_port_t thread, - mach_port_t task, - exception_type_t exception, - exception_data_t code, - mach_msg_type_number_t code_count); + mach_port_t thread, + mach_port_t task, + exception_type_t exception, + exception_data_t code, + mach_msg_type_number_t code_count); extern "C" kern_return_t catch_exception_raise_state (mach_port_t exception_port, - exception_type_t exception, - exception_data_t code, - mach_msg_type_number_t code_count, - thread_state_flavor_t *flavor, - thread_state_t in_state, - mach_msg_type_number_t in_state_count, - thread_state_t out_state, - mach_msg_type_number_t *out_state_count); + exception_type_t exception, + exception_data_t code, + mach_msg_type_number_t code_count, + thread_state_flavor_t *flavor, + thread_state_t in_state, + mach_msg_type_number_t in_state_count, + thread_state_t out_state, + mach_msg_type_number_t *out_state_count); extern "C" kern_return_t catch_exception_raise_state_identity (mach_port_t exception_port, - mach_port_t thread, - mach_port_t task, - exception_type_t exception, - exception_data_t code, - mach_msg_type_number_t codeCnt, - thread_state_flavor_t *flavor, - thread_state_t in_state, - mach_msg_type_number_t in_state_count, - thread_state_t out_state, - mach_msg_type_number_t *out_state_count); + mach_port_t thread, + mach_port_t task, + exception_type_t exception, + exception_data_t code, + mach_msg_type_number_t codeCnt, + thread_state_flavor_t *flavor, + thread_state_t in_state, + mach_msg_type_number_t in_state_count, + thread_state_t out_state, + mach_msg_type_number_t *out_state_count); namespace factor { diff --git a/vm/main-windows-ce.cpp b/vm/main-windows-ce.cpp deleted file mode 100755 index ed5844167a..0000000000 --- a/vm/main-windows-ce.cpp +++ /dev/null @@ -1,132 +0,0 @@ -#include "master.hpp" - -/* - Windows argument parsing ported to work on - int main(int argc, wchar_t **argv). - - Based on MinGW's public domain char** version. -*/ - -VM_C_API int parse_tokens(wchar_t *string, wchar_t ***tokens, int length) -{ - /* Extract whitespace- and quotes- delimited tokens from the given string - and put them into the tokens array. Returns number of tokens - extracted. Length specifies the current size of tokens[]. - THIS METHOD MODIFIES string. */ - - const wchar_t *whitespace = L" \t\r\n"; - wchar_t *tokenEnd = 0; - const wchar_t *quoteCharacters = L"\"\'"; - wchar_t *end = string + wcslen(string); - - if (string == NULL) - return length; - - while (1) - { - const wchar_t *q; - /* Skip over initial whitespace. */ - string += wcsspn(string, whitespace); - if (*string == '\0') - break; - - for (q = quoteCharacters; *q; ++q) - { - if (*string == *q) - break; - } - if (*q) - { - /* Token is quoted. */ - wchar_t quote = *string++; - tokenEnd = wcschr(string, quote); - /* If there is no endquote, the token is the rest of the string. */ - if (!tokenEnd) - tokenEnd = end; - } - else - { - tokenEnd = string + wcscspn(string, whitespace); - } - - *tokenEnd = '\0'; - - { - wchar_t **new_tokens; - int newlen = length + 1; - new_tokens = (wchar_t **)realloc (*tokens, sizeof (wchar_t**) * newlen); - if (!new_tokens) - { - /* Out of memory. */ - return -1; - } - - *tokens = new_tokens; - (*tokens)[length] = string; - length = newlen; - } - if (tokenEnd == end) - break; - string = tokenEnd + 1; - } - return length; -} - -VM_C_API void parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW) -{ - int cmdlineLen = 0; - - if (!cmdlinePtrW) - cmdlineLen = 0; - else - cmdlineLen = wcslen(cmdlinePtrW); - - /* gets realloc()'d later */ - *argc = 0; - *argv = (wchar_t **)malloc (sizeof (wchar_t**)); - - if (!*argv) - ExitProcess(1); - -#ifdef WINCE - wchar_t cmdnameBufW[MAX_UNICODE_PATH]; - - /* argv[0] is the path of invoked program - get this from CE. */ - cmdnameBufW[0] = 0; - GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0])); - - (*argv)[0] = wcsdup(cmdnameBufW); - if(!(*argv[0])) - ExitProcess(1); - /* Add one to account for argv[0] */ - (*argc)++; -#endif - - if (cmdlineLen > 0) - { - wchar_t *string = wcsdup(cmdlinePtrW); - if(!string) - ExitProcess(1); - *argc = parse_tokens(string, argv, *argc); - if (*argc < 0) - ExitProcess(1); - } - (*argv)[*argc] = 0; - return; -} - -int WINAPI WinMain( - HINSTANCE hInstance, - HINSTANCE hPrevInstance, - LPWSTR lpCmdLine, - int nCmdShow) -{ - int __argc; - wchar_t **__argv; - factor::parse_args(&__argc, &__argv, lpCmdLine); - factor::init_globals(); - factor::start_standalone_factor(__argc,(LPWSTR*)__argv); - - // memory leak from malloc, wcsdup - return 0; -} diff --git a/vm/main-windows-nt.cpp b/vm/main-windows.cpp old mode 100755 new mode 100644 similarity index 52% rename from vm/main-windows-nt.cpp rename to vm/main-windows.cpp index 64e2cce54b..4de32f894a --- a/vm/main-windows-nt.cpp +++ b/vm/main-windows.cpp @@ -3,12 +3,7 @@ VM_C_API int wmain(int argc, wchar_t **argv) { factor::init_globals(); -#ifdef FACTOR_MULTITHREADED - factor::THREADHANDLE thread = factor::start_standalone_factor_in_new_thread(argv,argc); - WaitForSingleObject(thread, INFINITE); -#else factor::start_standalone_factor(argc,argv); -#endif return 0; } @@ -19,11 +14,8 @@ int WINAPI WinMain( int nCmdShow) { int argc; - wchar_t **argv; - - argv = CommandLineToArgvW(GetCommandLine(),&argc); + wchar_t **argv = CommandLineToArgvW(GetCommandLine(),&argc); wmain(argc,argv); - // memory leak from malloc, wcsdup return 0; } diff --git a/vm/master.hpp b/vm/master.hpp index b8ababeb2d..d4cd70f867 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -20,13 +20,16 @@ #include #include #include +#include /* C++ headers */ #include +#include #include #include #include #include +#include #define FACTOR_STRINGIZE(x) #x diff --git a/vm/math.cpp b/vm/math.cpp index b872e7057f..67cab3570d 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -303,12 +303,6 @@ void factor_vm::primitive_float_divfloat() ctx->push(allot_float(x / y)); } -void factor_vm::primitive_float_mod() -{ - POP_FLOATS(x,y); - ctx->push(allot_float(fmod(x,y))); -} - void factor_vm::primitive_float_less() { POP_FLOATS(x,y); diff --git a/vm/mvm-windows-nt.cpp b/vm/mvm-windows.cpp similarity index 100% rename from vm/mvm-windows-nt.cpp rename to vm/mvm-windows.cpp diff --git a/vm/nursery_collector.cpp b/vm/nursery_collector.cpp index 062aa6aed3..7ea81391b2 100644 --- a/vm/nursery_collector.cpp +++ b/vm/nursery_collector.cpp @@ -18,7 +18,9 @@ void factor_vm::collect_nursery() collector.trace_roots(); collector.trace_contexts(); - current_gc->event->started_card_scan(); + gc_event *event = current_gc->event; + + if(event) event->started_card_scan(); collector.trace_cards(data->tenured, card_points_to_nursery, simple_unmarker(card_points_to_nursery)); @@ -28,11 +30,11 @@ void factor_vm::collect_nursery() card_points_to_nursery, full_unmarker()); } - current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned); + if(event) event->ended_card_scan(collector.cards_scanned,collector.decks_scanned); - current_gc->event->started_code_scan(); + if(event) event->started_code_scan(); collector.trace_code_heap_roots(&code->points_to_nursery); - current_gc->event->ended_code_scan(collector.code_blocks_scanned); + if(event) event->ended_code_scan(collector.code_blocks_scanned); collector.cheneys_algorithm(); diff --git a/vm/objects.hpp b/vm/objects.hpp old mode 100644 new mode 100755 index 8d883ecdb7..41265cd241 --- a/vm/objects.hpp +++ b/vm/objects.hpp @@ -55,6 +55,8 @@ enum special_object { C_TO_FACTOR_WORD, LAZY_JIT_COMPILE_WORD, UNWIND_NATIVE_FRAMES_WORD, + GET_FPU_STATE_WORD, + SET_FPU_STATE_WORD, /* Incremented on every modify-code-heap call; invalidates call( inline caching */ diff --git a/vm/os-linux.cpp b/vm/os-linux.cpp index ffc5a6097a..0bc7427331 100644 --- a/vm/os-linux.cpp +++ b/vm/os-linux.cpp @@ -45,19 +45,19 @@ VM_C_API int inotify_rm_watch(int fd, u32 wd) VM_C_API int inotify_init() { - parent->not_implemented_error(); + current_vm()->not_implemented_error(); return -1; } VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask) { - parent->not_implemented_error(); + current_vm()->not_implemented_error(); return -1; } VM_C_API int inotify_rm_watch(int fd, u32 wd) { - parent->not_implemented_error(); + current_vm()->not_implemented_error(); return -1; } diff --git a/vm/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp index 90da9a26f3..8931d4c7db 100644 --- a/vm/os-macosx-ppc.hpp +++ b/vm/os-macosx-ppc.hpp @@ -34,23 +34,23 @@ Modified for Factor by Slava Pestov */ #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1 #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0 - #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss) - #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs) + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs) - #define FPSCR(float_state) (float_state)->__fpscr + #define FPSCR(float_state) (float_state)->__fpscr #else #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar #define MACH_STACK_POINTER(thr_state) (thr_state)->r1 #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0 - #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss) - #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs) + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs) - #define FPSCR(float_state) (float_state)->fpscr + #define FPSCR(float_state) (float_state)->fpscr #endif #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(UAP_SS(ucontext)) + MACH_PROGRAM_COUNTER(UAP_SS(ucontext)) inline static unsigned int mach_fpu_status(ppc_float_state_t *float_state) { diff --git a/vm/os-macosx-x86.32.hpp b/vm/os-macosx-x86.32.hpp index 3d754ae9e4..12a351ae58 100644 --- a/vm/os-macosx-x86.32.hpp +++ b/vm/os-macosx-x86.32.hpp @@ -32,25 +32,25 @@ Modified for Factor by Slava Pestov */ #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip - #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss) - #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs) + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs) - #define MXCSR(float_state) (float_state)->__fpu_mxcsr - #define X87SW(float_state) (float_state)->__fpu_fsw + #define MXCSR(float_state) (float_state)->__fpu_mxcsr + #define X87SW(float_state) (float_state)->__fpu_fsw #else #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr #define MACH_STACK_POINTER(thr_state) (thr_state)->esp #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip - #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss) - #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs) + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs) - #define MXCSR(float_state) (float_state)->fpu_mxcsr - #define X87SW(float_state) (float_state)->fpu_fsw + #define MXCSR(float_state) (float_state)->fpu_mxcsr + #define X87SW(float_state) (float_state)->fpu_fsw #endif #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(UAP_SS(ucontext)) + MACH_PROGRAM_COUNTER(UAP_SS(ucontext)) inline static unsigned int mach_fpu_status(i386_float_state_t *float_state) { @@ -66,8 +66,8 @@ inline static unsigned int uap_fpu_status(void *uap) inline static void mach_clear_fpu_status(i386_float_state_t *float_state) { - MXCSR(float_state) &= 0xffffffc0; - memset(&X87SW(float_state), 0, sizeof(X87SW(float_state))); + MXCSR(float_state) &= 0xffffffc0; + memset(&X87SW(float_state), 0, sizeof(X87SW(float_state))); } inline static void uap_clear_fpu_status(void *uap) diff --git a/vm/os-macosx-x86.64.hpp b/vm/os-macosx-x86.64.hpp index 7cef436327..a9fcb9f274 100644 --- a/vm/os-macosx-x86.64.hpp +++ b/vm/os-macosx-x86.64.hpp @@ -31,24 +31,24 @@ Modified for Factor by Slava Pestov and Daniel Ehrenberg */ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr #define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip - #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss) - #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs) + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs) - #define MXCSR(float_state) (float_state)->__fpu_mxcsr - #define X87SW(float_state) (float_state)->__fpu_fsw + #define MXCSR(float_state) (float_state)->__fpu_mxcsr + #define X87SW(float_state) (float_state)->__fpu_fsw #else #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr #define MACH_STACK_POINTER(thr_state) (thr_state)->rsp #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip - #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss) - #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs) + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs) - #define MXCSR(float_state) (float_state)->fpu_mxcsr - #define X87SW(float_state) (float_state)->fpu_fsw + #define MXCSR(float_state) (float_state)->fpu_mxcsr + #define X87SW(float_state) (float_state)->fpu_fsw #endif #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(UAP_SS(ucontext)) + MACH_PROGRAM_COUNTER(UAP_SS(ucontext)) inline static unsigned int mach_fpu_status(x86_float_state64_t *float_state) { diff --git a/vm/os-macosx.mm b/vm/os-macosx.mm index c5377be8ef..93b4edd06a 100644 --- a/vm/os-macosx.mm +++ b/vm/os-macosx.mm @@ -17,7 +17,7 @@ void early_init(void) Gestalt(gestaltSystemVersion,&version); if(version < 0x1050) { - printf("Factor requires Mac OS X 10.5 or later.\n"); + std::cout << "Factor requires Mac OS X 10.5 or later.\n"; exit(1); } diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp old mode 100644 new mode 100755 index e95b84f51a..8f0f8b85cd --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -118,7 +118,7 @@ void factor_vm::dispatch_signal(void *uap, void (handler)()) UAP_STACK_POINTER(uap) = (UAP_STACK_POINTER_TYPE)fix_callstack_top((stack_frame *)UAP_STACK_POINTER(uap)); UAP_PROGRAM_COUNTER(uap) = (cell)handler; - signal_callstack_top = (stack_frame *)UAP_STACK_POINTER(uap); + ctx->callstack_top = (stack_frame *)UAP_STACK_POINTER(uap); } void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap) @@ -135,6 +135,10 @@ void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap) vm->dispatch_signal(uap,factor::misc_signal_handler_impl); } +void ignore_signal_handler(int signal, siginfo_t *siginfo, void *uap) +{ +} + void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap) { factor_vm *vm = current_vm(); @@ -206,9 +210,13 @@ void factor_vm::unix_init_signals() sigaction_safe(SIGQUIT,&misc_sigaction,NULL); sigaction_safe(SIGILL,&misc_sigaction,NULL); + /* We don't use SA_IGN here because then the ignore action is inherited + by subprocesses, which we don't want. There is a unit test in + io.launcher.unix for this. */ memset(&ignore_sigaction,0,sizeof(struct sigaction)); sigemptyset(&ignore_sigaction.sa_mask); - ignore_sigaction.sa_handler = SIG_IGN; + ignore_sigaction.sa_sigaction = ignore_signal_handler; + ignore_sigaction.sa_flags = SA_SIGINFO | SA_ONSTACK; sigaction_safe(SIGPIPE,&ignore_sigaction,NULL); } @@ -316,40 +324,29 @@ void *stdin_loop(void *arg) return NULL; } -void open_console() +void safe_pipe(int *in, int *out) { int filedes[2]; if(pipe(filedes) < 0) - fatal_error("Error opening control pipe",errno); + fatal_error("Error opening pipe",errno); - control_read = filedes[0]; - control_write = filedes[1]; + *in = filedes[0]; + *out = filedes[1]; - if(pipe(filedes) < 0) - fatal_error("Error opening size pipe",errno); + if(fcntl(*in,F_SETFD,FD_CLOEXEC) < 0) + fatal_error("Error with fcntl",errno); - size_read = filedes[0]; - size_write = filedes[1]; - - if(pipe(filedes) < 0) - fatal_error("Error opening stdin pipe",errno); - - stdin_read = filedes[0]; - stdin_write = filedes[1]; + if(fcntl(*out,F_SETFD,FD_CLOEXEC) < 0) + fatal_error("Error with fcntl",errno); +} +void open_console() +{ + safe_pipe(&control_read,&control_write); + safe_pipe(&size_read,&size_write); + safe_pipe(&stdin_read,&stdin_write); start_thread(stdin_loop,NULL); } -VM_C_API void wait_for_stdin() -{ - if(write(control_write,"X",1) != 1) - { - if(errno == EINTR) - wait_for_stdin(); - else - fatal_error("Error writing control fd",errno); - } -} - } diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 54e9d068ef..2c7dde9c61 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -27,8 +27,6 @@ typedef char symbol_char; #define FTELL ftello #define FSEEK fseeko -#define CELL_HEX_FORMAT "%lx" - #define OPEN_READ(path) fopen(path,"rb") #define OPEN_WRITE(path) fopen(path,"wb") @@ -39,9 +37,6 @@ typedef pthread_t THREADHANDLE; THREADHANDLE start_thread(void *(*start_routine)(void *),void *args); inline static THREADHANDLE thread_id() { return pthread_self(); } -void signal_handler(int signal, siginfo_t* siginfo, void* uap); -void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap); - u64 nano_count(); void sleep_nanos(u64 nsec); void open_console(); diff --git a/vm/os-windows-ce.cpp b/vm/os-windows-ce.cpp deleted file mode 100644 index 65e8ef5b09..0000000000 --- a/vm/os-windows-ce.cpp +++ /dev/null @@ -1,30 +0,0 @@ -#include "master.hpp" - -namespace factor -{ - -char *strerror(int err) -{ - /* strerror() is not defined on WinCE */ - return "strerror() is not defined on WinCE. Use native I/O."; -} - -void flush_icache(cell start, cell end) -{ - FlushInstructionCache(GetCurrentProcess(), 0, 0); -} - -char *getenv(char *name) -{ - vm->not_implemented_error(); - return 0; /* unreachable */ -} - -void c_to_factor_toplevel(cell quot) -{ - c_to_factor(quot,vm); -} - -void open_console() { } - -} diff --git a/vm/os-windows-ce.hpp b/vm/os-windows-ce.hpp deleted file mode 100755 index 892fc88be9..0000000000 --- a/vm/os-windows-ce.hpp +++ /dev/null @@ -1,27 +0,0 @@ -#ifndef UNICODE -#define UNICODE -#endif - -#include -#include - -namespace factor -{ - -typedef wchar_t symbol_char; - -#define FACTOR_OS_STRING "wince" -#define FACTOR_DLL L"factor-ce.dll" - -int errno; -char *strerror(int err); -void flush_icache(cell start, cell end); -char *getenv(char *name); - -#define snprintf _snprintf -#define snwprintf _snwprintf - -void c_to_factor_toplevel(cell quot); -void open_console(); - -} diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp deleted file mode 100755 index 7fdb882122..0000000000 --- a/vm/os-windows-nt.cpp +++ /dev/null @@ -1,98 +0,0 @@ -#include "master.hpp" - -namespace factor -{ - -THREADHANDLE start_thread(void *(*start_routine)(void *), void *args) -{ - return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0); -} - -u64 nano_count() -{ - static double scale_factor; - - static u32 hi = 0; - static u32 lo = 0; - - LARGE_INTEGER count; - BOOL ret = QueryPerformanceCounter(&count); - if(ret == 0) - fatal_error("QueryPerformanceCounter", 0); - - if(scale_factor == 0.0) - { - LARGE_INTEGER frequency; - BOOL ret = QueryPerformanceFrequency(&frequency); - if(ret == 0) - fatal_error("QueryPerformanceFrequency", 0); - scale_factor = (1000000000.0 / frequency.QuadPart); - } - -#ifdef FACTOR_64 - hi = count.HighPart; -#else - /* On VirtualBox, QueryPerformanceCounter does not increment - the high part every time the low part overflows. Workaround. */ - if(lo > count.LowPart) - hi++; -#endif - lo = count.LowPart; - - return (u64)((((u64)hi << 32) | (u64)lo) * scale_factor); -} - -void sleep_nanos(u64 nsec) -{ - Sleep((DWORD)(nsec/1000000)); -} - -LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) -{ - c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP); - signal_callstack_top = (stack_frame *)c->ESP; - - switch (e->ExceptionCode) - { - case EXCEPTION_ACCESS_VIOLATION: - signal_fault_addr = e->ExceptionInformation[1]; - c->EIP = (cell)factor::memory_signal_handler_impl; - break; - - case STATUS_FLOAT_DENORMAL_OPERAND: - case STATUS_FLOAT_DIVIDE_BY_ZERO: - case STATUS_FLOAT_INEXACT_RESULT: - case STATUS_FLOAT_INVALID_OPERATION: - case STATUS_FLOAT_OVERFLOW: - case STATUS_FLOAT_STACK_CHECK: - case STATUS_FLOAT_UNDERFLOW: - case STATUS_FLOAT_MULTIPLE_FAULTS: - case STATUS_FLOAT_MULTIPLE_TRAPS: -#ifdef FACTOR_64 - signal_fpu_status = fpu_status(MXCSR(c)); -#else - signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c)); - X87SW(c) = 0; -#endif - MXCSR(c) &= 0xffffffc0; - c->EIP = (cell)factor::fp_signal_handler_impl; - break; - default: - signal_number = e->ExceptionCode; - c->EIP = (cell)factor::misc_signal_handler_impl; - break; - } - - return 0; -} - -VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) -{ - return current_vm()->exception_handler(e,frame,c,dispatch); -} - -void factor_vm::open_console() -{ -} - -} diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp deleted file mode 100755 index 60990c0986..0000000000 --- a/vm/os-windows-nt.hpp +++ /dev/null @@ -1,42 +0,0 @@ -#undef _WIN32_WINNT -#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler - -#ifndef UNICODE -#define UNICODE -#endif - -#include -#include - -#ifdef _MSC_VER - #undef min - #undef max -#endif - -namespace factor -{ - -typedef char symbol_char; - -#define FACTOR_OS_STRING "winnt" - -#define FACTOR_DLL NULL - -VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch); - -// SSE traps raise these exception codes, which are defined in internal NT headers -// but not winbase.h -#ifndef STATUS_FLOAT_MULTIPLE_FAULTS -#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4 -#endif - -#ifndef STATUS_FLOAT_MULTIPLE_TRAPS -#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5 -#endif - -typedef HANDLE THREADHANDLE; - -THREADHANDLE start_thread(void *(*start_routine)(void *),void *args); -inline static THREADHANDLE thread_id() { return GetCurrentThread(); } - -} diff --git a/vm/os-windows-nt-x86.32.cpp b/vm/os-windows-x86.32.cpp similarity index 100% rename from vm/os-windows-nt-x86.32.cpp rename to vm/os-windows-x86.32.cpp diff --git a/vm/os-windows-nt-x86.64.cpp b/vm/os-windows-x86.64.cpp similarity index 100% rename from vm/os-windows-nt-x86.64.cpp rename to vm/os-windows-x86.64.cpp diff --git a/vm/os-windows-nt.32.hpp b/vm/os-windows.32.hpp old mode 100755 new mode 100644 similarity index 100% rename from vm/os-windows-nt.32.hpp rename to vm/os-windows.32.hpp diff --git a/vm/os-windows-nt.64.hpp b/vm/os-windows.64.hpp old mode 100755 new mode 100644 similarity index 100% rename from vm/os-windows-nt.64.hpp rename to vm/os-windows.64.hpp diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index 1ff1b174b5..a54a5e15d7 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -57,7 +57,10 @@ BOOL factor_vm::windows_stat(vm_char *path) void factor_vm::windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length) { - SNWPRINTF(temp_path, length-1, L"%s.image", full_path); + wcsncpy(temp_path, full_path, length - 1); + size_t full_path_len = wcslen(full_path); + if (full_path_len < length - 1) + wcsncat(temp_path, L".image", length - full_path_len - 1); temp_path[length - 1] = 0; } @@ -74,7 +77,10 @@ const vm_char *factor_vm::default_image_path() if((ptr = wcsrchr(full_path, '.'))) *ptr = 0; - SNWPRINTF(temp_path, MAX_UNICODE_PATH-1, L"%s.image", full_path); + wcsncpy(temp_path, full_path, MAX_UNICODE_PATH - 1); + size_t full_path_len = wcslen(full_path); + if (full_path_len < MAX_UNICODE_PATH - 1) + wcsncat(temp_path, L".image", MAX_UNICODE_PATH - full_path_len - 1); temp_path[MAX_UNICODE_PATH - 1] = 0; return safe_strdup(temp_path); @@ -145,4 +151,96 @@ void factor_vm::move_file(const vm_char *path1, const vm_char *path2) void factor_vm::init_signals() {} +THREADHANDLE start_thread(void *(*start_routine)(void *), void *args) +{ + return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0); +} + +u64 nano_count() +{ + static double scale_factor; + + static u32 hi = 0; + static u32 lo = 0; + + LARGE_INTEGER count; + BOOL ret = QueryPerformanceCounter(&count); + if(ret == 0) + fatal_error("QueryPerformanceCounter", 0); + + if(scale_factor == 0.0) + { + LARGE_INTEGER frequency; + BOOL ret = QueryPerformanceFrequency(&frequency); + if(ret == 0) + fatal_error("QueryPerformanceFrequency", 0); + scale_factor = (1000000000.0 / frequency.QuadPart); + } + +#ifdef FACTOR_64 + hi = count.HighPart; +#else + /* On VirtualBox, QueryPerformanceCounter does not increment + the high part every time the low part overflows. Workaround. */ + if(lo > count.LowPart) + hi++; +#endif + lo = count.LowPart; + + return (u64)((((u64)hi << 32) | (u64)lo) * scale_factor); +} + +void sleep_nanos(u64 nsec) +{ + Sleep((DWORD)(nsec/1000000)); +} + +LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) +{ + c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP); + ctx->callstack_top = (stack_frame *)c->ESP; + + switch (e->ExceptionCode) + { + case EXCEPTION_ACCESS_VIOLATION: + signal_fault_addr = e->ExceptionInformation[1]; + c->EIP = (cell)factor::memory_signal_handler_impl; + break; + + case STATUS_FLOAT_DENORMAL_OPERAND: + case STATUS_FLOAT_DIVIDE_BY_ZERO: + case STATUS_FLOAT_INEXACT_RESULT: + case STATUS_FLOAT_INVALID_OPERATION: + case STATUS_FLOAT_OVERFLOW: + case STATUS_FLOAT_STACK_CHECK: + case STATUS_FLOAT_UNDERFLOW: + case STATUS_FLOAT_MULTIPLE_FAULTS: + case STATUS_FLOAT_MULTIPLE_TRAPS: +#ifdef FACTOR_64 + signal_fpu_status = fpu_status(MXCSR(c)); +#else + signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c)); + + /* This seems to have no effect */ + X87SW(c) = 0; +#endif + MXCSR(c) &= 0xffffffc0; + c->EIP = (cell)factor::fp_signal_handler_impl; + break; + default: + signal_number = e->ExceptionCode; + c->EIP = (cell)factor::misc_signal_handler_impl; + break; + } + + return 0; +} + +VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) +{ + return current_vm()->exception_handler(e,frame,c,dispatch); +} + +void factor_vm::open_console() {} + } diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index ad8a9907a7..79f3e0d0aa 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -5,10 +5,30 @@ #include #endif +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler + +#ifndef UNICODE +#define UNICODE +#endif + +#include +#include + +#ifdef _MSC_VER + #undef min + #undef max +#endif + +/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ +#define EPOCH_OFFSET 0x019db1ded53e8000LL + namespace factor { typedef wchar_t vm_char; +typedef char symbol_char; +typedef HANDLE THREADHANDLE; #define STRING_LITERAL(string) L##string @@ -23,31 +43,36 @@ typedef wchar_t vm_char; #define FTELL ftell #define FSEEK fseek #define SNPRINTF _snprintf - #define SNWPRINTF _snwprintf #else #define FTELL ftello64 #define FSEEK fseeko64 #define SNPRINTF snprintf - #define SNWPRINTF snwprintf #endif -#ifdef WIN64 - #define CELL_HEX_FORMAT "%Ix" -#else - #define CELL_HEX_FORMAT "%lx" +#define FACTOR_OS_STRING "winnt" + +#define FACTOR_DLL NULL + +// SSE traps raise these exception codes, which are defined in internal NT headers +// but not winbase.h +#ifndef STATUS_FLOAT_MULTIPLE_FAULTS +#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4 +#endif + +#ifndef STATUS_FLOAT_MULTIPLE_TRAPS +#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5 #endif #define OPEN_READ(path) _wfopen((path),L"rb") #define OPEN_WRITE(path) _wfopen((path),L"wb") -/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */ -#define EPOCH_OFFSET 0x019db1ded53e8000LL - inline static void early_init() {} - u64 nano_count(); void sleep_nanos(u64 nsec); long getpagesize(); void move_file(const vm_char *path1, const vm_char *path2); +VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch); +THREADHANDLE start_thread(void *(*start_routine)(void *),void *args); +inline static THREADHANDLE thread_id() { return GetCurrentThread(); } } diff --git a/vm/platform.hpp b/vm/platform.hpp index e5a07a05d4..cdfe7fa45a 100755 --- a/vm/platform.hpp +++ b/vm/platform.hpp @@ -1,15 +1,11 @@ #if defined(WINDOWS) - #if defined(WINCE) - #include "os-windows-ce.hpp" + #if defined(WINNT) #include "os-windows.hpp" - #elif defined(WINNT) - #include "os-windows.hpp" - #include "os-windows-nt.hpp" #if defined(FACTOR_AMD64) - #include "os-windows-nt.64.hpp" + #include "os-windows.64.hpp" #elif defined(FACTOR_X86) - #include "os-windows-nt.32.hpp" + #include "os-windows.32.hpp" #else #error "Unsupported Windows flavor" #endif diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 77c255afd5..ce40ca0a7e 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -78,7 +78,6 @@ namespace factor _(float_greatereq) \ _(float_less) \ _(float_lesseq) \ - _(float_mod) \ _(float_multiply) \ _(float_subtract) \ _(float_to_bignum) \ diff --git a/vm/run.cpp b/vm/run.cpp index 605fd9b725..f545340221 100755 --- a/vm/run.cpp +++ b/vm/run.cpp @@ -11,7 +11,14 @@ void factor_vm::primitive_exit() void factor_vm::primitive_nano_count() { u64 nanos = nano_count(); - if(nanos < last_nano_count) critical_error("Monotonic counter decreased",0); + if(nanos < last_nano_count) + { + std::cout << "Monotonic counter decreased from 0x"; + std::cout << std::hex << last_nano_count; + std::cout << " to 0x" << nanos << "." << std::dec << "\n"; + std::cout << "Please report this error.\n"; + current_vm()->factorbug(); + } last_nano_count = nanos; ctx->push(from_unsigned_8(nanos)); } diff --git a/vm/to_tenured_collector.cpp b/vm/to_tenured_collector.cpp index b29affc480..4d11cdb27b 100644 --- a/vm/to_tenured_collector.cpp +++ b/vm/to_tenured_collector.cpp @@ -30,15 +30,17 @@ void factor_vm::collect_to_tenured() collector.trace_roots(); collector.trace_contexts(); - current_gc->event->started_card_scan(); + gc_event *event = current_gc->event; + + if(event) event->started_card_scan(); collector.trace_cards(data->tenured, card_points_to_aging, full_unmarker()); - current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned); + if(event) event->ended_card_scan(collector.cards_scanned,collector.decks_scanned); - current_gc->event->started_code_scan(); + if(event) event->started_code_scan(); collector.trace_code_heap_roots(&code->points_to_aging); - current_gc->event->ended_code_scan(collector.code_blocks_scanned); + if(event) event->ended_code_scan(collector.code_blocks_scanned); collector.tenure_reachable_objects(); diff --git a/vm/utilities.cpp b/vm/utilities.cpp index 3e976d0619..11d3de78cc 100755 --- a/vm/utilities.cpp +++ b/vm/utilities.cpp @@ -14,7 +14,8 @@ vm_char *safe_strdup(const vm_char *str) cell read_cell_hex() { cell cell; - if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1); + std::cin >> std::hex >> cell >> std::dec; + if(!std::cin.good()) exit(1); return cell; } diff --git a/vm/vm.hpp b/vm/vm.hpp index 90e1184c7c..d9c7186c4e 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -35,7 +35,7 @@ struct factor_vm int callback_id; /* Pooling unused contexts to make context allocation cheaper */ - std::vector unused_contexts; + std::list unused_contexts; /* Active contexts, for tracing by the GC */ std::set active_contexts; @@ -49,12 +49,11 @@ struct factor_vm /* Is call counting enabled? */ bool profiling_p; - /* Global variables used to pass fault handler state from signal handler to - user-space */ + /* Global variables used to pass fault handler state from signal handler + to VM */ cell signal_number; cell signal_fault_addr; unsigned int signal_fpu_status; - stack_frame *signal_callstack_top; /* GC is off during heap walking */ bool gc_off; @@ -168,15 +167,13 @@ struct factor_vm void primitive_profiling(); // errors - void throw_error(cell error, stack_frame *stack); - void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *stack); void general_error(vm_error_type error, cell arg1, cell arg2); void type_error(cell type, cell tagged); void not_implemented_error(); - void memory_protection_error(cell addr, stack_frame *stack); - void signal_error(cell signal, stack_frame *stack); + void memory_protection_error(cell addr); + void signal_error(cell signal); void divide_by_zero_error(); - void fp_trap_error(unsigned int fpu_status, stack_frame *stack); + void fp_trap_error(unsigned int fpu_status); void primitive_unimplemented(); void memory_signal_handler_impl(); void misc_signal_handler_impl(); @@ -301,6 +298,7 @@ struct factor_vm // gc void end_gc(); + void set_current_gc_op(gc_op op); void start_gc_again(); void update_code_heap_for_minor_gc(std::set *remembered_set); void collect_nursery(); @@ -464,7 +462,6 @@ struct factor_vm void primitive_float_subtract(); void primitive_float_multiply(); void primitive_float_divfloat(); - void primitive_float_mod(); void primitive_float_less(); void primitive_float_lesseq(); void primitive_float_greater(); @@ -589,6 +586,7 @@ struct factor_vm cell frame_scan(stack_frame *frame); cell frame_offset(stack_frame *frame); void set_frame_offset(stack_frame *frame, cell offset); + void scrub_return_address(); void primitive_callstack_to_array(); stack_frame *innermost_stack_frame(callstack *stack); void primitive_innermost_stack_frame_executing(); @@ -654,7 +652,10 @@ struct factor_vm // entry points void c_to_factor(cell quot); + template Func get_entry_point(cell n); void unwind_native_frames(cell quot, stack_frame *to); + cell get_fpu_state(); + void set_fpu_state(cell state); // factor void default_parameters(vm_parameters *p);