@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
- @echo "wince-arm"
@echo "winnt-x86-32"
@echo "winnt-x86-64"
@echo ""
$(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
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
!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 \
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 \
vm\to_tenured_collector.obj \
vm\tuples.obj \
vm\utilities.obj \
- vm\vm.obj \
+ vm\vm.obj \
vm\words.obj
.cpp.obj:
[ 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
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 -- )
{
{ $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." } ;
-{ <c-object> 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." } ;
{ $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." }
$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:"
M: word <c-array>
c-array-constructor execute( len -- array ) ; inline
+M: pointer <c-array>
+ drop void* <c-array> ;
+
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: <c-direct-array> ( alien len c-type -- array )
M: word <c-direct-array>
c-direct-array-constructor execute( alien len -- array ) ; inline
+M: pointer <c-direct-array>
+ drop void* <c-direct-array> ;
+
: malloc-array ( n type -- array )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: (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 ;
[ 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...
: 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) <pointer> ] }
- { [ dup search ] [ parse-c-type-name ] }
+ { [ "*" ?tail ] [ (parse-c-type) <pointer> ] }
+ { [ 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 ;
USING: alien.c-types alien.prettyprint alien.syntax\r
-io.streams.string see tools.test prettyprint ;\r
+io.streams.string see tools.test prettyprint\r
+io.encodings.ascii ;\r
IN: alien.prettyprint.tests\r
\r
CONSTANT: FOO 10\r
[ "USING: alien.c-types alien.syntax ;\r
IN: alien.prettyprint.tests\r
FUNCTION: int function_test\r
- ( float x, int[4][FOO] y, char* z, ushort* w ) ;\r
+ ( float x, int[4][FOO] y, char* z, ushort* w ) ; inline\r
" ] [\r
[ \ function_test see ] with-string-writer\r
] unit-test\r
[ "USING: alien.c-types alien.syntax ;\r
IN: alien.prettyprint.tests\r
FUNCTION-ALIAS: function-test int function_test\r
- ( float x, int[4][FOO] y, char* z, ushort* w ) ;\r
+ ( float x, int[4][FOO] y, char* z, ushort* w ) ; inline\r
" ] [\r
[ \ function-test see ] with-string-writer\r
] unit-test\r
\r
+TYPEDEF: c-string[ascii] string-typedef\r
+TYPEDEF: char[1][2][3] array-typedef\r
+\r
+[ "USING: alien.c-types alien.syntax ;\r
+IN: alien.prettyprint.tests\r
+TYPEDEF: c-string[ascii] string-typedef\r
+" ] [\r
+ [ \ string-typedef see ] with-string-writer\r
+] unit-test\r
+\r
+[ "USING: alien.c-types alien.syntax ;\r
+IN: alien.prettyprint.tests\r
+TYPEDEF: char[1][2][3] array-typedef\r
+" ] [\r
+ [ \ array-typedef see ] with-string-writer\r
+] unit-test\r
+\r
C-TYPE: opaque-c-type\r
\r
[ "USING: alien.syntax ;\r
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 ;
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 ;
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 ;
{
"winnt-x86.32" "unix-x86.32"
"winnt-x86.64" "unix-x86.64"
- "linux-ppc" "macosx-ppc"
} ;
<PRIVATE
SPECIAL-OBJECT: c-to-factor-word 42
SPECIAL-OBJECT: lazy-jit-compile-word 43
SPECIAL-OBJECT: unwind-native-frames-word 44
+SPECIAL-OBJECT: fpu-state-word 45
+SPECIAL-OBJECT: set-fpu-state-word 46
SPECIAL-OBJECT: callback-stub 48
\ c-to-factor c-to-factor-word set
\ lazy-jit-compile lazy-jit-compile-word set
\ unwind-native-frames unwind-native-frames-word set
+ \ fpu-state fpu-state-word set
+ \ set-fpu-state set-fpu-state-word set
undefined-def undefined-quot set ;
: emit-special-objects ( -- )
"io.backend." {
{ [ "io-backend" get ] [ "io-backend" get ] }
{ [ os unix? ] [ "unix." os name>> append ] }
- { [ os winnt? ] [ "windows.nt" ] }
+ { [ os windows? ] [ "windows" ] }
} cond append require
] when
(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
-! 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 ] }
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
CAIRO_STATUS_INVALID_INDEX
CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
CAIRO_STATUS_TEMP_FILE_ERROR
- CAIRO_STATUS_INVALID_STRIDE ;
-
-TYPEDEF: int cairo_content_t
-CONSTANT: CAIRO_CONTENT_COLOR HEX: 1000
-CONSTANT: CAIRO_CONTENT_ALPHA HEX: 2000
-CONSTANT: 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
+ 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 ;
+
+ENUM: cairo_content_t
+ { CAIRO_CONTENT_COLOR HEX: 1000 }
+ { CAIRO_CONTENT_ALPHA HEX: 2000 }
+ { CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 } ;
+
+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 ) ;
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 ) ;
cairo_pop_group_to_source ( cairo_t* cr ) ;
! Modify state
+
ENUM: cairo_operator_t
CAIRO_OPERATOR_CLEAR
cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
! Path creation functions
+
FUNCTION: void
cairo_new_path ( cairo_t* cr ) ;
cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
! Painting functions
+
FUNCTION: void
cairo_paint ( cairo_t* cr ) ;
cairo_show_page ( cairo_t* cr ) ;
! Insideness testing
+
FUNCTION: cairo_bool_t
cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
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 ) ;
cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
! Clipping
+
FUNCTION: void
cairo_reset_clip ( cairo_t* cr ) ;
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 }
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 ) ;
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 ) ;
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 ) ;
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
{ 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 ) ;
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 ) ;
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 ) ;
! 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 ) ;
{ $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
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:"
"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:"
! 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: <remote-channel>
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 "
--- /dev/null
+John Benediktsson
--- /dev/null
+! 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
+
--- /dev/null
+! 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 <sliced-groups> [ le> + ] each
+ [ -16 shift ] [ HEX: ffff bitand ] bi +
+ [ -16 shift ] keep + bitnot 2 >le ;
+
--- /dev/null
+Internet (RFC 1071) checksum algorithm
STRUCT: struct-test-equality-2
{ y int } ;
+[ 0 ] [ struct-test-equality-1 new hashcode ] unit-test
+
[ t ] [
[
struct-test-equality-1 <struct> 5 >>x
7 >>a
8 >>b
] unit-test
+
+SPECIALIZED-ARRAY: void*
+
+STRUCT: silly-array-field-test { x int*[3] } ;
+
+[ t ] [ silly-array-field-test <struct> x>> void*-array? ] unit-test
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 <direct-uchar-array> hashcode* ; inline
+ binary-object over
+ [ <direct-uchar-array> hashcode* ] [ 3drop 0 ] if ; inline
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
! 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
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
[ [ make-local ] map ] H{ } make-assoc
(parse-lambda) <lambda> ?rewrite-closures first ;
-: method-effect ( quadruple -- effect )
- [ third ] [ second void? { } { "x" } ? ] bi <effect> ;
-
-: 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! ;
--- /dev/null
+Jon Harper
--- /dev/null
+! 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"
--- /dev/null
+! 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
--- /dev/null
+! 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
+
+<PRIVATE
+
+: with-drop ( quot -- quot' ) [ drop ] prepend ; inline
+
+: prepare-pair ( pair -- pair' )
+ first2 [ [ [ - ] [ < ] 2bi ] curry ] [ with-drop ] bi* 2array ;
+
+ERROR: bad-probabilities assoc ;
+
+M: bad-probabilities summary
+ drop "The probabilities do not satisfy the rules stated in the docs." ;
+
+: good-probabilities? ( assoc -- ? )
+ dup last pair? [
+ keys { [ sum 1 number= ] [ [ 0 1 between? ] all? ] } 1&&
+ ] [
+ but-last keys { [ sum 0 1 between? ] [ [ 0 1 between? ] all? ] } 1&&
+ ] if ;
+
+! Useful for unit-tests (no random part)
+: (casep>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
"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." } }
} ;
} 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
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 }
}
] [
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
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 }
}
] [
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
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
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
[ 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 ;
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
\ ##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 ]
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 ;
(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
: 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
{ 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
: (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
-! 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 ;
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 ;
! 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
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
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
: 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 ;
UNION: memory-insn
##load-memory ##load-memory-imm
##store-memory ##store-memory-imm
+ ##write-barrier ##write-barrier-imm
alien-call-insn
slot-insn ;
! 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
} 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
! 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
} 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
[
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 }
}
] [
[
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 }
}
] [
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
! { 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 ;
! will be in a register.
UNION: clobber-insn
hairy-clobber-insn
-##unary-float-function
-##binary-float-function
##unbox
##box
##box-long-long ;
: 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 ;
{ 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 ] }
M: sync-point handle ( sync-point -- )
[ n>> deactivate-intervals ]
- [ handle-sync-point ]
[ n>> activate-intervals ]
+ [ handle-sync-point ]
tri ;
: smallest-heap ( heap1 heap2 -- heap )
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 ;
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 ;
} 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
M: insn compute-sync-points* drop ;
: compute-live-intervals-step ( bb -- )
- {
- [ block-from from set ]
- [ block-to to set ]
- [ handle-live-out ]
- [
- instructions>> <reversed> [
- [ 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>> <reversed> [
+ [ compute-live-intervals* ]
+ [ compute-sync-points* ]
+ bi
+ ] each
+ ]
+ } cleave
+ ] if ;
: init-live-intervals ( -- )
H{ } clone live-intervals set
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
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 }
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' )
alias-analysis
value-numbering
copy-propagation
- eliminate-dead-code
- eliminate-write-barriers ;
+ eliminate-dead-code ;
: init-components ( cfg components -- )
'[
- instructions>> [
+ [
defs-vregs [ _ add-atom ] each
] each
- ] each-basic-block ;
+ ] simple-analysis ;
GENERIC# visit-insn 1 ( insn disjoint-set -- )
: merge-components ( cfg components -- )
'[
- instructions>> [
+ [
_ visit-insn
] each
- ] each-basic-block ;
+ ] simple-analysis ;
: compute-components ( cfg -- )
<disjoint-set>
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 }
! 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 -- ? )
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{
1 3 edge
2 3 edge
-: test-ssa ( -- )
- cfg new 0 get >>entry
- dup cfg set
- construct-ssa
- drop ;
-
[ ] [ test-ssa ] unit-test
[
}
] [ 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 } } }
clean-up-phis
] unit-test
+! Test 2
reset-counters
V{ } 0 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
! 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
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
[ 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
+ <hashed-dlist> used-vregs set
H{ } clone stacks set ;
: gen-name ( vreg -- vreg' )
[ 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 ] [ ]
[ 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 -- )
: 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 ;
[ 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 ;
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>
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 ;
--- /dev/null
+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
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? ;
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 )
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
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
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
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 <array>
+ ! 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 <array> 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
USING: tools.test namespaces assocs alien.syntax kernel\r
-compiler.errors accessors alien ;\r
+compiler.errors accessors alien alien.c-types ;\r
FROM: alien.libraries => add-library ;\r
IN: compiler.tests.linkage-errors\r
\r
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 )
[ list instance? ] compile-call
] unit-test
+! <tuple> type function bustage
+[ T{ cons } 7 ] [ cons tuple-layout [ [ <tuple> ] [ length ] bi ] compile-call ] unit-test
+
! Regression
: interval-inference-bug ( obj -- obj x )
dup "a" get { array-capacity } declare >=
--- /dev/null
+USING: tools.test compiler.units classes.mixin definitions\r
+kernel kernel.private ;\r
+IN: compiler.tests.redefine25\r
+\r
+MIXIN: empty-mixin\r
+\r
+: empty-mixin-test-1 ( a -- ? ) empty-mixin? ;\r
+\r
+TUPLE: a-superclass ;\r
+\r
+: empty-mixin-test-2 ( a -- ? ) { a-superclass } declare empty-mixin? ;\r
+\r
+TUPLE: empty-mixin-member < a-superclass ;\r
+\r
+[ f ] [ empty-mixin-member new empty-mixin? ] unit-test\r
+[ f ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test\r
+[ f ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test\r
+\r
+[ ] [\r
+ [\r
+ \ empty-mixin-member \ empty-mixin add-mixin-instance\r
+ ] with-compilation-unit\r
+] unit-test\r
+\r
+[ t ] [ empty-mixin-member new empty-mixin? ] unit-test\r
+[ t ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test\r
+[ t ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test\r
+\r
+[ ] [\r
+ [\r
+ \ empty-mixin forget\r
+ \ empty-mixin-member forget\r
+ ] with-compilation-unit\r
+] unit-test\r
--- /dev/null
+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
: 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 ;
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 )
[
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 ;
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
[ cleanup ] change-child
dup label>> calls>> empty? [ flatten-recursive ] when ;
+M: #alien-callback cleanup*
+ [ cleanup ] change-child ;
+
M: node cleanup* ;
-! 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' )
M: #alien-node remove-dead-code*
maybe-drop-dead-outputs ;
+
+M: #alien-callback remove-dead-code*
+ [ (remove-dead-code) ] change-child ;
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
compiler.tree.dead-code
compiler.tree.modular-arithmetic ;
FROM: fry => _ ;
+FROM: namespaces => set ;
RENAME: _ match => __
IN: compiler.tree.debugger
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 ;
] 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? ;
: 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* ]
[ out-d>> unknown-allocations ]
bi ;
-M: #alien-callback escape-analysis* drop ;
+M: #alien-callback escape-analysis*
+ child>> (escape-analysis) ;
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 ;
] [ 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
-! 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
GENERIC: propagate-around ( node -- )
-: (propagate) ( node -- )
+: (propagate) ( nodes -- )
[ [ compute-copy-equiv ] [ propagate-around ] bi ] each ;
: extract-value-info ( values -- assoc )
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
recover ;
: predicate-output-infos/class ( info class -- info )
- [ class>> ] dip compare-classes
+ [ class>> ] dip evaluate-class-predicate
dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
: predicate-output-infos ( info class -- info )
M: #alien-node propagate-before propagate-alien-invoke ;
+M: #alien-callback propagate-around child>> (propagate) ;
+
M: #return annotate-node dup in-d>> (annotate-node) ;
-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
[ { 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
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 ;
: #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 ;
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 -- )
[ 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
parallel-cleave\r
parallel-spread\r
parallel-napply\r
-} ;\r
+}\r
+"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjuction with the above combinators to limit the maximum number of concurrent operations." ;\r
\r
ABOUT: "concurrency.combinators"\r
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
" 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"
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 <local> ] }
+ { [ os windows? ] [ test-ip 0 <inet4> ] }
+ } cond <node-server> ;
+
+: test-node-client ( -- addrspec )
{
{ [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
- { [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
+ { [ os windows? ] [ test-ip insecure-port <inet4> ] }
} cond ;
+
[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
-[ ] [ test-node dup (start-node) ] 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" <remote-thread> send
-
- receive
-] 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
-[ ] [ test-node stop-node ] unit-test
+ [ 8 ] [
+ 5 self 2array
+ test-node-client "thread-a" <remote-thread> send
+ 100 seconds receive-timeout
+ ] unit-test
+] with-threaded-server
\ No newline at end of file
: 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* ;
"concurrency.distributed" >>name
[ handle-node-client ] >>handler ;
-: (start-node) ( addrspec addrspec -- )
- local-node set-global <node-server> start-server* ;
-
-: start-node ( port -- )
- host-name over <inet> (start-node) ;
-
TUPLE: remote-thread node id ;
C: <remote-thread> remote-thread
send-remote-message ;
M: thread (serialize) ( obj -- )
- id>> [ local-node get-global ] dip <remote-thread>
- (serialize) ;
+ id>> [ insecure-addr ] dip <remote-thread> (serialize) ;
: stop-node ( node -- )
f swap send-remote-message ;
USING: help.markup help.syntax kernel quotations calendar ;\r
\r
HELP: semaphore\r
-{ $class-description "The class of counting semaphores." } ;\r
+{ $class-description "The class of counting semaphores. New instances can be created by calling " { $link <semaphore> } "." } ;\r
\r
HELP: <semaphore>\r
{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } }\r
{ $values { "semaphore" semaphore } { "quot" quotation } }\r
{ $description "Calls the quotation with the semaphore held." } ;\r
\r
-ARTICLE: "concurrency.semaphores" "Counting semaphores"\r
-"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."\r
-$nl\r
+ARTICLE: "concurrency.semaphores.examples" "Semaphore examples"\r
"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:"\r
{ $code\r
"SYMBOL: expensive-section"\r
- "10 <semaphore> expensive-section set-global"\r
- "requests ["\r
+ "requests"\r
+ "10 <semaphore> '["\r
" ..."\r
- " expensive-section [ do-expensive-stuff ] with-semaphore"\r
+ " _ [ do-expensive-stuff ] with-semaphore"\r
" ..."\r
"] parallel-map"\r
}\r
+"Here is a concrete example which fetches content from 5 different web sites, making no more than 3 requests at a time:"\r
+{ $code\r
+ """USING: concurrency.combinators concurrency.semaphores\r
+fry http.client kernel urls ;\r
+\r
+{\r
+ URL" http://www.apple.com"\r
+ URL" http://www.google.com"\r
+ URL" http://www.ibm.com"\r
+ URL" http://www.hp.com"\r
+ URL" http://www.oracle.com"\r
+}\r
+2 <semaphore> '[\r
+ _ [\r
+ http-get nip\r
+ ] with-semaphore\r
+] parallel-map"""\r
+} ;\r
+\r
+ARTICLE: "concurrency.semaphores" "Counting semaphores"\r
+"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."\r
+{ $subsections "concurrency.semaphores.examples" }\r
"Creating semaphores:"\r
{ $subsections\r
semaphore\r
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 -- )
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 )
+++ /dev/null
-IN: cpu.arm.assembler.tests
-USING: cpu.arm.assembler math tools.test namespaces make
-sequences kernel quotations ;
-FROM: cpu.arm.assembler => B ;
-
-: test-opcode ( expect quot -- ) [ { } make first ] curry unit-test ;
-
-[ HEX: ea000000 ] [ 0 B ] test-opcode
-[ HEX: eb000000 ] [ 0 BL ] test-opcode
-! [ HEX: e12fff30 ] [ R0 BLX ] test-opcode
-
-[ HEX: e24cc004 ] [ IP IP 4 SUB ] test-opcode
-[ HEX: e24cb004 ] [ FP IP 4 SUB ] test-opcode
-[ HEX: e087e3ac ] [ LR R7 IP 7 <LSR> ADD ] test-opcode
-[ HEX: e08c0109 ] [ R0 IP R9 2 <LSL> ADD ] test-opcode
-[ HEX: 02850004 ] [ R0 R5 4 EQ ADD ] test-opcode
-[ HEX: 00000000 ] [ R0 R0 R0 EQ AND ] test-opcode
-
-[ HEX: e1a0c00c ] [ IP IP MOV ] test-opcode
-[ HEX: e1a0c00d ] [ IP SP MOV ] test-opcode
-[ HEX: e3a03003 ] [ R3 3 MOV ] test-opcode
-[ HEX: e1a00003 ] [ R0 R3 MOV ] test-opcode
-[ HEX: e1e01c80 ] [ R1 R0 25 <LSL> MVN ] test-opcode
-[ HEX: e1e00ca1 ] [ R0 R1 25 <LSR> MVN ] test-opcode
-[ HEX: 11a021ac ] [ R2 IP 3 <LSR> NE MOV ] test-opcode
-
-[ HEX: e3530007 ] [ R3 7 CMP ] test-opcode
-
-[ HEX: e008049a ] [ R8 SL R4 MUL ] test-opcode
-
-[ HEX: e5151004 ] [ R1 R5 4 <-> LDR ] test-opcode
-[ HEX: e41c2004 ] [ R2 IP 4 <-!> LDR ] test-opcode
-[ HEX: e50e2004 ] [ R2 LR 4 <-> STR ] test-opcode
-
-[ HEX: e7910002 ] [ R0 R1 R2 <+> LDR ] test-opcode
-[ HEX: e7910102 ] [ R0 R1 R2 2 <LSL> <+> LDR ] test-opcode
-
-[ HEX: e1d310bc ] [ R1 R3 12 <+> LDRH ] test-opcode
-[ HEX: e1d310fc ] [ R1 R3 12 <+> LDRSH ] test-opcode
-[ HEX: e1d310dc ] [ R1 R3 12 <+> LDRSB ] test-opcode
-[ HEX: e1c310bc ] [ R1 R3 12 <+> STRH ] test-opcode
-[ HEX: e19310b4 ] [ R1 R3 R4 <+> LDRH ] test-opcode
-[ HEX: e1f310fc ] [ R1 R3 12 <!+> LDRSH ] test-opcode
-[ HEX: e1b310d4 ] [ R1 R3 R4 <!+> LDRSB ] test-opcode
-[ HEX: e0c317bb ] [ R1 R3 123 <+!> STRH ] test-opcode
-[ HEX: e08310b4 ] [ R1 R3 R4 <+!> STRH ] test-opcode
+++ /dev/null
-! Copyright (C) 2007, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators kernel make math math.bitwise
-namespaces sequences words words.symbol parser ;
-IN: cpu.arm.assembler
-
-! Registers
-<<
-
-SYMBOL: registers
-
-V{ } registers set-global
-
-SYNTAX: REGISTER:
- CREATE-WORD
- [ define-symbol ]
- [ registers get length "register" set-word-prop ]
- [ registers get push ]
- tri ;
-
->>
-
-REGISTER: R0
-REGISTER: R1
-REGISTER: R2
-REGISTER: R3
-REGISTER: R4
-REGISTER: R5
-REGISTER: R6
-REGISTER: R7
-REGISTER: R8
-REGISTER: R9
-REGISTER: R10
-REGISTER: R11
-REGISTER: R12
-REGISTER: R13
-REGISTER: R14
-REGISTER: R15
-
-ALIAS: SL R10 ALIAS: FP R11 ALIAS: IP R12
-ALIAS: SP R13 ALIAS: LR R14 ALIAS: PC R15
-
-<PRIVATE
-
-PREDICATE: register < word register >boolean ;
-
-GENERIC: register ( register -- n )
-M: word register "register" word-prop ;
-M: f register drop 0 ;
-
-PRIVATE>
-
-! Condition codes
-SYMBOL: cond-code
-
-: >CC ( n -- )
- cond-code set ;
-
-: CC> ( -- n )
- #! Default value is BIN: 1110 AL (= always)
- cond-code [ f ] change BIN: 1110 or ;
-
-: EQ ( -- ) BIN: 0000 >CC ;
-: NE ( -- ) BIN: 0001 >CC ;
-: CS ( -- ) BIN: 0010 >CC ;
-: CC ( -- ) BIN: 0011 >CC ;
-: LO ( -- ) BIN: 0100 >CC ;
-: PL ( -- ) BIN: 0101 >CC ;
-: VS ( -- ) BIN: 0110 >CC ;
-: VC ( -- ) BIN: 0111 >CC ;
-: HI ( -- ) BIN: 1000 >CC ;
-: LS ( -- ) BIN: 1001 >CC ;
-: GE ( -- ) BIN: 1010 >CC ;
-: LT ( -- ) BIN: 1011 >CC ;
-: GT ( -- ) BIN: 1100 >CC ;
-: LE ( -- ) BIN: 1101 >CC ;
-: AL ( -- ) BIN: 1110 >CC ;
-: NV ( -- ) BIN: 1111 >CC ;
-
-<PRIVATE
-
-: (insn) ( n -- ) CC> 28 shift bitor , ;
-
-: insn ( bitspec -- ) bitfield (insn) ; inline
-
-! Branching instructions
-GENERIC# (B) 1 ( target l -- )
-
-M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
-
-PRIVATE>
-
-: B ( target -- ) 0 (B) ;
-: BL ( target -- ) 1 (B) ;
-
-! Data processing instructions
-<PRIVATE
-
-SYMBOL: updates-cond-code
-
-PRIVATE>
-
-: S ( -- ) updates-cond-code on ;
-
-: S> ( -- ? ) updates-cond-code [ f ] change ;
-
-<PRIVATE
-
-: sinsn ( bitspec -- )
- bitfield S> [ 20 2^ bitor ] when (insn) ; inline
-
-GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n )
-
-M: integer shift-imm/reg ( shift-imm Rm shift -- n )
- { { 0 4 } 5 { register 0 } 7 } bitfield ;
-
-M: register shift-imm/reg ( Rs Rm shift -- n )
- {
- { 1 4 }
- { 0 7 }
- 5
- { register 8 }
- { register 0 }
- } bitfield ;
-
-PRIVATE>
-
-TUPLE: IMM immed rotate ;
-C: <IMM> IMM
-
-TUPLE: shifter Rm by shift ;
-C: <shifter> shifter
-
-<PRIVATE
-
-GENERIC: shifter-op ( shifter-op -- n )
-
-M: IMM shifter-op
- [ immed>> ] [ rotate>> ] bi { { 1 25 } 8 0 } bitfield ;
-
-M: shifter shifter-op
- [ by>> ] [ Rm>> ] [ shift>> ] tri shift-imm/reg ;
-
-PRIVATE>
-
-: <LSL> ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 <shifter> ;
-: <LSR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 <shifter> ;
-: <ASR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 <shifter> ;
-: <ROR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 <shifter> ;
-: <RRX> ( Rm -- shifter-op ) 0 <ROR> ;
-
-M: register shifter-op 0 <LSL> shifter-op ;
-M: integer shifter-op 0 <IMM> shifter-op ;
-
-<PRIVATE
-
-: addr1 ( Rd Rn shifter-op opcode -- )
- {
- 21 ! opcode
- { shifter-op 0 }
- { register 16 } ! Rn
- { register 12 } ! Rd
- } sinsn ;
-
-PRIVATE>
-
-: AND ( Rd Rn shifter-op -- ) BIN: 0000 addr1 ;
-: EOR ( Rd Rn shifter-op -- ) BIN: 0001 addr1 ;
-: SUB ( Rd Rn shifter-op -- ) BIN: 0010 addr1 ;
-: RSB ( Rd Rn shifter-op -- ) BIN: 0011 addr1 ;
-: ADD ( Rd Rn shifter-op -- ) BIN: 0100 addr1 ;
-: ADC ( Rd Rn shifter-op -- ) BIN: 0101 addr1 ;
-: SBC ( Rd Rn shifter-op -- ) BIN: 0110 addr1 ;
-: RSC ( Rd Rn shifter-op -- ) BIN: 0111 addr1 ;
-: ORR ( Rd Rn shifter-op -- ) BIN: 1100 addr1 ;
-: BIC ( Rd Rn shifter-op -- ) BIN: 1110 addr1 ;
-
-: MOV ( Rd shifter-op -- ) [ f ] dip BIN: 1101 addr1 ;
-: MVN ( Rd shifter-op -- ) [ f ] dip BIN: 1111 addr1 ;
-
-! These always update the condition code flags
-<PRIVATE
-
-: (CMP) ( Rn shifter-op opcode -- ) [ f ] 3dip S addr1 ;
-
-PRIVATE>
-
-: TST ( Rn shifter-op -- ) BIN: 1000 (CMP) ;
-: TEQ ( Rn shifter-op -- ) BIN: 1001 (CMP) ;
-: CMP ( Rn shifter-op -- ) BIN: 1010 (CMP) ;
-: CMN ( Rn shifter-op -- ) BIN: 1011 (CMP) ;
-
-! Multiply instructions
-<PRIVATE
-
-: (MLA) ( Rd Rm Rs Rn a -- )
- {
- 21
- { register 12 }
- { register 8 }
- { register 0 }
- { register 16 }
- { 1 7 }
- { 1 4 }
- } sinsn ;
-
-: (S/UMLAL) ( RdLo RdHi Rm Rs s a -- )
- {
- { 1 23 }
- 22
- 21
- { register 8 }
- { register 0 }
- { register 16 }
- { register 12 }
- { 1 7 }
- { 1 4 }
- } sinsn ;
-
-PRIVATE>
-
-: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
-: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
-
-: SMLAL ( RdLo RdHi Rm Rs -- ) 1 1 (S/UMLAL) ;
-: SMULL ( RdLo RdHi Rm Rs -- ) 1 0 (S/UMLAL) ;
-: UMLAL ( RdLo RdHi Rm Rs -- ) 0 1 (S/UMLAL) ;
-: UMULL ( RdLo RdHi Rm Rs -- ) 0 0 (S/UMLAL) ;
-
-! Miscellaneous arithmetic instructions
-: CLZ ( Rd Rm -- )
- {
- { 1 24 }
- { 1 22 }
- { 1 21 }
- { BIN: 111 16 }
- { BIN: 1111 8 }
- { 1 4 }
- { register 0 }
- { register 12 }
- } sinsn ;
-
-! Status register acess instructions
-
-! Load and store instructions
-<PRIVATE
-
-GENERIC: addressing-mode-2 ( addressing-mode -- n )
-
-TUPLE: addressing base p u w ;
-C: <addressing> addressing
-
-M: addressing addressing-mode-2
- { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-2 ] } cleave
- { 0 21 23 24 } bitfield ;
-
-M: integer addressing-mode-2 ;
-
-M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
-
-: addr2 ( Rd Rn addressing-mode b l -- )
- {
- { 1 26 }
- 20
- 22
- { addressing-mode-2 0 }
- { register 16 }
- { register 12 }
- } insn ;
-
-PRIVATE>
-
-! Offset
-: <+> ( base -- addressing ) 1 1 0 <addressing> ;
-: <-> ( base -- addressing ) 1 0 0 <addressing> ;
-
-! Pre-indexed
-: <!+> ( base -- addressing ) 1 1 1 <addressing> ;
-: <!-> ( base -- addressing ) 1 0 1 <addressing> ;
-
-! Post-indexed
-: <+!> ( base -- addressing ) 0 1 0 <addressing> ;
-: <-!> ( base -- addressing ) 0 0 0 <addressing> ;
-
-: LDR ( Rd Rn addressing-mode -- ) 0 1 addr2 ;
-: LDRB ( Rd Rn addressing-mode -- ) 1 1 addr2 ;
-: STR ( Rd Rn addressing-mode -- ) 0 0 addr2 ;
-: STRB ( Rd Rn addressing-mode -- ) 1 0 addr2 ;
-
-! We might have to simulate these instructions since older ARM
-! chips don't have them.
-SYMBOL: have-BX?
-SYMBOL: have-BLX?
-
-<PRIVATE
-
-GENERIC# (BX) 1 ( Rm l -- )
-
-M: register (BX) ( Rm l -- )
- {
- { 1 24 }
- { 1 21 }
- { BIN: 1111 16 }
- { BIN: 1111 12 }
- { BIN: 1111 8 }
- 5
- { 1 4 }
- { register 0 }
- } insn ;
-
-PRIVATE>
-
-: BX ( Rm -- ) have-BX? get [ 0 (BX) ] [ [ PC ] dip MOV ] if ;
-
-: BLX ( Rm -- ) have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
-
-! More load and store instructions
-<PRIVATE
-
-GENERIC: addressing-mode-3 ( addressing-mode -- n )
-
-: b>n/n ( b -- n n ) [ -4 shift ] [ HEX: f bitand ] bi ;
-
-M: addressing addressing-mode-3
- { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-3 ] } cleave
- { 0 21 23 24 } bitfield ;
-
-M: integer addressing-mode-3
- b>n/n {
- ! { 1 24 }
- { 1 22 }
- { 1 7 }
- { 1 4 }
- 0
- 8
- } bitfield ;
-
-M: object addressing-mode-3
- shifter-op {
- ! { 1 24 }
- { 1 7 }
- { 1 4 }
- 0
- } bitfield ;
-
-: addr3 ( Rn Rd addressing-mode h l s -- )
- {
- 6
- 20
- 5
- { addressing-mode-3 0 }
- { register 16 }
- { register 12 }
- } insn ;
-
-PRIVATE>
-
-: LDRH ( Rn Rd addressing-mode -- ) 1 1 0 addr3 ;
-: LDRSB ( Rn Rd addressing-mode -- ) 0 1 1 addr3 ;
-: LDRSH ( Rn Rd addressing-mode -- ) 1 1 1 addr3 ;
-: STRH ( Rn Rd addressing-mode -- ) 1 0 0 addr3 ;
-
-! Load and store multiple instructions
-
-! Semaphore instructions
-
-! Exception-generating instructions
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: cpu.ppc.assembler tools.test arrays kernel namespaces
-make vocabs sequences byte-arrays.hex ;
-FROM: cpu.ppc.assembler => B ;
-IN: cpu.ppc.assembler.tests
-
-: test-assembler ( expected quot -- )
- [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
-
-HEX{ 38 22 00 03 } [ 1 2 3 ADDI ] test-assembler
-HEX{ 3c 22 00 03 } [ 1 2 3 ADDIS ] test-assembler
-HEX{ 30 22 00 03 } [ 1 2 3 ADDIC ] test-assembler
-HEX{ 34 22 00 03 } [ 1 2 3 ADDIC. ] test-assembler
-HEX{ 38 40 00 01 } [ 1 2 LI ] test-assembler
-HEX{ 3c 40 00 01 } [ 1 2 LIS ] test-assembler
-HEX{ 38 22 ff fd } [ 1 2 3 SUBI ] test-assembler
-HEX{ 1c 22 00 03 } [ 1 2 3 MULI ] test-assembler
-HEX{ 7c 22 1a 14 } [ 1 2 3 ADD ] test-assembler
-HEX{ 7c 22 1a 15 } [ 1 2 3 ADD. ] test-assembler
-HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
-HEX{ 7c 22 1e 15 } [ 1 2 3 ADDO. ] test-assembler
-HEX{ 7c 22 18 14 } [ 1 2 3 ADDC ] test-assembler
-HEX{ 7c 22 18 15 } [ 1 2 3 ADDC. ] test-assembler
-HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
-HEX{ 7c 22 1c 15 } [ 1 2 3 ADDCO. ] test-assembler
-HEX{ 7c 22 19 14 } [ 1 2 3 ADDE ] test-assembler
-HEX{ 7c 41 18 38 } [ 1 2 3 AND ] test-assembler
-HEX{ 7c 41 18 39 } [ 1 2 3 AND. ] test-assembler
-HEX{ 7c 22 1b d6 } [ 1 2 3 DIVW ] test-assembler
-HEX{ 7c 22 1b 96 } [ 1 2 3 DIVWU ] test-assembler
-HEX{ 7c 41 1a 38 } [ 1 2 3 EQV ] test-assembler
-HEX{ 7c 41 1b b8 } [ 1 2 3 NAND ] test-assembler
-HEX{ 7c 41 18 f8 } [ 1 2 3 NOR ] test-assembler
-HEX{ 7c 41 10 f8 } [ 1 2 NOT ] test-assembler
-HEX{ 60 41 00 03 } [ 1 2 3 ORI ] test-assembler
-HEX{ 64 41 00 03 } [ 1 2 3 ORIS ] test-assembler
-HEX{ 7c 41 1b 78 } [ 1 2 3 OR ] test-assembler
-HEX{ 7c 41 13 78 } [ 1 2 MR ] test-assembler
-HEX{ 7c 22 18 96 } [ 1 2 3 MULHW ] test-assembler
-HEX{ 1c 22 00 03 } [ 1 2 3 MULLI ] test-assembler
-HEX{ 7c 22 18 16 } [ 1 2 3 MULHWU ] test-assembler
-HEX{ 7c 22 19 d6 } [ 1 2 3 MULLW ] test-assembler
-HEX{ 7c 41 18 30 } [ 1 2 3 SLW ] test-assembler
-HEX{ 7c 41 1e 30 } [ 1 2 3 SRAW ] test-assembler
-HEX{ 7c 41 1c 30 } [ 1 2 3 SRW ] test-assembler
-HEX{ 7c 41 1e 70 } [ 1 2 3 SRAWI ] test-assembler
-HEX{ 7c 22 18 50 } [ 1 2 3 SUBF ] test-assembler
-HEX{ 7c 22 18 10 } [ 1 2 3 SUBFC ] test-assembler
-HEX{ 7c 22 19 10 } [ 1 2 3 SUBFE ] test-assembler
-HEX{ 7c 41 07 74 } [ 1 2 EXTSB ] test-assembler
-HEX{ 68 41 00 03 } [ 1 2 3 XORI ] test-assembler
-HEX{ 7c 41 1a 78 } [ 1 2 3 XOR ] test-assembler
-HEX{ 7c 22 00 d0 } [ 1 2 NEG ] test-assembler
-HEX{ 2c 22 00 03 } [ 1 2 3 CMPI ] test-assembler
-HEX{ 28 22 00 03 } [ 1 2 3 CMPLI ] test-assembler
-HEX{ 7c 41 18 00 } [ 1 2 3 CMP ] test-assembler
-HEX{ 54 22 19 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
-HEX{ 54 22 18 38 } [ 1 2 3 SLWI ] test-assembler
-HEX{ 54 22 e8 fe } [ 1 2 3 SRWI ] test-assembler
-HEX{ 88 22 00 03 } [ 1 2 3 LBZ ] test-assembler
-HEX{ 8c 22 00 03 } [ 1 2 3 LBZU ] test-assembler
-HEX{ a8 22 00 03 } [ 1 2 3 LHA ] test-assembler
-HEX{ ac 22 00 03 } [ 1 2 3 LHAU ] test-assembler
-HEX{ a0 22 00 03 } [ 1 2 3 LHZ ] test-assembler
-HEX{ a4 22 00 03 } [ 1 2 3 LHZU ] test-assembler
-HEX{ 80 22 00 03 } [ 1 2 3 LWZ ] test-assembler
-HEX{ 84 22 00 03 } [ 1 2 3 LWZU ] test-assembler
-HEX{ 7c 41 18 ae } [ 1 2 3 LBZX ] test-assembler
-HEX{ 7c 41 18 ee } [ 1 2 3 LBZUX ] test-assembler
-HEX{ 7c 41 1a ae } [ 1 2 3 LHAX ] test-assembler
-HEX{ 7c 41 1a ee } [ 1 2 3 LHAUX ] test-assembler
-HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler
-HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
-HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
-HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
-HEX{ 7c 41 1c 2e } [ 1 2 3 LFSX ] test-assembler
-HEX{ 7c 41 1c 6e } [ 1 2 3 LFSUX ] test-assembler
-HEX{ 7c 41 1c ae } [ 1 2 3 LFDX ] test-assembler
-HEX{ 7c 41 1c ee } [ 1 2 3 LFDUX ] test-assembler
-HEX{ 7c 41 1d 2e } [ 1 2 3 STFSX ] test-assembler
-HEX{ 7c 41 1d 6e } [ 1 2 3 STFSUX ] test-assembler
-HEX{ 7c 41 1d ae } [ 1 2 3 STFDX ] test-assembler
-HEX{ 7c 41 1d ee } [ 1 2 3 STFDUX ] test-assembler
-HEX{ 48 00 00 01 } [ 1 B ] test-assembler
-HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
-HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
-HEX{ 41 81 00 04 } [ 1 BGT ] test-assembler
-HEX{ 40 81 00 04 } [ 1 BLE ] test-assembler
-HEX{ 40 80 00 04 } [ 1 BGE ] test-assembler
-HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
-HEX{ 40 82 00 04 } [ 1 BNE ] test-assembler
-HEX{ 41 82 00 04 } [ 1 BEQ ] test-assembler
-HEX{ 41 83 00 04 } [ 1 BO ] test-assembler
-HEX{ 40 83 00 04 } [ 1 BNO ] test-assembler
-HEX{ 4c 20 00 20 } [ 1 BCLR ] test-assembler
-HEX{ 4e 80 00 20 } [ BLR ] test-assembler
-HEX{ 4e 80 00 21 } [ BLRL ] test-assembler
-HEX{ 4c 20 04 20 } [ 1 BCCTR ] test-assembler
-HEX{ 4e 80 04 20 } [ BCTR ] test-assembler
-HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
-HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
-HEX{ 7c 69 02 a6 } [ 3 MFCTR ] test-assembler
-HEX{ 7c 61 03 a6 } [ 3 MTXER ] test-assembler
-HEX{ 7c 68 03 a6 } [ 3 MTLR ] test-assembler
-HEX{ 7c 69 03 a6 } [ 3 MTCTR ] test-assembler
-HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
-HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
-HEX{ c0 22 00 03 } [ 1 2 3 LFS ] test-assembler
-HEX{ c4 22 00 03 } [ 1 2 3 LFSU ] test-assembler
-HEX{ c8 22 00 03 } [ 1 2 3 LFD ] test-assembler
-HEX{ cc 22 00 03 } [ 1 2 3 LFDU ] test-assembler
-HEX{ d0 22 00 03 } [ 1 2 3 STFS ] test-assembler
-HEX{ d4 22 00 03 } [ 1 2 3 STFSU ] test-assembler
-HEX{ d8 22 00 03 } [ 1 2 3 STFD ] test-assembler
-HEX{ dc 22 00 03 } [ 1 2 3 STFDU ] test-assembler
-HEX{ fc 20 10 90 } [ 1 2 FMR ] test-assembler
-HEX{ fc 40 08 90 } [ 2 1 FMR ] test-assembler
-HEX{ fc 20 10 91 } [ 1 2 FMR. ] test-assembler
-HEX{ fc 40 08 91 } [ 2 1 FMR. ] test-assembler
-HEX{ fc 20 10 1e } [ 1 2 FCTIWZ ] test-assembler
-HEX{ fc 22 18 2a } [ 1 2 3 FADD ] test-assembler
-HEX{ fc 22 18 2b } [ 1 2 3 FADD. ] test-assembler
-HEX{ fc 22 18 28 } [ 1 2 3 FSUB ] test-assembler
-HEX{ fc 22 00 f2 } [ 1 2 3 FMUL ] test-assembler
-HEX{ fc 22 18 24 } [ 1 2 3 FDIV ] test-assembler
-HEX{ fc 20 10 2c } [ 1 2 FSQRT ] test-assembler
-HEX{ fc 41 18 00 } [ 1 2 3 FCMPU ] test-assembler
-HEX{ fc 41 18 40 } [ 1 2 3 FCMPO ] test-assembler
-HEX{ 3c 60 12 34 60 63 56 78 } [ HEX: 12345678 3 LOAD ] test-assembler
+++ /dev/null
-! Copyright (C) 2005, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces words math math.order locals
-cpu.ppc.assembler.backend ;
-IN: cpu.ppc.assembler
-
-! See the Motorola or IBM documentation for details. The opcode
-! names are standard, and the operand order is the same as in
-! the docs, except a few differences, namely, in IBM/Motorola
-! assembler syntax, loads and stores are written like:
-!
-! stw r14,10(r15)
-!
-! In Factor, we write:
-!
-! 14 15 10 STW
-
-! D-form
-D: ADDI 14
-D: ADDIC 12
-D: ADDIC. 13
-D: ADDIS 15
-D: CMPI 11
-D: CMPLI 10
-D: LBZ 34
-D: LBZU 35
-D: LFD 50
-D: LFDU 51
-D: LFS 48
-D: LFSU 49
-D: LHA 42
-D: LHAU 43
-D: LHZ 40
-D: LHZU 41
-D: LWZ 32
-D: LWZU 33
-D: MULI 7
-D: MULLI 7
-D: STB 38
-D: STBU 39
-D: STFD 54
-D: STFDU 55
-D: STFS 52
-D: STFSU 53
-D: STH 44
-D: STHU 45
-D: STW 36
-D: STWU 37
-
-! SD-form
-SD: ANDI 28
-SD: ANDIS 29
-SD: ORI 24
-SD: ORIS 25
-SD: XORI 26
-SD: XORIS 27
-
-! X-form
-X: AND 0 28 31
-X: AND. 1 28 31
-X: CMP 0 0 31
-X: CMPL 0 32 31
-X: EQV 0 284 31
-X: EQV. 1 284 31
-X: FCMPO 0 32 63
-X: FCMPU 0 0 63
-X: LBZUX 0 119 31
-X: LBZX 0 87 31
-X: LFDUX 0 631 31
-X: LFDX 0 599 31
-X: LFSUX 0 567 31
-X: LFSX 0 535 31
-X: LHAUX 0 375 31
-X: LHAX 0 343 31
-X: LHZUX 0 311 31
-X: LHZX 0 279 31
-X: LWZUX 0 55 31
-X: LWZX 0 23 31
-X: NAND 0 476 31
-X: NAND. 1 476 31
-X: NOR 0 124 31
-X: NOR. 1 124 31
-X: OR 0 444 31
-X: OR. 1 444 31
-X: ORC 0 412 31
-X: ORC. 1 412 31
-X: SLW 0 24 31
-X: SLW. 1 24 31
-X: SRAW 0 792 31
-X: SRAW. 1 792 31
-X: SRAWI 0 824 31
-X: SRW 0 536 31
-X: SRW. 1 536 31
-X: STBUX 0 247 31
-X: STBX 0 215 31
-X: STFDUX 0 759 31
-X: STFDX 0 727 31
-X: STFSUX 0 695 31
-X: STFSX 0 663 31
-X: STHUX 0 439 31
-X: STHX 0 407 31
-X: STWUX 0 183 31
-X: STWX 0 151 31
-X: XOR 0 316 31
-X: XOR. 1 316 31
-X1: EXTSB 0 954 31
-X1: EXTSB. 1 954 31
-: FRSP ( a s -- ) [ 0 ] 2dip 0 12 63 x-insn ;
-: FRSP. ( a s -- ) [ 0 ] 2dip 1 12 63 x-insn ;
-: FMR ( a s -- ) [ 0 ] 2dip 0 72 63 x-insn ;
-: FMR. ( a s -- ) [ 0 ] 2dip 1 72 63 x-insn ;
-: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
-: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
-
-! XO-form
-XO: ADD 0 0 266 31
-XO: ADD. 0 1 266 31
-XO: ADDC 0 0 10 31
-XO: ADDC. 0 1 10 31
-XO: ADDCO 1 0 10 31
-XO: ADDCO. 1 1 10 31
-XO: ADDE 0 0 138 31
-XO: ADDE. 0 1 138 31
-XO: ADDEO 1 0 138 31
-XO: ADDEO. 1 1 138 31
-XO: ADDO 1 0 266 31
-XO: ADDO. 1 1 266 31
-XO: DIVW 0 0 491 31
-XO: DIVW. 0 1 491 31
-XO: DIVWO 1 0 491 31
-XO: DIVWO. 1 1 491 31
-XO: DIVWU 0 0 459 31
-XO: DIVWU. 0 1 459 31
-XO: DIVWUO 1 0 459 31
-XO: DIVWUO. 1 1 459 31
-XO: MULHW 0 0 75 31
-XO: MULHW. 0 1 75 31
-XO: MULHWU 0 0 11 31
-XO: MULHWU. 0 1 11 31
-XO: MULLW 0 0 235 31
-XO: MULLW. 0 1 235 31
-XO: MULLWO 1 0 235 31
-XO: MULLWO. 1 1 235 31
-XO: SUBF 0 0 40 31
-XO: SUBF. 0 1 40 31
-XO: SUBFC 0 0 8 31
-XO: SUBFC. 0 1 8 31
-XO: SUBFCO 1 0 8 31
-XO: SUBFCO. 1 1 8 31
-XO: SUBFE 0 0 136 31
-XO: SUBFE. 0 1 136 31
-XO: SUBFEO 1 0 136 31
-XO: SUBFEO. 1 1 136 31
-XO: SUBFO 1 0 40 31
-XO: SUBFO. 1 1 40 31
-XO1: NEG 0 0 104 31
-XO1: NEG. 0 1 104 31
-XO1: NEGO 1 0 104 31
-XO1: NEGO. 1 1 104 31
-
-! A-form
-: RLWINM ( d a b c xo -- ) 0 21 a-insn ;
-: RLWINM. ( d a b c xo -- ) 1 21 a-insn ;
-: FADD ( d a b -- ) 0 21 0 63 a-insn ;
-: FADD. ( d a b -- ) 0 21 1 63 a-insn ;
-: FSUB ( d a b -- ) 0 20 0 63 a-insn ;
-: FSUB. ( d a b -- ) 0 20 1 63 a-insn ;
-: FMUL ( d a c -- ) 0 swap 25 0 63 a-insn ;
-: FMUL. ( d a c -- ) 0 swap 25 1 63 a-insn ;
-: FDIV ( d a b -- ) 0 18 0 63 a-insn ;
-: FDIV. ( d a b -- ) 0 18 1 63 a-insn ;
-: FSQRT ( d b -- ) 0 swap 0 22 0 63 a-insn ;
-: FSQRT. ( d b -- ) 0 swap 0 22 1 63 a-insn ;
-
-! Branches
-: B ( dest -- ) 0 0 (B) ;
-: BL ( dest -- ) 0 1 (B) ;
-BC: LT 12 0
-BC: GE 4 0
-BC: GT 12 1
-BC: LE 4 1
-BC: EQ 12 2
-BC: NE 4 2
-BC: O 12 3
-BC: NO 4 3
-B: CLR 0 8 0 0 19
-B: CLRL 0 8 0 1 19
-B: CCTR 0 264 0 0 19
-: BLR ( -- ) 20 BCLR ;
-: BLRL ( -- ) 20 BCLRL ;
-: BCTR ( -- ) 20 BCCTR ;
-
-! Special registers
-MFSPR: XER 1
-MFSPR: LR 8
-MFSPR: CTR 9
-MTSPR: XER 1
-MTSPR: LR 8
-MTSPR: CTR 9
-
-! Pseudo-instructions
-: LI ( value dst -- ) swap [ 0 ] dip ADDI ; inline
-: SUBI ( dst src1 src2 -- ) neg ADDI ; inline
-: LIS ( value dst -- ) swap [ 0 ] dip ADDIS ; inline
-: SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline
-: SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline
-: NOT ( dst src -- ) dup NOR ; inline
-: NOT. ( dst src -- ) dup NOR. ; inline
-: MR ( dst src -- ) dup OR ; inline
-: MR. ( dst src -- ) dup OR. ; inline
-: (SLWI) ( d a b -- d a b x y ) 0 31 pick - ; inline
-: SLWI ( d a b -- ) (SLWI) RLWINM ;
-: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
-: (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline
-: SRWI ( d a b -- ) (SRWI) RLWINM ;
-: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
-:: LOAD32 ( n r -- )
- n -16 shift HEX: ffff bitand r LIS
- r r n HEX: ffff bitand ORI ;
-: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
-: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
-
-! Altivec/VMX instructions
-VA: VMHADDSHS 32 4
-VA: VMHRADDSHS 33 4
-VA: VMLADDUHM 34 4
-VA: VMSUMUBM 36 4
-VA: VMSUMMBM 37 4
-VA: VMSUMUHM 38 4
-VA: VMSUMUHS 39 4
-VA: VMSUMSHM 40 4
-VA: VMSUMSHS 41 4
-VA: VSEL 42 4
-VA: VPERM 43 4
-VA: VSLDOI 44 4
-VA: VMADDFP 46 4
-VA: VNMSUBFP 47 4
-
-VX: VADDUBM 0 4
-VX: VADDUHM 64 4
-VX: VADDUWM 128 4
-VX: VADDCUW 384 4
-VX: VADDUBS 512 4
-VX: VADDUHS 576 4
-VX: VADDUWS 640 4
-VX: VADDSBS 768 4
-VX: VADDSHS 832 4
-VX: VADDSWS 896 4
-
-VX: VSUBUBM 1024 4
-VX: VSUBUHM 1088 4
-VX: VSUBUWM 1152 4
-VX: VSUBCUW 1408 4
-VX: VSUBUBS 1536 4
-VX: VSUBUHS 1600 4
-VX: VSUBUWS 1664 4
-VX: VSUBSBS 1792 4
-VX: VSUBSHS 1856 4
-VX: VSUBSWS 1920 4
-
-VX: VMAXUB 2 4
-VX: VMAXUH 66 4
-VX: VMAXUW 130 4
-VX: VMAXSB 258 4
-VX: VMAXSH 322 4
-VX: VMAXSW 386 4
-
-VX: VMINUB 514 4
-VX: VMINUH 578 4
-VX: VMINUW 642 4
-VX: VMINSB 770 4
-VX: VMINSH 834 4
-VX: VMINSW 898 4
-
-VX: VAVGUB 1026 4
-VX: VAVGUH 1090 4
-VX: VAVGUW 1154 4
-VX: VAVGSB 1282 4
-VX: VAVGSH 1346 4
-VX: VAVGSW 1410 4
-
-VX: VRLB 4 4
-VX: VRLH 68 4
-VX: VRLW 132 4
-VX: VSLB 260 4
-VX: VSLH 324 4
-VX: VSLW 388 4
-VX: VSL 452 4
-VX: VSRB 516 4
-VX: VSRH 580 4
-VX: VSRW 644 4
-VX: VSR 708 4
-VX: VSRAB 772 4
-VX: VSRAH 836 4
-VX: VSRAW 900 4
-
-VX: VAND 1028 4
-VX: VANDC 1092 4
-VX: VOR 1156 4
-VX: VNOR 1284 4
-VX: VXOR 1220 4
-
-VXD: MFVSCR 1540 4
-VXB: MTVSCR 1604 4
-
-VX: VMULOUB 8 4
-VX: VMULOUH 72 4
-VX: VMULOSB 264 4
-VX: VMULOSH 328 4
-VX: VMULEUB 520 4
-VX: VMULEUH 584 4
-VX: VMULESB 776 4
-VX: VMULESH 840 4
-VX: VSUM4UBS 1544 4
-VX: VSUM4SBS 1800 4
-VX: VSUM4SHS 1608 4
-VX: VSUM2SWS 1672 4
-VX: VSUMSWS 1928 4
-
-VX: VADDFP 10 4
-VX: VSUBFP 74 4
-
-VXDB: VREFP 266 4
-VXDB: VRSQRTEFP 330 4
-VXDB: VEXPTEFP 394 4
-VXDB: VLOGEFP 458 4
-VXDB: VRFIN 522 4
-VXDB: VRFIZ 586 4
-VXDB: VRFIP 650 4
-VXDB: VRFIM 714 4
-
-VX: VCFUX 778 4
-VX: VCFSX 842 4
-VX: VCTUXS 906 4
-VX: VCTSXS 970 4
-
-VX: VMAXFP 1034 4
-VX: VMINFP 1098 4
-
-VX: VMRGHB 12 4
-VX: VMRGHH 76 4
-VX: VMRGHW 140 4
-VX: VMRGLB 268 4
-VX: VMRGLH 332 4
-VX: VMRGLW 396 4
-
-VX: VSPLTB 524 4
-VX: VSPLTH 588 4
-VX: VSPLTW 652 4
-
-VXA: VSPLTISB 780 4
-VXA: VSPLTISH 844 4
-VXA: VSPLTISW 908 4
-
-VX: VSLO 1036 4
-VX: VSRO 1100 4
-
-VX: VPKUHUM 14 4
-VX: VPKUWUM 78 4
-VX: VPKUHUS 142 4
-VX: VPKUWUS 206 4
-VX: VPKSHUS 270 4
-VX: VPKSWUS 334 4
-VX: VPKSHSS 398 4
-VX: VPKSWSS 462 4
-VX: VPKPX 782 4
-
-VXDB: VUPKHSB 526 4
-VXDB: VUPKHSH 590 4
-VXDB: VUPKLSB 654 4
-VXDB: VUPKLSH 718 4
-VXDB: VUPKHPX 846 4
-VXDB: VUPKLPX 974 4
-
-: -T ( strm a b -- strm-t a b ) [ 16 bitor ] 2dip ;
-
-XD: DST 0 342 31
-: DSTT ( strm a b -- ) -T DST ;
-
-XD: DSTST 0 374 31
-: DSTSTT ( strm a b -- ) -T DSTST ;
-
-XD: (DSS) 0 822 31
-: DSS ( strm -- ) 0 0 (DSS) ;
-: DSSALL ( -- ) 16 0 0 (DSS) ;
-
-XD: LVEBX 0 7 31
-XD: LVEHX 0 39 31
-XD: LVEWX 0 71 31
-XD: LVSL 0 6 31
-XD: LVSR 0 38 31
-XD: LVX 0 103 31
-XD: LVXL 0 359 31
-
-XD: STVEBX 0 135 31
-XD: STVEHX 0 167 31
-XD: STVEWX 0 199 31
-XD: STVX 0 231 31
-XD: STVXL 0 487 31
-
-VXR: VCMPBFP 0 966 4
-VXR: VCMPEQFP 0 198 4
-VXR: VCMPEQUB 0 6 4
-VXR: VCMPEQUH 0 70 4
-VXR: VCMPEQUW 0 134 4
-VXR: VCMPGEFP 0 454 4
-VXR: VCMPGTFP 0 710 4
-VXR: VCMPGTSB 0 774 4
-VXR: VCMPGTSH 0 838 4
-VXR: VCMPGTSW 0 902 4
-VXR: VCMPGTUB 0 518 4
-VXR: VCMPGTUH 0 582 4
-VXR: VCMPGTUW 0 646 4
-
-VXR: VCMPBFP. 1 966 4
-VXR: VCMPEQFP. 1 198 4
-VXR: VCMPEQUB. 1 6 4
-VXR: VCMPEQUH. 1 70 4
-VXR: VCMPEQUW. 1 134 4
-VXR: VCMPGEFP. 1 454 4
-VXR: VCMPGTFP. 1 710 4
-VXR: VCMPGTSB. 1 774 4
-VXR: VCMPGTSH. 1 838 4
-VXR: VCMPGTSW. 1 902 4
-VXR: VCMPGTUB. 1 518 4
-VXR: VCMPGTUH. 1 582 4
-VXR: VCMPGTUW. 1 646 4
-
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make sequences words math
-math.bitwise io.binary parser lexer fry ;
-IN: cpu.ppc.assembler.backend
-
-: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
-
-: a-insn ( d a b c xo rc opcode -- )
- [ { 0 1 6 11 16 21 } bitfield ] dip insn ;
-
-: b-insn ( bo bi bd aa lk opcode -- )
- [ { 0 1 2 16 21 } bitfield ] dip insn ;
-
-: s>u16 ( s -- u ) HEX: ffff bitand ;
-
-: d-insn ( d a simm opcode -- )
- [ s>u16 { 0 16 21 } bitfield ] dip insn ;
-
-: define-d-insn ( word opcode -- )
- [ d-insn ] curry (( d a simm -- )) define-declared ;
-
-SYNTAX: D: CREATE scan-word define-d-insn ;
-
-: sd-insn ( d a simm opcode -- )
- [ s>u16 { 0 21 16 } bitfield ] dip insn ;
-
-: define-sd-insn ( word opcode -- )
- [ sd-insn ] curry (( d a simm -- )) define-declared ;
-
-SYNTAX: SD: CREATE scan-word define-sd-insn ;
-
-: i-insn ( li aa lk opcode -- )
- [ { 0 1 0 } bitfield ] dip insn ;
-
-: x-insn ( a s b rc xo opcode -- )
- [ { 1 0 11 21 16 } bitfield ] dip insn ;
-
-: xd-insn ( d a b rc xo opcode -- )
- [ { 1 0 11 16 21 } bitfield ] dip insn ;
-
-: (X) ( -- word quot )
- CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
-
-: (XD) ( -- word quot )
- CREATE scan-word scan-word scan-word [ xd-insn ] 3curry ;
-
-SYNTAX: X: (X) (( a s b -- )) define-declared ;
-SYNTAX: XD: (XD) (( d a b -- )) define-declared ;
-
-: (1) ( quot -- quot' ) [ 0 ] prepose ;
-
-SYNTAX: X1: (X) (1) (( a s -- )) define-declared ;
-
-: xfx-insn ( d spr xo opcode -- )
- [ { 1 11 21 } bitfield ] dip insn ;
-
-: CREATE-MF ( -- word ) scan "MF" prepend create-in ;
-
-SYNTAX: MFSPR:
- CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
- (( d -- )) define-declared ;
-
-: CREATE-MT ( -- word ) scan "MT" prepend create-in ;
-
-SYNTAX: MTSPR:
- CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
- (( d -- )) define-declared ;
-
-: xo-insn ( d a b oe rc xo opcode -- )
- [ { 1 0 10 11 16 21 } bitfield ] dip insn ;
-
-: (XO) ( -- word quot )
- CREATE scan-word scan-word scan-word scan-word
- [ xo-insn ] 2curry 2curry ;
-
-SYNTAX: XO: (XO) (( d a b -- )) define-declared ;
-
-SYNTAX: XO1: (XO) (1) (( d a -- )) define-declared ;
-
-GENERIC# (B) 2 ( dest aa lk -- )
-M: integer (B) 18 i-insn ;
-
-GENERIC: BC ( a b c -- )
-M: integer BC 0 0 16 b-insn ;
-
-: CREATE-B ( -- word ) scan "B" prepend create-in ;
-
-SYNTAX: BC:
- CREATE-B scan-word scan-word
- '[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
-
-SYNTAX: B:
- CREATE-B scan-word scan-word scan-word scan-word scan-word
- '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
-
-: va-insn ( d a b c xo opcode -- )
- [ { 0 6 11 16 21 } bitfield ] dip insn ;
-
-: (VA) ( -- word quot )
- CREATE scan-word scan-word [ va-insn ] 2curry ;
-
-SYNTAX: VA: (VA) (( d a b c -- )) define-declared ;
-
-: vx-insn ( d a b xo opcode -- )
- [ { 0 11 16 21 } bitfield ] dip insn ;
-
-: (VX) ( -- word quot )
- CREATE scan-word scan-word [ vx-insn ] 2curry ;
-: (VXD) ( -- word quot )
- CREATE scan-word scan-word '[ 0 0 _ _ vx-insn ] ;
-: (VXA) ( -- word quot )
- CREATE scan-word scan-word '[ [ 0 ] dip 0 _ _ vx-insn ] ;
-: (VXB) ( -- word quot )
- CREATE scan-word scan-word '[ [ 0 0 ] dip _ _ vx-insn ] ;
-: (VXDB) ( -- word quot )
- CREATE scan-word scan-word '[ [ 0 ] dip _ _ vx-insn ] ;
-
-SYNTAX: VX: (VX) (( d a b -- )) define-declared ;
-SYNTAX: VXD: (VXD) (( d -- )) define-declared ;
-SYNTAX: VXA: (VXA) (( a -- )) define-declared ;
-SYNTAX: VXB: (VXB) (( b -- )) define-declared ;
-SYNTAX: VXDB: (VXDB) (( d b -- )) define-declared ;
-
-: vxr-insn ( d a b rc xo opcode -- )
- [ { 0 10 11 16 21 } bitfield ] dip insn ;
-
-: (VXR) ( -- word quot )
- CREATE scan-word scan-word scan-word [ vxr-insn ] 3curry ;
-
-SYNTAX: VXR: (VXR) (( d a b -- )) define-declared ;
-
+++ /dev/null
-PowerPC assembler
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: bootstrap.image.private kernel kernel.private namespaces\r
-system cpu.ppc.assembler compiler.units compiler.constants math\r
-math.private math.ranges layouts words vocabs slots.private\r
-locals locals.backend generic.single.private fry sequences\r
-threads.private strings.private ;\r
-FROM: cpu.ppc.assembler => B ;\r
-IN: bootstrap.ppc\r
-\r
-4 \ cell set\r
-big-endian on\r
-\r
-CONSTANT: ds-reg 13\r
-CONSTANT: rs-reg 14\r
-CONSTANT: vm-reg 15\r
-CONSTANT: ctx-reg 16\r
-CONSTANT: nv-reg 17\r
-\r
-: jit-call ( string -- )\r
- 0 2 LOAD32 rc-absolute-ppc-2/2 jit-dlsym\r
- 2 MTLR\r
- BLRL ;\r
-\r
-: jit-call-quot ( -- )\r
- 4 3 quot-entry-point-offset LWZ\r
- 4 MTLR\r
- BLRL ;\r
-\r
-: jit-jump-quot ( -- )\r
- 4 3 quot-entry-point-offset LWZ\r
- 4 MTCTR\r
- BCTR ;\r
-\r
-: factor-area-size ( -- n ) 16 ;\r
-\r
-: stack-frame ( -- n )\r
- reserved-size\r
- factor-area-size +\r
- 16 align ;\r
-\r
-: next-save ( -- n ) stack-frame 4 - ;\r
-: xt-save ( -- n ) stack-frame 8 - ;\r
-\r
-: param-size ( -- n ) 32 ;\r
-\r
-: save-at ( m -- n ) reserved-size + param-size + ;\r
-\r
-: save-int ( register offset -- ) [ 1 ] dip save-at STW ;\r
-: restore-int ( register offset -- ) [ 1 ] dip save-at LWZ ;\r
-\r
-: save-fp ( register offset -- ) [ 1 ] dip save-at STFD ;\r
-: restore-fp ( register offset -- ) [ 1 ] dip save-at LFD ;\r
-\r
-: save-vec ( register offset -- ) save-at 2 LI 2 1 STVXL ;\r
-: restore-vec ( register offset -- ) save-at 2 LI 2 1 LVXL ;\r
-\r
-: nv-int-regs ( -- seq ) 13 31 [a,b] ;\r
-: nv-fp-regs ( -- seq ) 14 31 [a,b] ;\r
-: nv-vec-regs ( -- seq ) 20 31 [a,b] ;\r
-\r
-: saved-int-regs-size ( -- n ) 96 ;\r
-: saved-fp-regs-size ( -- n ) 144 ;\r
-: saved-vec-regs-size ( -- n ) 208 ;\r
-\r
-: callback-frame-size ( -- n )\r
- reserved-size\r
- param-size +\r
- saved-int-regs-size +\r
- saved-fp-regs-size +\r
- saved-vec-regs-size +\r
- 4 +\r
- 16 align ;\r
-\r
-: old-context-save-offset ( -- n )\r
- 432 save-at ;\r
-\r
-[\r
- ! Save old stack pointer\r
- 11 1 MR\r
-\r
- ! Create stack frame\r
- 0 MFLR\r
- 1 1 callback-frame-size SUBI\r
- 0 1 callback-frame-size lr-save + STW\r
-\r
- ! Save all non-volatile registers\r
- nv-int-regs [ 4 * save-int ] each-index\r
- nv-fp-regs [ 8 * 80 + save-fp ] each-index\r
- nv-vec-regs [ 16 * 224 + save-vec ] each-index\r
-\r
- ! Stick old stack pointer in a non-volatile register so that\r
- ! callbacks can access their arguments\r
- nv-reg 11 MR\r
-\r
- ! Load VM into vm-reg\r
- 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
-\r
- ! Save old context\r
- 2 vm-reg vm-context-offset LWZ\r
- 2 1 old-context-save-offset STW\r
-\r
- ! Switch over to the spare context\r
- 2 vm-reg vm-spare-context-offset LWZ\r
- 2 vm-reg vm-context-offset STW\r
-\r
- ! Save C callstack pointer\r
- 1 2 context-callstack-save-offset STW\r
-\r
- ! Load Factor callstack pointer\r
- 1 2 context-callstack-bottom-offset LWZ\r
-\r
- ! Call into Factor code\r
- 0 2 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel\r
- 2 MTLR\r
- BLRL\r
-\r
- ! Load VM again, pointlessly\r
- 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
-\r
- ! Load C callstack pointer\r
- 2 vm-reg vm-context-offset LWZ\r
- 1 2 context-callstack-save-offset LWZ\r
-\r
- ! Load old context\r
- 2 1 old-context-save-offset LWZ\r
- 2 vm-reg vm-context-offset STW\r
-\r
- ! Restore non-volatile registers\r
- nv-vec-regs [ 16 * 224 + restore-vec ] each-index\r
- nv-fp-regs [ 8 * 80 + restore-fp ] each-index\r
- nv-int-regs [ 4 * restore-int ] each-index\r
-\r
- ! Tear down stack frame and return\r
- 0 1 callback-frame-size lr-save + LWZ\r
- 1 1 callback-frame-size ADDI\r
- 0 MTLR\r
- BLR\r
-] callback-stub jit-define\r
-\r
-: jit-conditional* ( test-quot false-quot -- )\r
- [ '[ 4 /i 1 + @ ] ] dip jit-conditional ; inline\r
-\r
-: jit-load-context ( -- )\r
- ctx-reg vm-reg vm-context-offset LWZ ;\r
-\r
-: jit-save-context ( -- )\r
- jit-load-context\r
- 1 ctx-reg context-callstack-top-offset STW\r
- ds-reg ctx-reg context-datastack-offset STW\r
- rs-reg ctx-reg context-retainstack-offset STW ;\r
-\r
-: jit-restore-context ( -- )\r
- ds-reg ctx-reg context-datastack-offset LWZ\r
- rs-reg ctx-reg context-retainstack-offset LWZ ;\r
-\r
-[\r
- 0 12 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- 11 12 profile-count-offset LWZ\r
- 11 11 1 tag-fixnum ADDI\r
- 11 12 profile-count-offset STW\r
- 11 12 word-code-offset LWZ\r
- 11 11 compiled-header-size ADDI\r
- 11 MTCTR\r
- BCTR\r
-] jit-profiling jit-define\r
-\r
-[\r
- 0 2 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
- 0 MFLR\r
- 1 1 stack-frame SUBI\r
- 2 1 xt-save STW\r
- stack-frame 2 LI\r
- 2 1 next-save STW\r
- 0 1 lr-save stack-frame + STW\r
-] jit-prolog jit-define\r
-\r
-[\r
- 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- 3 ds-reg 4 STWU\r
-] jit-push jit-define\r
-\r
-[\r
- jit-save-context\r
- 3 vm-reg MR\r
- 0 4 LOAD32 rc-absolute-ppc-2/2 rt-dlsym jit-rel\r
- 4 MTLR\r
- BLRL\r
- jit-restore-context\r
-] jit-primitive jit-define\r
-\r
-[ 0 BL rc-relative-ppc-3 rt-entry-point-pic jit-rel ] jit-word-call jit-define\r
-\r
-[\r
- 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel\r
- 0 B rc-relative-ppc-3 rt-entry-point-pic-tail jit-rel\r
-] jit-word-jump jit-define\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 0 3 \ f type-number CMPI\r
- [ BEQ ] [ 0 B rc-relative-ppc-3 rt-entry-point jit-rel ] jit-conditional*\r
- 0 B rc-relative-ppc-3 rt-entry-point jit-rel\r
-] jit-if jit-define\r
-\r
-: jit->r ( -- )\r
- 4 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 4 rs-reg 4 STWU ;\r
-\r
-: jit-2>r ( -- )\r
- 4 ds-reg 0 LWZ\r
- 5 ds-reg -4 LWZ\r
- ds-reg dup 8 SUBI\r
- rs-reg dup 8 ADDI\r
- 4 rs-reg 0 STW\r
- 5 rs-reg -4 STW ;\r
-\r
-: jit-3>r ( -- )\r
- 4 ds-reg 0 LWZ\r
- 5 ds-reg -4 LWZ\r
- 6 ds-reg -8 LWZ\r
- ds-reg dup 12 SUBI\r
- rs-reg dup 12 ADDI\r
- 4 rs-reg 0 STW\r
- 5 rs-reg -4 STW\r
- 6 rs-reg -8 STW ;\r
-\r
-: jit-r> ( -- )\r
- 4 rs-reg 0 LWZ\r
- rs-reg dup 4 SUBI\r
- 4 ds-reg 4 STWU ;\r
-\r
-: jit-2r> ( -- )\r
- 4 rs-reg 0 LWZ\r
- 5 rs-reg -4 LWZ\r
- rs-reg dup 8 SUBI\r
- ds-reg dup 8 ADDI\r
- 4 ds-reg 0 STW\r
- 5 ds-reg -4 STW ;\r
-\r
-: jit-3r> ( -- )\r
- 4 rs-reg 0 LWZ\r
- 5 rs-reg -4 LWZ\r
- 6 rs-reg -8 LWZ\r
- rs-reg dup 12 SUBI\r
- ds-reg dup 12 ADDI\r
- 4 ds-reg 0 STW\r
- 5 ds-reg -4 STW\r
- 6 ds-reg -8 STW ;\r
-\r
-[\r
- jit->r\r
- 0 BL rc-relative-ppc-3 rt-entry-point jit-rel\r
- jit-r>\r
-] jit-dip jit-define\r
-\r
-[\r
- jit-2>r\r
- 0 BL rc-relative-ppc-3 rt-entry-point jit-rel\r
- jit-2r>\r
-] jit-2dip jit-define\r
-\r
-[\r
- jit-3>r\r
- 0 BL rc-relative-ppc-3 rt-entry-point jit-rel\r
- jit-3r>\r
-] jit-3dip jit-define\r
-\r
-[\r
- 0 1 lr-save stack-frame + LWZ\r
- 1 1 stack-frame ADDI\r
- 0 MTLR\r
-] jit-epilog jit-define\r
-\r
-[ BLR ] jit-return jit-define\r
-\r
-! ! ! Polymorphic inline caches\r
-\r
-! Don't touch r6 here; it's used to pass the tail call site\r
-! address for tail PICs\r
-\r
-! Load a value from a stack position\r
-[\r
- 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel\r
-] pic-load jit-define\r
-\r
-[ 4 4 tag-mask get ANDI ] pic-tag jit-define\r
-\r
-[\r
- 3 4 MR\r
- 4 4 tag-mask get ANDI\r
- 0 4 tuple type-number CMPI\r
- [ BNE ]\r
- [ 4 3 tuple-class-offset LWZ ]\r
- jit-conditional*\r
-] pic-tuple jit-define\r
-\r
-[\r
- 0 4 0 CMPI rc-absolute-ppc-2 rt-untagged jit-rel\r
-] pic-check-tag jit-define\r
-\r
-[\r
- 0 5 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- 4 0 5 CMP\r
-] pic-check-tuple jit-define\r
-\r
-[\r
- [ BNE ] [ 0 B rc-relative-ppc-3 rt-entry-point jit-rel ] jit-conditional*\r
-] pic-hit jit-define\r
-\r
-! Inline cache miss entry points\r
-: jit-load-return-address ( -- ) 6 MFLR ;\r
-\r
-! These are always in tail position with an existing stack\r
-! frame, and the stack. The frame setup takes this into account.\r
-: jit-inline-cache-miss ( -- )\r
- jit-save-context\r
- 3 6 MR\r
- 4 vm-reg MR\r
- "inline_cache_miss" jit-call\r
- jit-load-context\r
- jit-restore-context ;\r
-\r
-[ jit-load-return-address jit-inline-cache-miss ]\r
-[ 3 MTLR BLRL ]\r
-[ 3 MTCTR BCTR ]\r
-\ inline-cache-miss define-combinator-primitive\r
-\r
-[ jit-inline-cache-miss ]\r
-[ 3 MTLR BLRL ]\r
-[ 3 MTCTR BCTR ]\r
-\ inline-cache-miss-tail define-combinator-primitive\r
-\r
-! ! ! Megamorphic caches\r
-\r
-[\r
- ! class = ...\r
- 3 4 MR\r
- 4 4 tag-mask get ANDI\r
- 4 4 tag-bits get SLWI\r
- 0 4 tuple type-number tag-fixnum CMPI\r
- [ BNE ]\r
- [ 4 3 tuple-class-offset LWZ ]\r
- jit-conditional*\r
- ! cache = ...\r
- 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- ! key = hashcode(class)\r
- 5 4 1 SRAWI\r
- ! key &= cache.length - 1\r
- 5 5 mega-cache-size get 1 - 4 * ANDI\r
- ! cache += array-start-offset\r
- 3 3 array-start-offset ADDI\r
- ! cache += key\r
- 3 3 5 ADD\r
- ! if(get(cache) == class)\r
- 6 3 0 LWZ\r
- 6 0 4 CMP\r
- [ BNE ]\r
- [\r
- ! megamorphic_cache_hits++\r
- 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel\r
- 5 4 0 LWZ\r
- 5 5 1 ADDI\r
- 5 4 0 STW\r
- ! ... goto get(cache + 4)\r
- 3 3 4 LWZ\r
- 3 3 word-entry-point-offset LWZ\r
- 3 MTCTR\r
- BCTR\r
- ]\r
- jit-conditional*\r
- ! fall-through on miss\r
-] mega-lookup jit-define\r
-\r
-! ! ! Sub-primitives\r
-\r
-! Quotations and words\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
-]\r
-[ jit-call-quot ]\r
-[ jit-jump-quot ] \ (call) define-combinator-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 4 3 word-entry-point-offset LWZ\r
-]\r
-[ 4 MTLR BLRL ]\r
-[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 4 3 word-entry-point-offset LWZ\r
- 4 MTCTR BCTR\r
-] jit-execute jit-define\r
-\r
-! Special primitives\r
-[\r
- nv-reg 3 MR\r
-\r
- 3 vm-reg MR\r
- "begin_callback" jit-call\r
-\r
- jit-load-context\r
- jit-restore-context\r
-\r
- ! Call quotation\r
- 3 nv-reg MR\r
- jit-call-quot\r
-\r
- jit-save-context\r
-\r
- 3 vm-reg MR\r
- "end_callback" jit-call\r
-] \ c-to-factor define-sub-primitive\r
-\r
-[\r
- ! Unwind stack frames\r
- 1 4 MR\r
-\r
- ! Load VM pointer into vm-reg, since we're entering from\r
- ! C code\r
- 0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm\r
-\r
- ! Load ds and rs registers\r
- jit-load-context\r
- jit-restore-context\r
-\r
- ! We have changed the stack; load return address again\r
- 0 1 lr-save LWZ\r
- 0 MTLR\r
-\r
- ! Call quotation\r
- jit-call-quot\r
-] \ unwind-native-frames define-sub-primitive\r
-\r
-[\r
- ! Load callstack object\r
- 6 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- ! Get ctx->callstack_bottom\r
- jit-load-context\r
- 3 ctx-reg context-callstack-bottom-offset LWZ\r
- ! Get top of callstack object -- 'src' for memcpy\r
- 4 6 callstack-top-offset ADDI\r
- ! Get callstack length, in bytes --- 'len' for memcpy\r
- 5 6 callstack-length-offset LWZ\r
- 5 5 tag-bits get SRAWI\r
- ! Compute new stack pointer -- 'dst' for memcpy\r
- 3 5 3 SUBF\r
- ! Install new stack pointer\r
- 1 3 MR\r
- ! Call memcpy; arguments are now in the correct registers\r
- 1 1 -64 STWU\r
- "factor_memcpy" jit-call\r
- 1 1 0 LWZ\r
- ! Return with new callstack\r
- 0 1 lr-save LWZ\r
- 0 MTLR\r
- BLR\r
-] \ set-callstack define-sub-primitive\r
-\r
-[\r
- jit-save-context\r
- 4 vm-reg MR\r
- "lazy_jit_compile" jit-call\r
-]\r
-[ jit-call-quot ]\r
-[ jit-jump-quot ]\r
-\ lazy-jit-compile define-combinator-primitive\r
-\r
-! Objects\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 3 tag-mask get ANDI\r
- 3 3 tag-bits get SLWI\r
- 3 ds-reg 0 STW\r
-] \ tag define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZU\r
- 3 3 2 SRAWI\r
- 4 4 0 0 31 tag-bits get - RLWINM\r
- 4 3 3 LWZX\r
- 3 ds-reg 0 STW\r
-] \ slot define-sub-primitive\r
-\r
-[\r
- ! load string index from stack\r
- 3 ds-reg -4 LWZ\r
- 3 3 tag-bits get SRAWI\r
- ! load string from stack\r
- 4 ds-reg 0 LWZ\r
- ! load character\r
- 4 4 string-offset ADDI\r
- 3 3 4 LBZX\r
- 3 3 tag-bits get SLWI\r
- ! store character to stack\r
- ds-reg ds-reg 4 SUBI\r
- 3 ds-reg 0 STW\r
-] \ string-nth-fast define-sub-primitive\r
-\r
-! Shufflers\r
-[\r
- ds-reg dup 4 SUBI\r
-] \ drop define-sub-primitive\r
-\r
-[\r
- ds-reg dup 8 SUBI\r
-] \ 2drop define-sub-primitive\r
-\r
-[\r
- ds-reg dup 12 SUBI\r
-] \ 3drop define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 ds-reg 4 STWU\r
-] \ dup define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- ds-reg dup 8 ADDI\r
- 3 ds-reg 0 STW\r
- 4 ds-reg -4 STW\r
-] \ 2dup define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 5 ds-reg -8 LWZ\r
- ds-reg dup 12 ADDI\r
- 3 ds-reg 0 STW\r
- 4 ds-reg -4 STW\r
- 5 ds-reg -8 STW\r
-] \ 3dup define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 4 SUBI\r
- 3 ds-reg 0 STW\r
-] \ nip define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg dup 8 SUBI\r
- 3 ds-reg 0 STW\r
-] \ 2nip define-sub-primitive\r
-\r
-[\r
- 3 ds-reg -4 LWZ\r
- 3 ds-reg 4 STWU\r
-] \ over define-sub-primitive\r
-\r
-[\r
- 3 ds-reg -8 LWZ\r
- 3 ds-reg 4 STWU\r
-] \ pick define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 4 ds-reg 0 STW\r
- 3 ds-reg 4 STWU\r
-] \ dupd define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 3 ds-reg -4 STW\r
- 4 ds-reg 0 STW\r
-] \ swap define-sub-primitive\r
-\r
-[\r
- 3 ds-reg -4 LWZ\r
- 4 ds-reg -8 LWZ\r
- 3 ds-reg -8 STW\r
- 4 ds-reg -4 STW\r
-] \ swapd define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 5 ds-reg -8 LWZ\r
- 4 ds-reg -8 STW\r
- 3 ds-reg -4 STW\r
- 5 ds-reg 0 STW\r
-] \ rot define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 5 ds-reg -8 LWZ\r
- 3 ds-reg -8 STW\r
- 5 ds-reg -4 STW\r
- 4 ds-reg 0 STW\r
-] \ -rot define-sub-primitive\r
-\r
-[ jit->r ] \ load-local define-sub-primitive\r
-\r
-! Comparisons\r
-: jit-compare ( insn -- )\r
- t jit-literal\r
- 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- 4 ds-reg 0 LWZ\r
- 5 ds-reg -4 LWZU\r
- 5 0 4 CMP\r
- 2 swap execute( offset -- ) ! magic number\r
- \ f type-number 3 LI\r
- 3 ds-reg 0 STW ;\r
-\r
-: define-jit-compare ( insn word -- )\r
- [ [ jit-compare ] curry ] dip define-sub-primitive ;\r
-\r
-\ BEQ \ eq? define-jit-compare\r
-\ BGE \ fixnum>= define-jit-compare\r
-\ BLE \ fixnum<= define-jit-compare\r
-\ BGT \ fixnum> define-jit-compare\r
-\ BLT \ fixnum< define-jit-compare\r
-\r
-! Math\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- 4 ds-reg 0 LWZ\r
- 3 3 4 OR\r
- 3 3 tag-mask get ANDI\r
- \ f type-number 4 LI\r
- 0 3 0 CMPI\r
- [ BNE ] [ 1 tag-fixnum 4 LI ] jit-conditional*\r
- 4 ds-reg 0 STW\r
-] \ both-fixnums? define-sub-primitive\r
-\r
-: jit-math ( insn -- )\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZU\r
- [ 5 3 4 ] dip execute( dst src1 src2 -- )\r
- 5 ds-reg 0 STW ;\r
-\r
-[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive\r
-\r
-[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZU\r
- 4 4 tag-bits get SRAWI\r
- 5 3 4 MULLW\r
- 5 ds-reg 0 STW\r
-] \ fixnum*fast define-sub-primitive\r
-\r
-[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive\r
-\r
-[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive\r
-\r
-[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 3 NOT\r
- 3 3 tag-mask get XORI\r
- 3 ds-reg 0 STW\r
-] \ fixnum-bitnot define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 3 tag-bits get SRAWI\r
- ds-reg ds-reg 4 SUBI\r
- 4 ds-reg 0 LWZ\r
- 5 4 3 SLW\r
- 6 3 NEG\r
- 7 4 6 SRAW\r
- 7 7 0 0 31 tag-bits get - RLWINM\r
- 0 3 0 CMPI\r
- [ BGT ] [ 5 7 MR ] jit-conditional*\r
- 5 ds-reg 0 STW\r
-] \ fixnum-shift-fast define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- 4 ds-reg 0 LWZ\r
- 5 4 3 DIVW\r
- 6 5 3 MULLW\r
- 7 6 4 SUBF\r
- 7 ds-reg 0 STW\r
-] \ fixnum-mod define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- 4 ds-reg 0 LWZ\r
- 5 4 3 DIVW\r
- 5 5 tag-bits get SLWI\r
- 5 ds-reg 0 STW\r
-] \ fixnum/i-fast define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- 5 4 3 DIVW\r
- 6 5 3 MULLW\r
- 7 6 4 SUBF\r
- 5 5 tag-bits get SLWI\r
- 5 ds-reg -4 STW\r
- 7 ds-reg 0 STW\r
-] \ fixnum/mod-fast define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- 3 3 2 SRAWI\r
- rs-reg 3 3 LWZX\r
- 3 ds-reg 0 STW\r
-] \ get-local define-sub-primitive\r
-\r
-[\r
- 3 ds-reg 0 LWZ\r
- ds-reg ds-reg 4 SUBI\r
- 3 3 2 SRAWI\r
- rs-reg 3 rs-reg SUBF\r
-] \ drop-locals define-sub-primitive\r
-\r
-! Overflowing fixnum arithmetic\r
-:: jit-overflow ( insn func -- )\r
- ds-reg ds-reg 4 SUBI\r
- jit-save-context\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg 4 LWZ\r
- 0 0 LI\r
- 0 MTXER\r
- 6 4 3 insn call( d a s -- )\r
- 6 ds-reg 0 STW\r
- [ BNO ]\r
- [\r
- 5 vm-reg MR\r
- func jit-call\r
- ]\r
- jit-conditional* ;\r
-\r
-[ [ ADDO. ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive\r
-\r
-[ [ SUBFO. ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive\r
-\r
-[\r
- ds-reg ds-reg 4 SUBI\r
- jit-save-context\r
- 3 ds-reg 0 LWZ\r
- 3 3 tag-bits get SRAWI\r
- 4 ds-reg 4 LWZ\r
- 0 0 LI\r
- 0 MTXER\r
- 6 3 4 MULLWO.\r
- 6 ds-reg 0 STW\r
- [ BNO ]\r
- [\r
- 4 4 tag-bits get SRAWI\r
- 5 vm-reg MR\r
- "overflow_fixnum_multiply" jit-call\r
- ]\r
- jit-conditional*\r
-] \ fixnum* define-sub-primitive\r
-\r
-! Contexts\r
-: jit-switch-context ( reg -- )\r
- ! Save ds, rs registers\r
- jit-save-context\r
-\r
- ! Make the new context the current one\r
- ctx-reg swap MR\r
- ctx-reg vm-reg vm-context-offset STW\r
-\r
- ! Load new stack pointer\r
- 1 ctx-reg context-callstack-top-offset LWZ\r
-\r
- ! Load new ds, rs registers\r
- jit-restore-context ;\r
-\r
-: jit-pop-context-and-param ( -- )\r
- 3 ds-reg 0 LWZ\r
- 3 3 alien-offset LWZ\r
- 4 ds-reg -4 LWZ\r
- ds-reg ds-reg 8 SUBI ;\r
-\r
-: jit-push-param ( -- )\r
- ds-reg ds-reg 4 ADDI\r
- 4 ds-reg 0 STW ;\r
-\r
-: jit-set-context ( -- )\r
- jit-pop-context-and-param\r
- 3 jit-switch-context\r
- jit-push-param ;\r
-\r
-[ jit-set-context ] \ (set-context) define-sub-primitive\r
-\r
-: jit-pop-quot-and-param ( -- )\r
- 3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
- ds-reg ds-reg 8 SUBI ;\r
-\r
-: jit-start-context ( -- )\r
- ! Create the new context in return-reg\r
- 3 vm-reg MR\r
- "new_context" jit-call\r
- 6 3 MR\r
-\r
- jit-pop-quot-and-param\r
-\r
- 6 jit-switch-context\r
-\r
- jit-push-param\r
-\r
- jit-jump-quot ;\r
-\r
-[ jit-start-context ] \ (start-context) define-sub-primitive\r
-\r
-: jit-delete-current-context ( -- )\r
- jit-load-context\r
- 3 vm-reg MR\r
- 4 ctx-reg MR\r
- "delete_context" jit-call ;\r
-\r
-[\r
- jit-delete-current-context\r
- jit-set-context\r
-] \ (set-context-and-delete) define-sub-primitive\r
-\r
-[\r
- jit-delete-current-context\r
- jit-start-context\r
-] \ (start-context-and-delete) define-sub-primitive\r
-\r
-[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
+++ /dev/null
-! Copyright (C) 2007, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser system kernel sequences ;
-IN: bootstrap.ppc
-
-: reserved-size ( -- n ) 24 ;
-: lr-save ( -- n ) 4 ;
-
-<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
-call
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors system kernel layouts
-alien.c-types cpu.architecture cpu.ppc ;
-IN: cpu.ppc.linux
-
-<<
-t "longlong" c-type stack-align?<<
-t "ulonglong" c-type stack-align?<<
->>
-
-M: linux reserved-area-size 2 cells ;
-
-M: linux lr-save 1 cells ;
-
-M: ppc param-regs
- drop {
- { int-regs { 3 4 5 6 7 8 9 10 } }
- { float-regs { 1 2 3 4 5 6 7 8 } }
- } ;
-
-M: ppc value-struct? drop f ;
-
-M: ppc dummy-stack-params? f ;
-
-M: ppc dummy-int-params? f ;
-
-M: ppc dummy-fp-params? f ;
+++ /dev/null
-Linux/PPC ABI support
+++ /dev/null
-not loaded
+++ /dev/null
-! Copyright (C) 2007, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser system kernel sequences ;
-IN: bootstrap.ppc
-
-: reserved-size ( -- n ) 24 ;
-: lr-save ( -- n ) 8 ;
-
-<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
-call
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors system kernel layouts
-alien.c-types cpu.architecture cpu.ppc ;
-IN: cpu.ppc.macosx
-
-M: macosx reserved-area-size 6 cells ;
-
-M: macosx lr-save 2 cells ;
-
-M: ppc param-regs
- drop {
- { int-regs { 3 4 5 6 7 8 9 10 } }
- { float-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
- } ;
-
-M: ppc value-struct? drop t ;
-
-M: ppc dummy-stack-params? t ;
-
-M: ppc dummy-int-params? t ;
-
-M: ppc dummy-fp-params? f ;
+++ /dev/null
-Mac OS X/PPC ABI support
+++ /dev/null
-not loaded
+++ /dev/null
-! Copyright (C) 2005, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sequences kernel combinators
-classes.algebra byte-arrays make math math.order math.ranges
-system namespaces locals layouts words alien alien.accessors
-alien.c-types alien.complex alien.data alien.libraries
-literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.comparisons compiler.codegen.fixup
-compiler.cfg.intrinsics compiler.cfg.stack-frame
-compiler.cfg.build-stack-frame compiler.units compiler.constants
-compiler.codegen vm ;
-QUALIFIED-WITH: alien.c-types c
-FROM: cpu.ppc.assembler => B ;
-FROM: layouts => cell ;
-FROM: math => float ;
-IN: cpu.ppc
-
-! PowerPC register assignments:
-! r2-r12: integer vregs
-! r13: data stack
-! r14: retain stack
-! r15: VM pointer
-! r16-r29: integer vregs
-! r30: integer scratch
-! f0-f29: float vregs
-! f30: float scratch
-
-! Add some methods to the assembler that are useful to us
-M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
-M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
-
-enable-float-intrinsics
-
-M: ppc machine-registers
- {
- { int-regs $[ 2 12 [a,b] 16 29 [a,b] append ] }
- { float-regs $[ 0 29 [a,b] ] }
- } ;
-
-CONSTANT: scratch-reg 30
-CONSTANT: fp-scratch-reg 30
-
-M: ppc complex-addressing? f ;
-
-M: ppc fused-unboxing? f ;
-
-M: ppc %load-immediate ( reg n -- ) swap LOAD ;
-
-M: ppc %load-reference ( reg obj -- )
- [ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ]
- [ \ f type-number swap LI ]
- if* ;
-
-M: ppc %alien-global ( register symbol dll -- )
- [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
-
-CONSTANT: ds-reg 13
-CONSTANT: rs-reg 14
-CONSTANT: vm-reg 15
-
-: %load-vm-addr ( reg -- ) vm-reg MR ;
-
-M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
-
-M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
-
-GENERIC: loc-reg ( loc -- reg )
-
-M: ds-loc loc-reg drop ds-reg ;
-M: rs-loc loc-reg drop rs-reg ;
-
-: loc>operand ( loc -- reg n )
- [ loc-reg ] [ n>> cells neg ] bi ; inline
-
-M: ppc %peek loc>operand LWZ ;
-M: ppc %replace loc>operand STW ;
-
-:: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline
-
-M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
-M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
-
-HOOK: reserved-area-size os ( -- n )
-
-! The start of the stack frame contains the size of this frame
-! as well as the currently executing code block
-: factor-area-size ( -- n ) 2 cells ; foldable
-: next-save ( n -- i ) cell - ; foldable
-: xt-save ( n -- i ) 2 cells - ; foldable
-
-! Next, we have the spill area as well as the FFI parameter area.
-! It is safe for them to overlap, since basic blocks with FFI calls
-! will never spill -- indeed, basic blocks with FFI calls do not
-! use vregs at all, and the FFI call is a stack analysis sync point.
-! In the future this will change and the stack frame logic will
-! need to be untangled somewhat.
-
-: param@ ( n -- x ) reserved-area-size + ; inline
-
-: param-save-size ( -- n ) 8 cells ; foldable
-
-: local@ ( n -- x )
- reserved-area-size param-save-size + + ; inline
-
-: spill@ ( n -- offset )
- spill-offset local@ ;
-
-! Some FP intrinsics need a temporary scratch area in the stack
-! frame, 8 bytes in size. This is in the param-save area so it
-! does not overlap with spill slots.
-: scratch@ ( n -- offset )
- factor-area-size + ;
-
-! Finally we have the linkage area
-HOOK: lr-save os ( -- n )
-
-M: ppc stack-frame-size ( stack-frame -- i )
- (stack-frame-size)
- param-save-size +
- reserved-area-size +
- factor-area-size +
- 4 cells align ;
-
-M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
-
-M: ppc %jump ( word -- )
- 0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here
- 0 B rc-relative-ppc-3 rel-word-pic-tail ;
-
-M: ppc %jump-label ( label -- ) B ;
-M: ppc %return ( -- ) BLR ;
-
-M:: ppc %dispatch ( src temp -- )
- 0 temp LOAD32
- 3 cells rc-absolute-ppc-2/2 rel-here
- temp temp src LWZX
- temp MTCTR
- BCTR ;
-
-: (%slot) ( dst obj slot scale tag -- obj dst slot )
- [ 0 assert= ] bi@ swapd ;
-
-M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ;
-M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
-M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ;
-M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
-
-M: ppc %add ADD ;
-M: ppc %add-imm ADDI ;
-M: ppc %sub swap SUBF ;
-M: ppc %sub-imm SUBI ;
-M: ppc %mul MULLW ;
-M: ppc %mul-imm MULLI ;
-M: ppc %and AND ;
-M: ppc %and-imm ANDI ;
-M: ppc %or OR ;
-M: ppc %or-imm ORI ;
-M: ppc %xor XOR ;
-M: ppc %xor-imm XORI ;
-M: ppc %shl SLW ;
-M: ppc %shl-imm swapd SLWI ;
-M: ppc %shr SRW ;
-M: ppc %shr-imm swapd SRWI ;
-M: ppc %sar SRAW ;
-M: ppc %sar-imm SRAWI ;
-M: ppc %not NOT ;
-M: ppc %neg NEG ;
-
-:: overflow-template ( label dst src1 src2 cc insn -- )
- 0 0 LI
- 0 MTXER
- dst src2 src1 insn call
- cc {
- { cc-o [ label BO ] }
- { cc/o [ label BNO ] }
- } case ; inline
-
-M: ppc %fixnum-add ( label dst src1 src2 cc -- )
- [ ADDO. ] overflow-template ;
-
-M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
- [ SUBFO. ] overflow-template ;
-
-M: ppc %fixnum-mul ( label dst src1 src2 cc -- )
- [ MULLWO. ] overflow-template ;
-
-M: ppc %add-float FADD ;
-M: ppc %sub-float FSUB ;
-M: ppc %mul-float FMUL ;
-M: ppc %div-float FDIV ;
-
-M: ppc integer-float-needs-stack-frame? t ;
-
-M:: ppc %integer>float ( dst src -- )
- HEX: 4330 scratch-reg LIS
- scratch-reg 1 0 scratch@ STW
- scratch-reg src MR
- scratch-reg dup HEX: 8000 XORIS
- scratch-reg 1 4 scratch@ STW
- dst 1 0 scratch@ LFD
- scratch-reg 4503601774854144.0 %load-reference
- fp-scratch-reg scratch-reg float-offset LFD
- dst dst fp-scratch-reg FSUB ;
-
-M:: ppc %float>integer ( dst src -- )
- fp-scratch-reg src FCTIWZ
- fp-scratch-reg 1 0 scratch@ STFD
- dst 1 4 scratch@ LWZ ;
-
-M: ppc %copy ( dst src rep -- )
- 2over eq? [ 3drop ] [
- {
- { tagged-rep [ MR ] }
- { int-rep [ MR ] }
- { double-rep [ FMR ] }
- } case
- ] if ;
-
-GENERIC: float-function-param* ( dst src -- )
-
-M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
-M: integer float-function-param* FMR ;
-
-: float-function-param ( i src -- )
- [ float-regs cdecl param-regs at nth ] dip float-function-param* ;
-
-: float-function-return ( reg -- )
- float-regs return-regs at first double-rep %copy ;
-
-M:: ppc %unary-float-function ( dst src func -- )
- 0 src float-function-param
- func f %c-invoke
- dst float-function-return ;
-
-M:: ppc %binary-float-function ( dst src1 src2 func -- )
- 0 src1 float-function-param
- 1 src2 float-function-param
- func f %c-invoke
- dst float-function-return ;
-
-! Internal format is always double-precision on PowerPC
-M: ppc %single>double-float double-rep %copy ;
-M: ppc %double>single-float FRSP ;
-
-M: ppc %unbox-alien ( dst src -- )
- alien-offset LWZ ;
-
-M:: ppc %unbox-any-c-ptr ( dst src -- )
- [
- "end" define-label
- 0 dst LI
- ! Is the object f?
- 0 src \ f type-number CMPI
- "end" get BEQ
- ! Compute tag in dst register
- dst src tag-mask get ANDI
- ! Is the object an alien?
- 0 dst alien type-number CMPI
- ! Add an offset to start of byte array's data
- dst src byte-array-offset ADDI
- "end" get BNE
- ! If so, load the offset and add it to the address
- dst src alien-offset LWZ
- "end" resolve-label
- ] with-scope ;
-
-: alien@ ( n -- n' ) cells alien type-number - ;
-
-M:: ppc %box-alien ( dst src temp -- )
- [
- "f" define-label
- dst \ f type-number %load-immediate
- 0 src 0 CMPI
- "f" get BEQ
- dst 5 cells alien temp %allot
- temp \ f type-number %load-immediate
- temp dst 1 alien@ STW
- temp dst 2 alien@ STW
- src dst 3 alien@ STW
- src dst 4 alien@ STW
- "f" resolve-label
- ] with-scope ;
-
-:: %box-displaced-alien/f ( dst displacement base -- )
- base dst 1 alien@ STW
- displacement dst 3 alien@ STW
- displacement dst 4 alien@ STW ;
-
-:: %box-displaced-alien/alien ( dst displacement base temp -- )
- ! Set new alien's base to base.base
- temp base 1 alien@ LWZ
- temp dst 1 alien@ STW
-
- ! Compute displacement
- temp base 3 alien@ LWZ
- temp temp displacement ADD
- temp dst 3 alien@ STW
-
- ! Compute address
- temp base 4 alien@ LWZ
- temp temp displacement ADD
- temp dst 4 alien@ STW ;
-
-:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
- base dst 1 alien@ STW
- displacement dst 3 alien@ STW
- temp base byte-array-offset ADDI
- temp temp displacement ADD
- temp dst 4 alien@ STW ;
-
-:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
- "not-f" define-label
- "not-alien" define-label
-
- ! Is base f?
- 0 base \ f type-number CMPI
- "not-f" get BNE
-
- ! Yes, it is f. Fill in new object
- dst displacement base %box-displaced-alien/f
-
- "end" get B
-
- "not-f" resolve-label
-
- ! Check base type
- temp base tag-mask get ANDI
-
- ! Is base an alien?
- 0 temp alien type-number CMPI
- "not-alien" get BNE
-
- dst displacement base temp %box-displaced-alien/alien
-
- ! We are done
- "end" get B
-
- ! Is base a byte array? It has to be, by now...
- "not-alien" resolve-label
-
- dst displacement base temp %box-displaced-alien/byte-array ;
-
-M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
- ! This is ridiculous
- [
- "end" define-label
-
- ! If displacement is zero, return the base
- dst base MR
- 0 displacement 0 CMPI
- "end" get BEQ
-
- ! Displacement is non-zero, we're going to be allocating a new
- ! object
- dst 5 cells alien temp %allot
-
- ! Set expired to f
- temp \ f type-number %load-immediate
- temp dst 2 alien@ STW
-
- dst displacement base temp
- {
- { [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] }
- { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
- { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
- [ %box-displaced-alien/dynamic ]
- } cond
-
- "end" resolve-label
- ] with-scope ;
-
-: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
- [ [ 0 assert= ] bi@ swapd ] 2dip ; inline
-
-M: ppc %load-memory-imm ( dst base offset rep c-type -- )
- [
- {
- { c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
- { c:uchar [ LBZ ] }
- { c:short [ LHA ] }
- { c:ushort [ LHZ ] }
- { c:int [ LWZ ] }
- { c:uint [ LWZ ] }
- } case
- ] [
- {
- { int-rep [ LWZ ] }
- { float-rep [ LFS ] }
- { double-rep [ LFD ] }
- } case
- ] ?if ;
-
-M: ppc %load-memory ( dst base displacement scale offset rep c-type -- )
- (%memory) [
- {
- { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
- { c:uchar [ LBZX ] }
- { c:short [ LHAX ] }
- { c:ushort [ LHZX ] }
- { c:int [ LWZX ] }
- { c:uint [ LWZX ] }
- } case
- ] [
- {
- { int-rep [ LWZX ] }
- { float-rep [ LFSX ] }
- { double-rep [ LFDX ] }
- } case
- ] ?if ;
-
-M: ppc %store-memory-imm ( src base offset rep c-type -- )
- [
- {
- { c:char [ STB ] }
- { c:uchar [ STB ] }
- { c:short [ STH ] }
- { c:ushort [ STH ] }
- { c:int [ STW ] }
- { c:uint [ STW ] }
- } case
- ] [
- {
- { int-rep [ STW ] }
- { float-rep [ STFS ] }
- { double-rep [ STFD ] }
- } case
- ] ?if ;
-
-M: ppc %store-memory ( src base displacement scale offset rep c-type -- )
- (%memory) [
- {
- { c:char [ STBX ] }
- { c:uchar [ STBX ] }
- { c:short [ STHX ] }
- { c:ushort [ STHX ] }
- { c:int [ STWX ] }
- { c:uint [ STWX ] }
- } case
- ] [
- {
- { int-rep [ STWX ] }
- { float-rep [ STFSX ] }
- { double-rep [ STFDX ] }
- } case
- ] ?if ;
-
-: load-zone-ptr ( reg -- )
- vm-reg "nursery" vm-field-offset ADDI ;
-
-: load-allot-ptr ( nursery-ptr allot-ptr -- )
- [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
-
-:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
- scratch-reg allot-ptr n data-alignment get align ADDI
- scratch-reg nursery-ptr 0 STW ;
-
-:: store-header ( dst class -- )
- class type-number tag-header scratch-reg LI
- scratch-reg dst 0 STW ;
-
-: store-tagged ( dst tag -- )
- dupd type-number ORI ;
-
-M:: ppc %allot ( dst size class nursery-ptr -- )
- nursery-ptr dst load-allot-ptr
- nursery-ptr dst size inc-allot-ptr
- dst class store-header
- dst class store-tagged ;
-
-: load-cards-offset ( dst -- )
- 0 swap LOAD32 rc-absolute-ppc-2/2 rel-cards-offset ;
-
-: load-decks-offset ( dst -- )
- 0 swap LOAD32 rc-absolute-ppc-2/2 rel-decks-offset ;
-
-:: (%write-barrier) ( temp1 temp2 -- )
- card-mark scratch-reg LI
-
- ! Mark the card
- temp1 temp1 card-bits SRWI
- temp2 load-cards-offset
- temp1 scratch-reg temp2 STBX
-
- ! Mark the card deck
- temp1 temp1 deck-bits card-bits - SRWI
- temp2 load-decks-offset
- temp1 scratch-reg temp2 STBX ;
-
-M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
- scale 0 assert= tag 0 assert=
- temp1 src slot ADD
- temp1 temp2 (%write-barrier) ;
-
-M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
- temp1 src slot tag slot-offset ADDI
- temp1 temp2 (%write-barrier) ;
-
-M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
- temp1 vm-reg "nursery" vm-field-offset LWZ
- temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ
- temp1 temp1 size ADDI
- ! is here >= end?
- temp1 0 temp2 CMP
- cc {
- { cc<= [ label BLE ] }
- { cc/<= [ label BGT ] }
- } case ;
-
-: gc-root-offsets ( seq -- seq' )
- [ n>> spill@ ] map f like ;
-
-M: ppc %call-gc ( gc-roots -- )
- 3 swap gc-root-offsets %load-reference
- 4 %load-vm-addr
- "inline_gc" f %c-invoke ;
-
-M: ppc %prologue ( n -- )
- 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
- 0 MFLR
- {
- [ [ 1 1 ] dip neg ADDI ]
- [ [ 11 1 ] dip xt-save STW ]
- [ 11 LI ]
- [ [ 11 1 ] dip next-save STW ]
- [ [ 0 1 ] dip lr-save + STW ]
- } cleave ;
-
-M: ppc %epilogue ( n -- )
- #! At the end of each word that calls a subroutine, we store
- #! the previous link register value in r0 by popping it off
- #! the stack, set the link register to the contents of r0,
- #! and jump to the link register.
- [ [ 0 1 ] dip lr-save + LWZ ]
- [ [ 1 1 ] dip ADDI ] bi
- 0 MTLR ;
-
-:: (%boolean) ( dst temp branch1 branch2 -- )
- "end" define-label
- dst \ f type-number %load-immediate
- "end" get branch1 execute( label -- )
- branch2 [ "end" get branch2 execute( label -- ) ] when
- dst \ t %load-reference
- "end" get resolve-label ; inline
-
-:: %boolean ( dst cc temp -- )
- cc negate-cc order-cc {
- { cc< [ dst temp \ BLT f (%boolean) ] }
- { cc<= [ dst temp \ BLE f (%boolean) ] }
- { cc> [ dst temp \ BGT f (%boolean) ] }
- { cc>= [ dst temp \ BGE f (%boolean) ] }
- { cc= [ dst temp \ BEQ f (%boolean) ] }
- { cc/= [ dst temp \ BNE f (%boolean) ] }
- } case ;
-
-: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
-
-: (%compare-integer-imm) ( src1 src2 -- )
- [ 0 ] 2dip CMPI ; inline
-
-: (%compare-imm) ( src1 src2 -- )
- [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
-
-: (%compare-float-unordered) ( src1 src2 -- )
- [ 0 ] dip FCMPU ; inline
-
-: (%compare-float-ordered) ( src1 src2 -- )
- [ 0 ] dip FCMPO ; inline
-
-:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
- cc {
- { cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] }
- { cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
- { cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] }
- { cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
- { cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] }
- { cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
- { cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNO f ] }
- { cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] }
- { cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BO ] }
- { cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] }
- { cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BO ] }
- { cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] }
- { cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BO ] }
- { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO f ] }
- } case ; inline
-
-M: ppc %compare [ (%compare) ] 2dip %boolean ;
-
-M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
-
-M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
-
-M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
- src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
- dst temp branch1 branch2 (%boolean) ;
-
-M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
- src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
- dst temp branch1 branch2 (%boolean) ;
-
-:: %branch ( label cc -- )
- cc order-cc {
- { cc< [ label BLT ] }
- { cc<= [ label BLE ] }
- { cc> [ label BGT ] }
- { cc>= [ label BGE ] }
- { cc= [ label BEQ ] }
- { cc/= [ label BNE ] }
- } case ;
-
-M:: ppc %compare-branch ( label src1 src2 cc -- )
- src1 src2 (%compare)
- label cc %branch ;
-
-M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
- src1 src2 (%compare-imm)
- label cc %branch ;
-
-M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
- src1 src2 (%compare-integer-imm)
- label cc %branch ;
-
-:: (%branch) ( label branch1 branch2 -- )
- label branch1 execute( label -- )
- branch2 [ label branch2 execute( label -- ) ] when ; inline
-
-M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
- src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
- label branch1 branch2 (%branch) ;
-
-M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
- src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
- label branch1 branch2 (%branch) ;
-
-: load-from-frame ( dst n rep -- )
- {
- { int-rep [ [ 1 ] dip LWZ ] }
- { tagged-rep [ [ 1 ] dip LWZ ] }
- { float-rep [ [ 1 ] dip LFS ] }
- { double-rep [ [ 1 ] dip LFD ] }
- { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
- } case ;
-
-: next-param@ ( n -- reg x )
- [ 17 ] dip param@ ;
-
-: store-to-frame ( src n rep -- )
- {
- { int-rep [ [ 1 ] dip STW ] }
- { tagged-rep [ [ 1 ] dip STW ] }
- { float-rep [ [ 1 ] dip STFS ] }
- { double-rep [ [ 1 ] dip STFD ] }
- { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
- } case ;
-
-M: ppc %spill ( src rep dst -- )
- swap [ n>> spill@ ] dip store-to-frame ;
-
-M: ppc %reload ( dst rep src -- )
- swap [ n>> spill@ ] dip load-from-frame ;
-
-M: ppc %loop-entry ;
-
-M: ppc return-regs
- {
- { int-regs { 3 4 5 6 } }
- { float-regs { 1 } }
- } ;
-
-M:: ppc %save-param-reg ( stack reg rep -- )
- reg stack local@ rep store-to-frame ;
-
-M:: ppc %load-param-reg ( stack reg rep -- )
- reg stack local@ rep load-from-frame ;
-
-GENERIC: load-param ( reg src -- )
-
-M: integer load-param int-rep %copy ;
-
-M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ;
-
-GENERIC: store-param ( reg dst -- )
-
-M: integer store-param swap int-rep %copy ;
-
-M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
-
-:: call-unbox-func ( src func -- )
- 3 src load-param
- 4 %load-vm-addr
- func f %c-invoke ;
-
-M:: ppc %unbox ( src n rep func -- )
- src func call-unbox-func
- ! Store the return value on the C stack
- n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ;
-
-M:: ppc %unbox-long-long ( src n func -- )
- src func call-unbox-func
- ! Store the return value on the C stack
- n [
- 3 1 n local@ STW
- 4 1 n cell + local@ STW
- ] when ;
-
-M:: ppc %unbox-large-struct ( src n c-type -- )
- 4 src load-param
- 3 1 n local@ ADDI
- c-type heap-size 5 LI
- "memcpy" "libc" load-library %c-invoke ;
-
-M:: ppc %box ( dst n rep func -- )
- n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
- rep double-rep? 5 4 ? %load-vm-addr
- func f %c-invoke
- 3 dst store-param ;
-
-M:: ppc %box-long-long ( dst n func -- )
- n [
- 3 1 n local@ LWZ
- 4 1 n cell + local@ LWZ
- ] when
- 5 %load-vm-addr
- func f %c-invoke
- 3 dst store-param ;
-
-: struct-return@ ( n -- n )
- [ stack-frame get params>> ] unless* local@ ;
-
-M: ppc %prepare-box-struct ( -- )
- #! Compute target address for value struct return
- 3 1 f struct-return@ ADDI
- 3 1 0 local@ STW ;
-
-M:: ppc %box-large-struct ( dst n c-type -- )
- ! If n = f, then we're boxing a returned struct
- ! Compute destination address and load struct size
- 3 1 n struct-return@ ADDI
- c-type heap-size 4 LI
- 5 %load-vm-addr
- ! Call the function
- "from_value_struct" f %c-invoke
- 3 dst store-param ;
-
-M:: ppc %restore-context ( temp1 temp2 -- )
- temp1 %context
- ds-reg temp1 "datastack" context-field-offset LWZ
- rs-reg temp1 "retainstack" context-field-offset LWZ ;
-
-M:: ppc %save-context ( temp1 temp2 -- )
- temp1 %context
- 1 temp1 "callstack-top" context-field-offset STW
- ds-reg temp1 "datastack" context-field-offset STW
- rs-reg temp1 "retainstack" context-field-offset STW ;
-
-M: ppc %c-invoke ( symbol dll -- )
- [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
-
-M: ppc %alien-indirect ( src -- )
- [ 11 ] dip load-param 11 MTLR BLRL ;
-
-M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
-
-M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
-
-M: ppc immediate-store? drop f ;
-
-M: ppc return-struct-in-registers? ( c-type -- ? )
- c-type return-in-registers?>> ;
-
-M:: ppc %box-small-struct ( dst c-type -- )
- #! Box a <= 16-byte struct returned in r3:r4:r5:r6
- c-type heap-size 7 LI
- 8 %load-vm-addr
- "from_medium_struct" f %c-invoke
- 3 dst store-param ;
-
-: %unbox-struct-1 ( -- )
- ! Alien must be in r3.
- 3 3 0 LWZ ;
-
-: %unbox-struct-2 ( -- )
- ! Alien must be in r3.
- 4 3 4 LWZ
- 3 3 0 LWZ ;
-
-: %unbox-struct-4 ( -- )
- ! Alien must be in r3.
- 6 3 12 LWZ
- 5 3 8 LWZ
- 4 3 4 LWZ
- 3 3 0 LWZ ;
-
-M:: ppc %unbox-small-struct ( src c-type -- )
- src 3 load-param
- c-type heap-size {
- { [ dup 4 <= ] [ drop %unbox-struct-1 ] }
- { [ dup 8 <= ] [ drop %unbox-struct-2 ] }
- { [ dup 16 <= ] [ drop %unbox-struct-4 ] }
- } cond ;
-
-M: ppc %begin-callback ( -- )
- 3 %load-vm-addr
- "begin_callback" f %c-invoke ;
-
-M: ppc %alien-callback ( quot -- )
- 3 swap %load-reference
- 4 3 quot-entry-point-offset LWZ
- 4 MTLR
- BLRL ;
-
-M: ppc %end-callback ( -- )
- 3 %load-vm-addr
- "end_callback" f %c-invoke ;
-
-enable-float-functions
-
-USE: vocabs.loader
-
-{
- { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
- { [ os linux? ] [ "cpu.ppc.linux" require ] }
-} cond
-
-complex-double c-type t >>return-in-registers? drop
+++ /dev/null
-32-bit PowerPC compiler backend
+++ /dev/null
-compiler
-not loaded
{ 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
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 ;
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
! 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
! 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
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
[ 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
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
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
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 ;
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
\ (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
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
! 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
: jit-set-context ( -- )
jit-pop-context-and-param
+ jit-save-context
arg1 jit-switch-context
RSP 8 ADD
jit-push-param ;
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
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
M: x86 %scalar>vector %copy ;
enable-float-intrinsics
-enable-float-functions
enable-float-min/max
enable-fsqrt
--- /dev/null
+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
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 ;
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 ( -- )
[ [ FUCOMI ] compare-op ] (%compare-float-branch) ;
enable-float-intrinsics
-enable-float-functions
enable-fsqrt
{ $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."
} 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 -- ? )
{
{
{ [ 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 )
[ 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 ;
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 ;
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 ;
-! 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
"null});\n" write
] with-byte-writer ;
-: send-jedit-request ( request -- )
- jedit-server-info "localhost" rot <inet> binary [
- 4 >be write
- dup length 2 >be write
- write
+:: send-jedit-request ( request -- )
+ jedit-server-file jedit-server-info :> ( port auth )
+ "localhost" port <inet> binary [
+ auth 4 >be write
+ request length 2 >be write
+ request write
] with-client ;
: jedit-location ( file line -- )
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
: test-ftp-server ( quot -- )
'[
- current-temporary-directory get 0
- <ftp-server>
- [ start-server* ]
- [
- sockets>> first addr>> port>>
+ current-temporary-directory get
+ 0 <ftp-server> [
+ insecure-port
<url>
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
[
"/" >>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
! 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
[ 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
<ftp-response>
] recover ;
: random-local-server ( -- server )
- remote-address get class new 0 >>port binary <server> ;
+ remote-address get class new binary <server> ;
: 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
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 ;
: handle-RETR ( obj -- )
tokenized>> second
+ fixup-relative-path
dup can-serve-file? [
<ftp-get> fulfill-client
] [
: handle-MDTM ( obj -- )
tokenized>> 1 swap ?nth [
+ fixup-relative-path
dup file-info dup directory? [
drop not-a-plain-file
] [
: handle-CWD ( obj -- )
tokenized>> 1 swap ?nth [
+ fixup-relative-path
dup can-serve-directory? [
set-current-directory
directory-change-success
"ftp.server" >>name
5 minutes >>timeout ;
-: ftpd ( directory port -- )
+: ftpd ( directory port -- server )
<ftp-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|
+
} 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] ;
CHLOE: a
[
[ a-attrs ]
- [ compile-children>string ] bi
+ [ compile-children>xml-string ] bi
[ <unescaped> [XML <a><-></a> XML] second swap >>attrs ]
[xml-code]
] compile-with-scope ;
[
[ compile-form-attrs ]
[ hidden-fields ]
- [ compile-children>string ] tri
+ [ compile-children>xml-string ] tri
[
<unescaped> [XML <form><-><-></form> XML] second
swap >>attrs
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 ]
] 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 ;
-! 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
{ CHAR: , "__comma__" }
{ CHAR: @ "__at__" }
{ CHAR: # "__hash__" }
+ { CHAR: % "__percent__" }
} at [ % ] [ , ] ?if
] [ number>string "__" "__" surround % ] if ;
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 ;
: render ( name renderer -- )
render>xml write-xml ;
+<PRIVATE
+
+GENERIC: write-nested ( obj -- )
+
+M: string write-nested write ;
+
+M: sequence write-nested [ write-nested ] each ;
+
+PRIVATE>
+
+: render-string ( name renderer -- )
+ render>xml write-nested ;
+
SINGLETON: label
M: label render*
span-css-style
[ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
-: emit-html ( quot stream -- )
+: emit-html ( stream quot -- )
dip data>> push ; inline
: image-path ( path -- images-path )
{ $code
"<t:button t:method=\"POST\""
" t:action=\"$wiki/delete\""
- " t:for=\"id\">"
- " class=\"link-button\""
+ " t:for=\"id\""
+ " class=\"link-button\">"
" Delete"
"</t:button>"
}
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
"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 <world> &escaping test;" ] [
+ [
+ <box> title set
+ [
+ begin-form
+ "&escaping test;" "a-value" set-value
+ "test14" test-template call-template
+ ] run-template
+ title get box>
+ ] with-scope
+] unit-test
+
+[
+ [
+ <box> title set
+ [
+ "test15" test-template call-template
+ ] run-template
+ ] with-scope
+] [ error>> tag-not-allowed-here? ] must-fail-with
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 ]
[ 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' )
: 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
-! 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 -- )
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
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello <world> <t:label t:name="a-value" /></t:title>
+ <t:write-title />
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>This is <b>not</b> allowed</t:title>
+ <t:write-title />
+</t:chloe>
: 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 ;
! 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 ;
[ "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 ;
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
[ "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
] 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"
<http-server>
0 >>insecure
f >>secure
- dup start-server*
- sockets>> first addr>> port>>
+ start-server
+ servers>> random addr>> port>>
] with-scope "port" set ;
[ ] [
{ $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 <http-server> } " and fill in the tuple slots before calling " { $link start-server } "." } ;
";" 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 ;
] 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* ;
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
"http" protocol-port >>insecure
"https" protocol-port >>secure ;
-: httpd ( port -- )
+: httpd ( port -- http-server )
<http-server>
swap >>insecure
f >>secure
: bytes-per-pixel ( image -- n )
[ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ;
+
+: bytes-per-image ( image -- n )
+ [ dim>> product ] [ bytes-per-pixel ] bi * ;
<PRIVATE
M: bsd init-io ( -- )
<kqueue-mx> mx set-global ;
-
-! M: bsd (monitor) ( path recursive? mailbox -- )
-! swap [ "Recursive kqueue monitors not supported" throw ] when
-! <vnode-monitor> ;
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 ;
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 ;
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-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> 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 ;
-
-: <completion-port> ( handle existing -- handle )
- f 1 CreateIoCompletionPort dup win32-error=0/f ;
-
-SYMBOL: master-completion-port
-
-: <master-completion-port> ( -- handle )
- INVALID_HANDLE_VALUE f <completion-port> ;
-
-M: winnt add-completion ( win32-handle -- )
- handle>> master-completion-port get-global <completion-port> 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> master-completion-port set-global
- H{ } clone pending-overlapped set-global ;
-
-ERROR: invalid-file-size n ;
-
-: handle>file-size ( handle -- n )
- 0 <ulonglong> [ 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
+++ /dev/null
-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
-
-TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
-
-! Security tokens
-! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
-
-: (open-process-token) ( handle -- handle )
- flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY }
- { PHANDLE }
- [ OpenProcessToken win32-error=0/f ]
- with-out-parameters ;
-
-: open-process-token ( -- handle )
- #! remember to CloseHandle
- GetCurrentProcess (open-process-token) ;
-
-: with-process-token ( quot -- )
- #! quot: ( token-handle -- token-handle )
- [ open-process-token ] dip
- [ keep ] curry
- [ CloseHandle drop ] [ ] cleanup ; inline
-
-: lookup-privilege ( string -- luid )
- [ f ] dip LUID <struct>
- [ LookupPrivilegeValue win32-error=0/f ] keep ;
-
-:: make-token-privileges ( name enabled? -- obj )
- TOKEN_PRIVILEGES <struct>
- 1 >>PrivilegeCount
- LUID_AND_ATTRIBUTES malloc-struct &free
- enabled? [ SE_PRIVILEGE_ENABLED >>Attributes ] when
- name lookup-privilege >>Luid
- >>Privileges ;
-
-M: winnt set-privilege ( name ? -- )
- '[
- 0
- _ _ make-token-privileges
- dup byte-length
- f
- f
- AdjustTokenPrivileges win32-error=0/f
- ] with-process-token ;
+++ /dev/null
-USING: io.backend.windows.privileges tools.test ;\r
-IN: io.backend.windows.privileges.tests\r
-\r
-[ [ ] with-privileges ] must-infer\r
+++ /dev/null
-USING: io.backend kernel continuations sequences\r
-system vocabs.loader combinators fry ;\r
-IN: io.backend.windows.privileges\r
-\r
-HOOK: set-privilege io-backend ( name ? -- )\r
-\r
-: with-privileges ( seq quot -- )\r
- [ '[ _ [ t set-privilege ] each @ ] ]\r
- [ drop '[ _ [ f set-privilege ] each ] ]\r
- 2bi [ ] cleanup ; inline\r
-\r
-{\r
- { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }\r
- { [ os wince? ] [ "io.backend.windows.ce.privileges" require ] }\r
-} cond\r
-! 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 ;
-
-: <win32-handle> ( 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 ;
-
-: <win32-file> ( 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?
- <win32-file> |dispose
- dup add-completion ;
-
-CONSTANT: share-mode
- flags{
- FILE_SHARE_READ
- FILE_SHARE_WRITE
- FILE_SHARE_DELETE
- }
-
-: default-security-attributes ( -- obj )
- SECURITY_ATTRIBUTES <struct>
- SECURITY_ATTRIBUTES heap-size >>nLength ;
+winnt set-io-backend
{ $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 } }
] 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
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 -- )
-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." }
{ "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:"
--- /dev/null
+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
! 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 ]
: copy-trees-into ( files to -- )
'[ _ copy-tree-into ] each ;
-
{ $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:"
[ second >>mount-point ]
[ third >>type ]
[ fourth <string-reader> 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 )
! 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
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 -- )
<PRIVATE
-: random-letter ( -- ch )
- 26 random { CHAR: a CHAR: A } random + ;
-
-: random-ch ( -- ch )
- { t f } random
- [ 10 random CHAR: 0 + ] [ random-letter ] if ;
-
-: random-name ( -- string )
- unique-length get [ random-ch ] "" replicate-as ;
+: random-file-name ( -- string )
+ unique-length get random-string ;
: retry ( quot: ( -- ? ) n -- )
iota swap [ drop ] prepose attempt-all ; inline
: (make-unique-file) ( path prefix suffix -- path )
'[
- _ _ _ random-name glue append-path
+ _ _ _ random-file-name glue append-path
dup touch-unique-file
] unique-retries get retry ;
: unique-directory ( -- path )
[
current-temporary-directory get
- random-name append-path
+ random-file-name append-path
dup make-directory
] unique-retries get retry ;
-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 -- )
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-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
-
-[ f ] [ "\\foo" absolute-path? ] unit-test
-[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
-[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test
-[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test
-[ t ] [ "c:\\foo" absolute-path? ] unit-test
-[ t ] [ "c:" absolute-path? ] unit-test
-[ t ] [ "c:\\" absolute-path? ] unit-test
-[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test
-
-[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
-! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
-[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
-[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
-[ "c:" ] [ "c:" parent-directory ] unit-test
-[ "Z:" ] [ "Z:" parent-directory ] unit-test
-
-[ f ] [ "" root-directory? ] unit-test
-[ t ] [ "\\" root-directory? ] unit-test
-[ t ] [ "\\\\" root-directory? ] unit-test
-[ t ] [ "/" root-directory? ] unit-test
-[ t ] [ "//" root-directory? ] unit-test
-[ t ] [ "c:\\" trim-tail-separators root-directory? ] unit-test
-[ t ] [ "Z:\\" trim-tail-separators root-directory? ] unit-test
-[ f ] [ "c:\\foo" root-directory? ] unit-test
-[ f ] [ "." root-directory? ] unit-test
-[ f ] [ ".." root-directory? ] unit-test
-[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test
-[ t ] [ "\\\\?\\c:" root-directory? ] unit-test
-[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test
-
-[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
-
-[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
- "C:\\builds\\factor\\12345\\"
- "..\\log.txt" append-path normalize-path
-] unit-test
-
-[ "\\\\?\\C:\\builds\\" ] [
- "C:\\builds\\factor\\12345\\"
- "..\\.." append-path normalize-path
-] unit-test
-
-[ "\\\\?\\C:\\builds\\" ] [
- "C:\\builds\\factor\\12345\\"
- "..\\.." append-path normalize-path
-] unit-test
-
-[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
-[ t ] [ "" resource-path 2 tail exists? ] unit-test
+++ /dev/null
-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 <ushort-array>
- [ 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 ;
-
-<PRIVATE
-
-: windows-file-size ( path -- size )
- normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
- [ 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|| ;
--- /dev/null
+! 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 splitting sequences io.pathnames.private ;
+IN: io.files.windows.tests
+
+[ f ] [ "\\foo" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test
+[ t ] [ "c:\\foo" absolute-path? ] unit-test
+[ t ] [ "c:" absolute-path? ] unit-test
+[ t ] [ "c:\\" absolute-path? ] unit-test
+[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test
+
+[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
+[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
+[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
+! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
+[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
+[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
+[ "c:" ] [ "c:" parent-directory ] unit-test
+[ "Z:" ] [ "Z:" parent-directory ] unit-test
+
+[ f ] [ "" root-directory? ] unit-test
+[ t ] [ "\\" root-directory? ] unit-test
+[ t ] [ "\\\\" root-directory? ] unit-test
+[ t ] [ "/" root-directory? ] unit-test
+[ t ] [ "//" root-directory? ] unit-test
+[ t ] [ "c:\\" trim-tail-separators root-directory? ] unit-test
+[ t ] [ "Z:\\" trim-tail-separators root-directory? ] unit-test
+[ f ] [ "c:\\foo" root-directory? ] unit-test
+[ f ] [ "." root-directory? ] unit-test
+[ f ] [ ".." root-directory? ] unit-test
+[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test
+[ t ] [ "\\\\?\\c:" root-directory? ] unit-test
+[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test
+
+[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
+
+[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\log.txt" append-path normalize-path
+] unit-test
+
+[ "\\\\?\\C:\\builds\\" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\.." append-path normalize-path
+] unit-test
+
+[ "\\\\?\\C:\\builds\\" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\.." append-path normalize-path
+] unit-test
+
+[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
+[ t ] [ "" resource-path 2 tail exists? ] unit-test
! 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 ;
+
+: <win32-file> ( 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 <win32-file> |dispose add-completion ;
+
+CONSTANT: share-mode
+ flags{
+ FILE_SHARE_READ
+ FILE_SHARE_WRITE
+ FILE_SHARE_DELETE
+ }
+
+: default-security-attributes ( -- obj )
+ SECURITY_ATTRIBUTES <struct>
+ SECURITY_ATTRIBUTES heap-size >>nLength ;
+
+TUPLE: FileArgs
+ hFile lpBuffer nNumberOfBytesToRead
+ lpNumberOfBytesRet lpOverlapped ;
+
+C: <FileArgs> FileArgs
+
+: make-FileArgs ( port -- <FileArgs> )
+ {
+ [ handle>> check-disposed ]
+ [ handle>> handle>> ]
+ [ buffer>> ]
+ [ buffer>> buffer-length ]
+ [ drop DWORD <c-object> ]
+ [ FileArgs-overlapped ]
+ } cleave <FileArgs> ;
+
+! Global variable with assoc mapping overlapped to threads
+SYMBOL: pending-overlapped
+
+TUPLE: io-callback port thread ;
+
+C: <io-callback> 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 ;
+
+: <completion-port> ( handle existing -- handle )
+ f 1 CreateIoCompletionPort dup win32-error=0/f ;
+
+SYMBOL: master-completion-port
+
+: <master-completion-port> ( -- handle )
+ INVALID_HANDLE_VALUE f <completion-port> ;
+
+M: winnt add-completion ( win32-handle -- win32-handle )
+ dup handle>> master-completion-port get-global <completion-port> 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> master-completion-port set-global
+ H{ } clone pending-overlapped set-global ;
+
+ERROR: invalid-file-size n ;
+
+: handle>file-size ( handle -- n )
+ 0 <ulonglong> [ 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 ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
+ {
+ [ hFile>> ]
+ [ lpBuffer>> buffer-end ]
+ [ lpBuffer>> buffer-capacity ]
+ [ lpNumberOfBytesRet>> ]
+ [ lpOverlapped>> ]
+ } cleave ;
+
+: setup-write ( <FileArgs> -- 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
[ [ handle>> ] dip d>w/w <uint> ] 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> FileArgs
-
-: make-FileArgs ( port -- <FileArgs> )
- {
- [ handle>> check-disposed ]
- [ handle>> handle>> ]
- [ buffer>> ]
- [ buffer>> buffer-length ]
- [ drop DWORD <c-object> ]
- [ FileArgs-overlapped ]
- } cleave <FileArgs> ;
-
-: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
- {
- [ hFile>> ]
- [ lpBuffer>> buffer-end ]
- [ lpBuffer>> buffer-capacity ]
- [ lpNumberOfBytesRet>> ]
- [ lpOverlapped>> ]
- } cleave ;
-
-: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
- {
- [ hFile>> ]
- [ lpBuffer>> buffer@ ]
- [ lpBuffer>> buffer-length ]
- [ lpNumberOfBytesRet>> ]
- [ lpOverlapped>> ]
- } cleave ;
-
M: windows (file-reader) ( path -- stream )
open-read <input-port> ;
+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 )
: (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 <ushort-array>
+ [ 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 ;
+
+<PRIVATE
+
+: windows-file-size ( path -- size )
+ normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
+ [ 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
{
{ [ os unix? ] [ "io.launcher.unix" require ] }
- { [ os winnt? ] [ "io.launcher.windows.nt" require ] }
+ { [ os windows? ] [ "io.launcher.windows" require ] }
[ ]
} cond
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
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
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-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
-
-[ ] [
- <process>
- "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
-
-[
- <process>
- "notepad" >>command
- 1/2 seconds >>timeout
- try-process
-] must-fail
-
-[
- <process>
- "notepad" >>command
- 1/2 seconds >>timeout
- try-output-process
-] must-fail
-
-: console-vm ( -- path )
- vm ".exe" ?tail [ ".com" append ] when ;
-
-[ ] [
- <process>
- 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 ) " ] [
- <process>
- 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 [
- <process>
- 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 [
- <process>
- 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 [
- <process>
- console-vm "-script" "stderr.factor" 3array >>command
- "err2.txt" temp-file >>stderr
- ascii <process-reader> stream-lines first
- ] with-directory
-] unit-test
-
-[ "error" ] [
- "err2.txt" temp-file ascii file-lines first
-] unit-test
-
-[ t ] [
- launcher-test-path [
- <process>
- console-vm "-script" "env.factor" 3array >>command
- ascii <process-reader> stream-contents
- ] with-directory eval( -- alist )
-
- os-envs =
-] unit-test
-
-[ t ] [
- launcher-test-path [
- <process>
- console-vm "-script" "env.factor" 3array >>command
- +replace-environment+ >>environment-mode
- os-envs >>environment
- ascii <process-reader> stream-contents
- ] with-directory eval( -- alist )
-
- os-envs =
-] unit-test
-
-[ "B" ] [
- launcher-test-path [
- <process>
- console-vm "-script" "env.factor" 3array >>command
- { { "A" "B" } } >>environment
- ascii <process-reader> stream-contents
- ] with-directory eval( -- alist )
-
- "A" swap at
-] unit-test
-
-[ f ] [
- launcher-test-path [
- <process>
- console-vm "-script" "env.factor" 3array >>command
- { { "USERPROFILE" "XXX" } } >>environment
- +prepend-environment+ >>environment-mode
- ascii <process-reader> stream-contents
- ] with-directory eval( -- alist )
-
- "USERPROFILE" swap at "XXX" =
-] unit-test
-
-2 [
- [ ] [
- <process>
- "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 [
- <process>
- console-vm "-script" "append.factor" 3array >>command
- "append-test" temp-file <appender> >>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
-
-[ ] [
- <process>
- console-vm "-run=listener" 2array >>command
- "vocab:io/launcher/windows/nt/test/input.txt" >>stdin
- try-process
-] unit-test
+++ /dev/null
-! 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 <void*> [ ! target handle
- DUPLICATE_SAME_ACCESS ! desired access
- TRUE ! inherit handle
- 0 ! options
- DuplicateHandle win32-error=0/f
- ] keep *void* <win32-handle> &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? <win32-file> &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 ;
+++ /dev/null
-USE: io\r
-"Hello appender" print\r
+++ /dev/null
-USE: system
-USE: prettyprint
-USE: environment
-os-envs .
+++ /dev/null
-USE: system 0 exit\r
+++ /dev/null
-USE: io\r
-USE: namespaces\r
-\r
-"output" write flush\r
-"error" error-stream get stream-write error-stream get stream-flush\r
--- /dev/null
+USE: io
+"Hello appender" print
--- /dev/null
+USE: system
+USE: prettyprint
+USE: environment
+os-envs .
--- /dev/null
+USE: system 0 exit
--- /dev/null
+USE: io
+USE: namespaces
+
+"output" write flush
+"error" error-stream get stream-write error-stream get stream-flush
+USING: accessors arrays assocs calendar continuations\r
+environment eval hashtables io io.directories\r
+io.encodings.ascii io.files io.files.temp io.launcher\r
+io.launcher.windows io.pathnames kernel math namespaces parser\r
+sequences splitting system tools.test ;\r
IN: io.launcher.windows.tests\r
-USING: tools.test io.launcher.windows ;\r
\r
[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test\r
\r
[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test\r
\r
[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test\r
+\r
+[ ] [\r
+ <process>\r
+ "notepad" >>command\r
+ 1/2 seconds >>timeout\r
+ "notepad" set\r
+] unit-test\r
+\r
+[ f ] [ "notepad" get process-running? ] unit-test\r
+\r
+[ f ] [ "notepad" get process-started? ] unit-test\r
+\r
+[ ] [ "notepad" [ run-detached ] change ] unit-test\r
+\r
+[ "notepad" get wait-for-process ] must-fail\r
+\r
+[ t ] [ "notepad" get killed>> ] unit-test\r
+\r
+[ f ] [ "notepad" get process-running? ] unit-test\r
+\r
+[\r
+ <process>\r
+ "notepad" >>command\r
+ 1/2 seconds >>timeout\r
+ try-process\r
+] must-fail\r
+\r
+[\r
+ <process>\r
+ "notepad" >>command\r
+ 1/2 seconds >>timeout\r
+ try-output-process\r
+] must-fail\r
+\r
+: console-vm ( -- path )\r
+ vm ".exe" ?tail [ ".com" append ] when ;\r
+\r
+[ ] [\r
+ <process>\r
+ console-vm "-quiet" "-run=hello-world" 3array >>command\r
+ "out.txt" temp-file >>stdout\r
+ try-process\r
+] unit-test\r
+\r
+[ "Hello world" ] [\r
+ "out.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ "( scratchpad ) " ] [\r
+ <process>\r
+ console-vm "-run=listener" 2array >>command\r
+ +closed+ >>stdin\r
+ +stdout+ >>stderr\r
+ ascii [ lines last ] with-process-reader\r
+] unit-test\r
+\r
+: launcher-test-path ( -- str )\r
+ "resource:basis/io/launcher/windows/test" ;\r
+\r
+[ ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "stderr.factor" 3array >>command\r
+ "out.txt" temp-file >>stdout\r
+ "err.txt" temp-file >>stderr\r
+ try-process\r
+ ] with-directory\r
+] unit-test\r
+\r
+[ "output" ] [\r
+ "out.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ "error" ] [\r
+ "err.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "stderr.factor" 3array >>command\r
+ "out.txt" temp-file >>stdout\r
+ +stdout+ >>stderr\r
+ try-process\r
+ ] with-directory\r
+] unit-test\r
+\r
+[ "outputerror" ] [\r
+ "out.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ "output" ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "stderr.factor" 3array >>command\r
+ "err2.txt" temp-file >>stderr\r
+ ascii <process-reader> stream-lines first\r
+ ] with-directory\r
+] unit-test\r
+\r
+[ "error" ] [\r
+ "err2.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ t ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "env.factor" 3array >>command\r
+ ascii <process-reader> stream-contents\r
+ ] with-directory eval( -- alist )\r
+\r
+ os-envs =\r
+] unit-test\r
+\r
+[ t ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "env.factor" 3array >>command\r
+ +replace-environment+ >>environment-mode\r
+ os-envs >>environment\r
+ ascii <process-reader> stream-contents\r
+ ] with-directory eval( -- alist )\r
+ \r
+ os-envs =\r
+] unit-test\r
+\r
+[ "B" ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "env.factor" 3array >>command\r
+ { { "A" "B" } } >>environment\r
+ ascii <process-reader> stream-contents\r
+ ] with-directory eval( -- alist )\r
+\r
+ "A" swap at\r
+] unit-test\r
+\r
+[ f ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "env.factor" 3array >>command\r
+ { { "USERPROFILE" "XXX" } } >>environment\r
+ +prepend-environment+ >>environment-mode\r
+ ascii <process-reader> stream-contents\r
+ ] with-directory eval( -- alist )\r
+\r
+ "USERPROFILE" swap at "XXX" =\r
+] unit-test\r
+\r
+2 [\r
+ [ ] [\r
+ <process>\r
+ "cmd.exe /c dir" >>command\r
+ "dir.txt" temp-file >>stdout\r
+ try-process\r
+ ] unit-test\r
+\r
+ [ ] [ "dir.txt" temp-file delete-file ] unit-test\r
+] times\r
+\r
+[ "append-test" temp-file delete-file ] ignore-errors\r
+\r
+[ "Hello appender\r\nHello appender\r\n" ] [\r
+ 2 [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "append.factor" 3array >>command\r
+ "append-test" temp-file <appender> >>stdout\r
+ try-process\r
+ ] with-directory\r
+ ] times\r
+ \r
+ "append-test" temp-file ascii file-contents\r
+] unit-test\r
+\r
+[ "( scratchpad ) " ] [\r
+ console-vm "-run=listener" 2array\r
+ ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream\r
+] unit-test\r
+\r
+[ ] [\r
+ console-vm "-run=listener" 2array\r
+ ascii [ "USE: system 0 exit" print ] with-process-writer\r
+] unit-test\r
+\r
+[ ] [\r
+ <process>\r
+ console-vm "-run=listener" 2array >>command\r
+ "vocab:io/launcher/windows/test/input.txt" >>stdin\r
+ try-process\r
+] unit-test\r
! 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
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 <void*> [ ! target handle
+ DUPLICATE_SAME_ACCESS ! desired access
+ TRUE ! inherit handle
+ 0 ! options
+ DuplicateHandle win32-error=0/f
+ ] keep *void* <win32-handle> &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 <win32-file> &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 ;
{ $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 ;"
""
"\"mydata.dat\" char ["
" 4 <sliced-groups>"
- " [ reverse! drop ] map! drop"
+ " [ reverse! drop ] each"
"] with-mapped-array"
}
"Normalize a file containing packed quadrupes of floats:"
-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 )
"An example which watches a directory for changes:"\r
{ $code\r
"USE: io.monitors"\r
+ ""\r
": watch-loop ( monitor -- )"\r
- " dup next-change path>> print nl nl flush watch-loop ;"\r
+ " dup next-change path>> print flush watch-loop ;"\r
""\r
": watch-directory ( path -- )"\r
" [ t [ watch-loop ] with-monitor ] with-monitors ;"\r
-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? [
[
{
{ [ 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
--- /dev/null
+Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-IN: io.monitors.windows.nt.tests\r
-USING: io.monitors.windows.nt tools.test ;\r
-\r
-\r
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-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
-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
-
-: open-directory ( path -- handle )
- normalize-path
- FILE_LIST_DIRECTORY
- share-mode
- f
- OPEN_EXISTING
- flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED }
- f
- CreateFile opened-file ;
-
-TUPLE: win32-monitor-port < input-port recursive ;
-
-TUPLE: win32-monitor < monitor port ;
-
-: begin-reading-changes ( port -- overlapped )
- {
- [ handle>> handle>> ]
- [ buffer>> ptr>> ]
- [ buffer>> size>> ]
- [ recursive>> 1 0 ? ]
- } cleave
- FILE_NOTIFY_CHANGE_ALL
- 0 <uint>
- (make-overlapped)
- [ f ReadDirectoryChangesW win32-error=0/f ] keep ;
-
-: read-changes ( port -- bytes-transferred )
- [
- [ begin-reading-changes ] [ twiddle-thumbs ] bi
- ] with-destructors ;
-
-: parse-action ( action -- changed )
- {
- { FILE_ACTION_ADDED [ +add-file+ ] }
- { FILE_ACTION_REMOVED [ +remove-file+ ] }
- { FILE_ACTION_MODIFIED [ +modify-file+ ] }
- { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] }
- { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] }
- [ drop +modify-file+ ]
- } case 1array ;
-
-: memory>u16-string ( alien len -- string )
- memory>byte-array utf16n decode ;
-
-: parse-notify-record ( buffer -- path changed )
- [ [ FileName>> ] [ FileNameLength>> ] bi memory>u16-string ]
- [ Action>> parse-action ] bi ;
-
-: (file-notify-records) ( buffer -- buffer )
- FILE_NOTIFY_INFORMATION memory>struct
- dup ,
- dup NextEntryOffset>> zero? [
- [ NextEntryOffset>> ] [ >c-ptr <displaced-alien> ] bi
- (file-notify-records)
- ] unless ;
-
-: file-notify-records ( buffer -- seq )
- [ (file-notify-records) drop ] { } make ;
-
-:: parse-notify-records ( monitor buffer -- )
- buffer file-notify-records [
- parse-notify-record
- [ monitor path>> prepend-path normalize-path ] dip
- monitor queue-change
- ] each ;
-
-: fill-queue ( monitor -- )
- dup port>> dup check-disposed
- [ buffer>> ptr>> ] [ read-changes zero? ] bi
- [ 2dup parse-notify-records ] unless
- 2drop ;
-
-: (fill-queue-thread) ( monitor -- )
- dup fill-queue (fill-queue-thread) ;
-
-: fill-queue-thread ( monitor -- )
- [ dup fill-queue (fill-queue-thread) ]
- [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ;
-
-M:: winnt (monitor) ( path recursive? mailbox -- monitor )
- [
- path normalize-path mailbox win32-monitor new-monitor
- path open-directory \ win32-monitor-port <buffered-port>
- recursive? >>recursive
- >>port
- dup [ fill-queue-thread ] curry
- "Windows monitor thread" spawn drop
- ] with-destructors ;
-
-M: win32-monitor dispose
- [ port>> dispose ] [ call-next-method ] bi ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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.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
+
+: open-directory ( path -- handle )
+ normalize-path
+ FILE_LIST_DIRECTORY
+ share-mode
+ f
+ OPEN_EXISTING
+ flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED }
+ f
+ CreateFile opened-file ;
+
+TUPLE: win32-monitor-port < input-port recursive ;
+
+TUPLE: win32-monitor < monitor port ;
+
+: begin-reading-changes ( port -- overlapped )
+ {
+ [ handle>> handle>> ]
+ [ buffer>> ptr>> ]
+ [ buffer>> size>> ]
+ [ recursive>> 1 0 ? ]
+ } cleave
+ FILE_NOTIFY_CHANGE_ALL
+ 0 <uint>
+ (make-overlapped)
+ [ f ReadDirectoryChangesW win32-error=0/f ] keep ;
+
+: read-changes ( port -- bytes-transferred )
+ [
+ [ begin-reading-changes ] [ twiddle-thumbs ] bi
+ ] with-destructors ;
+
+: parse-action ( action -- changed )
+ {
+ { FILE_ACTION_ADDED [ +add-file+ ] }
+ { FILE_ACTION_REMOVED [ +remove-file+ ] }
+ { FILE_ACTION_MODIFIED [ +modify-file+ ] }
+ { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] }
+ { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] }
+ [ drop +modify-file+ ]
+ } case 1array ;
+
+: memory>u16-string ( alien len -- string )
+ memory>byte-array utf16n decode ;
+
+: parse-notify-record ( buffer -- path changed )
+ [ [ FileName>> ] [ FileNameLength>> ] bi memory>u16-string ]
+ [ Action>> parse-action ] bi ;
+
+: (file-notify-records) ( buffer -- buffer )
+ FILE_NOTIFY_INFORMATION memory>struct
+ dup ,
+ dup NextEntryOffset>> zero? [
+ [ NextEntryOffset>> ] [ >c-ptr <displaced-alien> ] bi
+ (file-notify-records)
+ ] unless ;
+
+: file-notify-records ( buffer -- seq )
+ [ (file-notify-records) drop ] { } make ;
+
+:: parse-notify-records ( monitor buffer -- )
+ buffer file-notify-records [
+ parse-notify-record
+ [ monitor path>> prepend-path normalize-path ] dip
+ monitor queue-change
+ ] each ;
+
+: fill-queue ( monitor -- )
+ dup port>> dup check-disposed
+ [ buffer>> ptr>> ] [ read-changes zero? ] bi
+ [ 2dup parse-notify-records ] unless
+ 2drop ;
+
+: (fill-queue-thread) ( monitor -- )
+ dup fill-queue (fill-queue-thread) ;
+
+: fill-queue-thread ( monitor -- )
+ [ dup fill-queue (fill-queue-thread) ]
+ [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ;
+
+M:: winnt (monitor) ( path recursive? mailbox -- monitor )
+ [
+ path normalize-path mailbox win32-monitor new-monitor
+ path open-directory \ win32-monitor-port <buffered-port>
+ recursive? >>recursive
+ >>port
+ dup [ fill-queue-thread ] curry
+ "Windows monitor thread" spawn drop
+ ] with-destructors ;
+
+M: win32-monitor dispose
+ [ port>> dispose ] [ call-next-method ] bi ;
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" ] [
[
utf8 <pipe> [
- 5 seconds over set-timeout
+ 1 seconds over set-timeout
stream-readln
] with-disposal
] must-fail
] curry ignore-errors
] times
] unit-test
+
+! 0 read should not block
+[ f ] [
+ [
+ binary <pipe> &dispose
+ in>>
+ [ 0 read ] with-input-stream
+ ] with-destructors
+] unit-test
{
{ [ os unix? ] [ "io.pipes.unix" require ] }
- { [ os winnt? ] [ "io.pipes.windows.nt" require ] }
+ { [ os windows? ] [ "io.pipes.windows" require ] }
[ ]
} cond
--- /dev/null
+Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
-
-! This code is based on
-! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
-
-: create-named-pipe ( name -- handle )
- flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED }
- PIPE_TYPE_BYTE
- 1
- 4096
- 4096
- 0
- default-security-attributes
- CreateNamedPipe opened-file ;
-
-: open-other-end ( name -- handle )
- GENERIC_WRITE
- flags{ FILE_SHARE_READ FILE_SHARE_WRITE }
- default-security-attributes
- OPEN_EXISTING
- FILE_FLAG_OVERLAPPED
- f
- CreateFile opened-file ;
-
-: unique-pipe-name ( -- string )
- [
- "\\\\.\\pipe\\factor-" %
- pipe counter #
- "-" %
- 32 random-bits #
- "-" %
- nano-count #
- ] "" make ;
-
-M: winnt (pipe) ( -- pipe )
- [
- unique-pipe-name
- [ create-named-pipe ] [ open-other-end ] bi
- pipe boa
- ] with-destructors ;
--- /dev/null
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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
+
+: create-named-pipe ( name -- handle )
+ flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED }
+ PIPE_TYPE_BYTE
+ 1
+ 4096
+ 4096
+ 0
+ default-security-attributes
+ CreateNamedPipe opened-file ;
+
+: open-other-end ( name -- handle )
+ GENERIC_WRITE
+ flags{ FILE_SHARE_READ FILE_SHARE_WRITE }
+ default-security-attributes
+ OPEN_EXISTING
+ FILE_FLAG_OVERLAPPED
+ f
+ CreateFile opened-file ;
+
+: unique-pipe-name ( -- string )
+ [
+ "\\\\.\\pipe\\factor-" %
+ pipe counter #
+ "-" %
+ 32 random-bits #
+ "-" %
+ nano-count #
+ ] "" make ;
+
+M: winnt (pipe) ( -- pipe )
+ [
+ unique-pipe-name
+ [ create-named-pipe ] [ open-other-end ] bi
+ pipe boa
+ ] with-destructors ;
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 > [
] if ;
M: input-port stream-read
- dup check-disposed
- [ 0 max >fixnum ] dip
+ prepare-read
2dup read-step dup [
pick over length > [
pick <byte-vector>
+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"
"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
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*
+HELP: stop-server
{ $values { "threaded-server" threaded-server } }
-{ $description "Starts a threaded server, returning as soon as it is ready to begin accepting connections." } ;
+{ $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: stop-server
+HELP: wait-for-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 "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." } ;
+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 <threaded-server> listen-on empty? ] unit-test
init-server semaphore>> count>>
] unit-test
-[ ] [
+[ "Hello world." ] [
ascii <threaded-server>
5 >>max-connections
0 >>insecure
[ "Hello world." write stop-this-server ] >>handler
- dup start-server* sockets>> first addr>> port>> "port" set
+ [
+ "localhost" insecure-port <inet> ascii <client> drop stream-contents
+ ] with-threaded-server
] unit-test
-[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop stream-contents ] unit-test
+[ ] [
+ ascii <threaded-server>
+ 5 >>max-connections
+ 0 >>insecure
+ start-server [ '[ _ wait-for-server ] in-thread ] [ stop-server ] bi
+] unit-test
-! 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 ;
+
+<PRIVATE
+
+: must-be-running ( threaded-server -- threaded-server )
+ dup running-servers get in? [ server-not-running ] unless ;
+
+: must-not-be-running ( threaded-server -- threaded-server )
+ dup running-servers get in? [ server-already-running ] when ;
+
+: add-running-server ( threaded-server -- )
+ must-not-be-running
+ running-servers get adjoin ;
+
+: remove-running-server ( threaded-server -- )
+ must-be-running
+ running-servers get delete ;
+
+PRIVATE>
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
"server" >>name
DEBUG >>log-level
<secure-config> >>secure-config
- V{ } clone >>sockets
1 minutes >>timeout
[ "No handler quotation" throw ] >>handler
- <flag> >>ready
swap >>encoding ;
: <threaded-server> ( encoding -- threaded-server )
<PRIVATE
-: >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|| [ <secure> ] unless ;
+ [ dup { [ secure? ] [ not ] } 1|| [ <secure> ] 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 -- )
[
\ 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>> <server>
- [ 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 )
+ <flag> >>server-stopped
dup semaphore>> [
dup max-connections>> [
<semaphore> >>semaphore
] when*
] unless ;
+ERROR: no-ports-configured threaded-server ;
+
+: (make-servers) ( theaded-server addrspecs -- servers )
+ swap encoding>>
+ '[ [ _ <server> |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
(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 ;
+
+: with-threaded-server ( threaded-server quot -- )
+ [ start-server ] dip over
+ '[
+ [ _ threaded-server _ with-variable ]
+ [ _ stop-server ]
+ [ ] cleanup
+ ] call ; inline
+
+<PRIVATE
+
+: first-port ( quot -- n/f )
+ [ threaded-server get servers>> ] dip
+ filter [ f ] [ first addr>> port>> ] if-empty ; inline
+
+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 ;
-M: integer port ;
+: 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 ;
-M: object port port>> ;
+: all-servers ( -- sequence )
+ running-servers get-global members ;
-: secure-port ( -- n )
- threaded-server get dup [ secure>> port ] when ;
+: get-servers-named ( string -- sequence )
+ [ all-servers ] dip '[ name>> _ = ] filter ;
+
+: servers. ( -- )
+ all-servers [ server. ] each ;
-: insecure-port ( -- n )
- threaded-server get dup [ insecure>> port ] when ;
+: stop-all-servers ( -- )
+ all-servers [ stop-server ] each ;
--- /dev/null
+John Benediktsson
--- /dev/null
+
+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 <icmp> } "." }
+{ $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\" <icmp>" }
+} ;
+
+HELP: <icmp>
+{ $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 <icmp4> } "."
+}
+{ $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\" <icmp4>" }
+} ;
+
+HELP: <icmp4>
+{ $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 <icmp6> } "."
+}
+{ $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\" <icmp6>" }
+} ;
+
+HELP: <icmp6>
+{ $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
+ <icmp>
+}
+"IPv4 addresses, with no host name resolution:"
+{ $subsections
+ icmp4
+ <icmp4>
+}
+"IPv6 addresses, with no host name resolution:"
+{ $subsections
+ icmp6
+ <icmp6>
+} ;
+
+ABOUT: "network-icmp"
+
--- /dev/null
+
+USING: accessors destructors kernel io.sockets io.sockets.icmp
+sequences tools.test ;
+
+IN: io.sockets.icmp.tests
+
+[ { } ] [
+ "localhost" <icmp> resolve-host
+ [ [ icmp4? ] [ icmp6? ] bi or not ] filter
+] unit-test
--- /dev/null
+! 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 >>
+
+<PRIVATE
+
+MEMO: IPPROTO_ICMP4 ( -- protocol )
+ "icmp" getprotobyname proto>> ;
+
+MEMO: IPPROTO_ICMP6 ( -- protocol )
+ "ipv6-icmp" getprotobyname proto>> ;
+
+GENERIC: with-icmp ( addrspec -- addrspec )
+
+PRIVATE>
+
+
+TUPLE: icmp4 < ipv4 ;
+
+C: <icmp4> icmp4
+
+M: ipv4 with-icmp host>> <icmp4> ;
+
+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> icmp6
+
+M: ipv6 with-icmp host>> <icmp6> ;
+
+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> icmp
+
+M: icmp resolve-host call-next-method [ with-icmp ] map ;
--- /dev/null
+Support for ICMP.
with-disposal
] with-scope ; inline
-TUPLE: secure addrspec ;
+TUPLE: secure { addrspec read-only } ;
C: <secure> secure
[ "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 <inet> resolve-host length 1 >= ] unit-test
+[ t t ] [
+ "localhost" 80 <inet> 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 <inet> resolve-host
+ [ length 1 >= ]
+ [ [ [ ipv4? ] [ ipv6? ] bi or ] all? ] bi
+] unit-test
! Smoke-test UDP
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test
"hi\n" write flush readln readln
] with-client
] unit-test
+
+! Binding to all interfaces should work
+[ ] [ f 0 <inet4> <datagram> dispose ] unit-test
-! 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
<< {
! Addressing
<PRIVATE
+UNION: ?string string POSTPONE: f ;
+
+GENERIC: protocol ( addrspec -- n )
+
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-size ( addrspec -- n )
GENERIC: inet-pton ( str addrspec -- data )
+GENERIC# with-port 1 ( addrspec port -- addrspec )
+
: make-sockaddr/size ( addrspec -- sockaddr size )
[ make-sockaddr ] [ sockaddr-size ] bi ;
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
+M: f parse-sockaddr nip ;
+
HOOK: sockaddr-of-family os ( alien af -- sockaddr )
HOOK: addrspec-of-family os ( af -- addrspec )
PRIVATE>
-TUPLE: abstract-inet host port ;
-
-M: abstract-inet present
- [ host>> ":" ] [ port>> number>string ] bi 3append ;
-
-TUPLE: local path ;
+TUPLE: local { path read-only } ;
: <local> ( path -- addrspec )
normalize-path local boa ;
M: local present path>> "Unix domain socket: " prepend ;
-TUPLE: inet4 < abstract-inet ;
+M: local protocol drop 0 ;
-C: <inet4> inet4
+SLOT: port
+
+TUPLE: ipv4 { host ?string read-only } ;
-M: inet4 inet-ntop ( data addrspec -- str )
+C: <ipv4> ipv4
+
+M: ipv4 inet-ntop ( data addrspec -- str )
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
-ERROR: malformed-inet4 sequence ;
-ERROR: bad-inet4-component string ;
+<PRIVATE
-: parse-inet4 ( string -- seq )
- "." split dup length 4 = [
- malformed-inet4
- ] unless
- [
- string>number
- [ "Dotted component not a number" throw ] unless*
- ] B{ } map-as ;
+ERROR: malformed-ipv4 sequence ;
-ERROR: invalid-inet4 string reason ;
+ERROR: bad-ipv4-component string ;
-M: invalid-inet4 summary drop "Invalid IPv4 address" ;
+: parse-ipv4 ( string -- seq )
+ "." split dup length 4 = [ malformed-ipv4 ] unless
+ [ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as ;
-M: inet4 inet-pton ( str addrspec -- data )
- drop
- [ parse-inet4 ] [ invalid-inet4 ] recover ;
+ERROR: invalid-ipv4 string reason ;
-M: inet4 address-size drop 4 ;
+M: invalid-ipv4 summary drop "Invalid IPv4 address" ;
-M: inet4 protocol-family drop PF_INET ;
+PRIVATE>
-M: inet4 sockaddr-size drop sockaddr-in heap-size ;
+M: ipv4 inet-pton ( str addrspec -- data )
+ drop [ parse-ipv4 ] [ invalid-ipv4 ] recover ;
-M: inet4 empty-sockaddr drop sockaddr-in <struct> ;
+M: ipv4 address-size drop 4 ;
-M: inet4 make-sockaddr ( inet -- sockaddr )
+M: ipv4 protocol-family drop PF_INET ;
+
+M: ipv4 sockaddr-size drop sockaddr-in heap-size ;
+
+M: ipv4 empty-sockaddr drop sockaddr-in <struct> ;
+
+M: ipv4 make-sockaddr ( inet -- sockaddr )
sockaddr-in <struct>
AF_INET >>family
- swap [ port>> htons >>port ]
- [ host>> "0.0.0.0" or ]
- [ inet-pton *uint >>addr ] tri ;
+ swap
+ [ port>> htons >>port ]
+ [ host>> "0.0.0.0" or ]
+ [ inet-pton *uint >>addr ] tri ;
+
+M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
+ [ addr>> <uint> ] dip inet-ntop <ipv4> ;
+
+TUPLE: inet4 < ipv4 { port integer read-only } ;
+
+C: <inet4> inet4
+
+M: ipv4 with-port [ host>> ] dip <inet4> ;
M: inet4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
- [ [ addr>> <uint> ] dip inet-ntop ]
- [ drop port>> ntohs ] 2bi <inet4> ;
+ [ call-next-method ] [ drop port>> ntohs ] 2bi with-port ;
-TUPLE: inet6 < abstract-inet ;
+M: inet4 present
+ [ host>> ] [ port>> number>string ] bi ":" glue ;
-C: <inet6> inet6
+M: inet4 protocol drop 0 ;
-M: inet6 inet-ntop ( data addrspec -- str )
- drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
+TUPLE: ipv6 { host ?string read-only } ;
-ERROR: invalid-inet6 string reason ;
+C: <ipv6> ipv6
-M: invalid-inet6 summary drop "Invalid IPv6 address" ;
+M: ipv6 inet-ntop ( data addrspec -- str )
+ drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
+
+ERROR: invalid-ipv6 string reason ;
<PRIVATE
ERROR: bad-ipv4-embedded-prefix obj ;
+ERROR: more-than-8-components ;
+
: parse-ipv6-component ( seq -- seq' )
[ dup hex> [ 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
<byte-array> 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 <struct> ;
+M: ipv6 empty-sockaddr drop sockaddr-in6 <struct> ;
-M: inet6 make-sockaddr ( inet -- sockaddr )
+M: ipv6 make-sockaddr ( inet -- sockaddr )
sockaddr-in6 <struct>
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 <ipv6> ;
+
+TUPLE: inet6 < ipv6 { port integer read-only } ;
+
+C: <inet6> inet6
+
+M: ipv6 with-port [ host>> ] dip <inet6> ;
M: inet6 parse-sockaddr
- [ [ addr>> ] dip inet-ntop ]
- [ drop port>> ntohs ] 2bi <inet6> ;
+ [ 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 ;
<PRIVATE
HOOK: (datagram) io-backend ( addr -- datagram )
-: check-datagram-port ( port -- port )
- dup check-disposed
- dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
+TUPLE: raw-port < port addr ;
+
+HOOK: (raw) io-backend ( addr -- raw )
HOOK: (receive) io-backend ( datagram -- packet addrspec )
-: check-datagram-send ( packet addrspec port -- packet addrspec port )
- check-datagram-port
+ERROR: invalid-port object ;
+
+: check-port ( packet addrspec port -- packet addrspec port )
2dup addr>> [ 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 )
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 <struct>
PF_UNSPEC >>family
IPPROTO_TCP >>protocol ;
-: fill-in-ports ( addrspecs port -- addrspecs )
- '[ _ >>port ] map ;
-
PRIVATE>
: <client> ( remote encoding -- stream local )
>>addr
] with-destructors ;
+: <raw> ( addrspec -- datagram )
+ [
+ [ (raw) |dispose ] keep
+ [ drop raw-port <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 <inet6> binary <server> 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> inet
+M: string resolve-host
+ f prepare-addrinfo f <void*>
+ [ 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 <void*>
- [ 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: inet4 resolve-host 1array ;
+
+M: inet6 resolve-host 1array ;
+
+M: local resolve-host 1array ;
-M: f resolve-host drop { } ;
+M: f resolve-host
+ drop resolve-localhost ;
-M: object resolve-host 1array ;
+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 <byte-array> dup dup length gethostname
{
{ [ os unix? ] [ "io.sockets.unix" require ] }
- { [ os winnt? ] [ "io.sockets.windows.nt" require ] }
+ { [ os windows? ] [ "io.sockets.windows" require ] }
} cond
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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" } } ;
+
! 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 <fd> init-fd |dispose ;
+: socket-fd ( domain type protocol -- fd )
+ socket dup io-error <fd> init-fd |dispose ;
: set-socket-option ( fd level opt -- )
[ handle-fd ] 2dip 1 <int> dup byte-length setsockopt io-error ;
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 ;
] 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
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 ;
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
M: local parse-sockaddr
drop
path>> utf8 alien>string <local> ;
+
+os linux? [ "io.sockets.unix.linux" require ] when
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-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 )
- <int> 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 <c-object>
- 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
-
-: <ConnectEx-args> ( 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 <ConnectEx-args>
- 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
-
-: <AcceptEx-args> ( 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 <void*> 0 <int> f <void*> [ 0 <int> 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 )
- [
- <AcceptEx-args>
- {
- [ call-AcceptEx ]
- [ wait-for-socket drop ]
- [ sAcceptSocket>> <win32-socket> ]
- [ 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
-
-: <WSARecvFrom-args> ( 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 )
- [
- <WSARecvFrom-args>
- [ 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
-
-: <WSASendTo-args> ( 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 <uint> >>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 -- )
- [
- <WSASendTo-args>
- [ call-WSASendTo ]
- [ wait-for-socket drop ]
- bi
- ] with-destructors ;
! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors io.sockets io.sockets.private\r
-io.backend.windows io.backend windows.winsock system destructors\r
-alien.c-types classes.struct combinators ;\r
+USING: accessors alien alien.c-types alien.data classes.struct\r
+combinators destructors io.backend io.files.windows io.ports\r
+io.sockets io.sockets.icmp io.sockets.private kernel libc math\r
+sequences system windows.handles windows.kernel32 windows.types\r
+windows.winsock ;\r
FROM: namespaces => get ;\r
IN: io.sockets.windows\r
\r
\r
M: windows addrspec-of-family ( af -- addrspec )\r
{\r
- { AF_INET [ T{ inet4 } ] }\r
- { AF_INET6 [ T{ inet6 } ] }\r
+ { AF_INET [ T{ ipv4 } ] }\r
+ { AF_INET6 [ T{ ipv6 } ] }\r
[ drop f ]\r
} case ;\r
\r
: <win32-socket> ( handle -- win32-socket )\r
win32-socket new-win32-handle ;\r
\r
-M: win32-socket dispose ( stream -- )\r
- handle>> closesocket drop ;\r
+M: win32-socket dispose* ( stream -- )\r
+ handle>> closesocket socket-error* ;\r
\r
: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
[ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ;\r
\r
: opened-socket ( handle -- win32-socket )\r
- <win32-socket> |dispose dup add-completion ;\r
+ <win32-socket> |dispose add-completion ;\r
\r
: open-socket ( addrspec type -- win32-socket )\r
- [ protocol-family ] dip\r
- 0 f 0 WSASocket-flags WSASocket\r
+ [ drop protocol-family ] [ swap protocol ] 2bi\r
+ f 0 WSASocket-flags WSASocket\r
dup socket-error\r
opened-socket ;\r
\r
\r
M: windows (datagram) ( addrspec -- handle )\r
[ SOCK_DGRAM server-socket ] with-destructors ;\r
+\r
+M: windows (raw) ( addrspec -- handle )\r
+ [ SOCK_RAW server-socket ] with-destructors ;\r
+\r
+: malloc-int ( n -- alien )\r
+ <int> malloc-byte-array ; inline\r
+\r
+M: winnt WSASocket-flags ( -- DWORD )\r
+ WSA_FLAG_OVERLAPPED ;\r
+\r
+: get-ConnectEx-ptr ( socket -- void* )\r
+ SIO_GET_EXTENSION_FUNCTION_POINTER\r
+ WSAID_CONNECTEX\r
+ GUID heap-size\r
+ { void* }\r
+ [\r
+ void* heap-size\r
+ DWORD <c-object>\r
+ f\r
+ f\r
+ WSAIoctl SOCKET_ERROR = [\r
+ maybe-winsock-exception throw\r
+ ] when\r
+ ] with-out-parameters ;\r
+\r
+TUPLE: ConnectEx-args port\r
+ s name namelen lpSendBuffer dwSendDataLength\r
+ lpdwBytesSent lpOverlapped ptr ;\r
+\r
+: wait-for-socket ( args -- n )\r
+ [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline\r
+\r
+: <ConnectEx-args> ( sockaddr size -- ConnectEx )\r
+ ConnectEx-args new\r
+ swap >>namelen\r
+ swap >>name\r
+ f >>lpSendBuffer\r
+ 0 >>dwSendDataLength\r
+ f >>lpdwBytesSent\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-ConnectEx ( ConnectEx -- )\r
+ {\r
+ [ s>> ]\r
+ [ name>> ]\r
+ [ namelen>> ]\r
+ [ lpSendBuffer>> ]\r
+ [ dwSendDataLength>> ]\r
+ [ lpdwBytesSent>> ]\r
+ [ lpOverlapped>> ]\r
+ [ ptr>> ]\r
+ } cleave\r
+ int\r
+ { SOCKET void* int PVOID DWORD LPDWORD void* }\r
+ stdcall alien-indirect drop\r
+ winsock-error ; inline\r
+\r
+M: object establish-connection ( client-out remote -- )\r
+ make-sockaddr/size <ConnectEx-args>\r
+ swap >>port\r
+ dup port>> handle>> handle>> >>s\r
+ dup s>> get-ConnectEx-ptr >>ptr\r
+ dup call-ConnectEx\r
+ wait-for-socket drop ;\r
+\r
+TUPLE: AcceptEx-args port\r
+ sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength\r
+ dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;\r
+\r
+: init-accept-buffer ( addr AcceptEx -- )\r
+ swap sockaddr-size 16 +\r
+ [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi\r
+ dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer\r
+ drop ; inline\r
+\r
+: <AcceptEx-args> ( server addr -- AcceptEx )\r
+ AcceptEx-args new\r
+ 2dup init-accept-buffer\r
+ swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket\r
+ over handle>> handle>> >>sListenSocket\r
+ swap >>port\r
+ 0 >>dwReceiveDataLength\r
+ f >>lpdwBytesReceived\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+! AcceptEx return value is useless\r
+: call-AcceptEx ( AcceptEx -- )\r
+ {\r
+ [ sListenSocket>> ]\r
+ [ sAcceptSocket>> ]\r
+ [ lpOutputBuffer>> ]\r
+ [ dwReceiveDataLength>> ]\r
+ [ dwLocalAddressLength>> ]\r
+ [ dwRemoteAddressLength>> ]\r
+ [ lpdwBytesReceived>> ]\r
+ [ lpOverlapped>> ]\r
+ } cleave AcceptEx drop winsock-error ; inline\r
+\r
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )\r
+ f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;\r
+\r
+: extract-remote-address ( AcceptEx -- sockaddr )\r
+ [\r
+ {\r
+ [ lpOutputBuffer>> ]\r
+ [ dwReceiveDataLength>> ]\r
+ [ dwLocalAddressLength>> ]\r
+ [ dwRemoteAddressLength>> ]\r
+ } cleave\r
+ (extract-remote-address)\r
+ ] [ port>> addr>> protocol-family ] bi\r
+ sockaddr-of-family ; inline\r
+\r
+M: object (accept) ( server addr -- handle sockaddr )\r
+ [\r
+ <AcceptEx-args>\r
+ {\r
+ [ call-AcceptEx ]\r
+ [ wait-for-socket drop ]\r
+ [ sAcceptSocket>> <win32-socket> ]\r
+ [ extract-remote-address ]\r
+ } cleave\r
+ ] with-destructors ;\r
+\r
+TUPLE: WSARecvFrom-args port\r
+ s lpBuffers dwBufferCount lpNumberOfBytesRecvd\r
+ lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;\r
+\r
+: make-receive-buffer ( -- WSABUF )\r
+ WSABUF malloc-struct &free\r
+ default-buffer-size get\r
+ [ >>len ] [ malloc &free >>buf ] bi ; inline\r
+\r
+: <WSARecvFrom-args> ( datagram -- WSARecvFrom )\r
+ WSARecvFrom-args new\r
+ swap >>port\r
+ dup port>> handle>> handle>> >>s\r
+ dup port>> addr>> sockaddr-size\r
+ [ malloc &free >>lpFrom ]\r
+ [ malloc-int &free >>lpFromLen ] bi\r
+ make-receive-buffer >>lpBuffers\r
+ 1 >>dwBufferCount\r
+ 0 malloc-int &free >>lpFlags\r
+ 0 malloc-int &free >>lpNumberOfBytesRecvd\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-WSARecvFrom ( WSARecvFrom -- )\r
+ {\r
+ [ s>> ]\r
+ [ lpBuffers>> ]\r
+ [ dwBufferCount>> ]\r
+ [ lpNumberOfBytesRecvd>> ]\r
+ [ lpFlags>> ]\r
+ [ lpFrom>> ]\r
+ [ lpFromLen>> ]\r
+ [ lpOverlapped>> ]\r
+ [ lpCompletionRoutine>> ]\r
+ } cleave WSARecvFrom socket-error* ; inline\r
+\r
+: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )\r
+ [ lpBuffers>> buf>> swap memory>byte-array ]\r
+ [\r
+ [ port>> addr>> empty-sockaddr dup ]\r
+ [ lpFrom>> ]\r
+ [ lpFromLen>> *int ]\r
+ tri memcpy\r
+ ] bi ; inline\r
+\r
+M: winnt (receive) ( datagram -- packet addrspec )\r
+ [\r
+ <WSARecvFrom-args>\r
+ [ call-WSARecvFrom ]\r
+ [ wait-for-socket ]\r
+ [ parse-WSARecvFrom ]\r
+ tri\r
+ ] with-destructors ;\r
+\r
+TUPLE: WSASendTo-args port\r
+ s lpBuffers dwBufferCount lpNumberOfBytesSent\r
+ dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;\r
+\r
+: make-send-buffer ( packet -- WSABUF )\r
+ [ WSABUF malloc-struct &free ] dip\r
+ [ malloc-byte-array &free >>buf ]\r
+ [ length >>len ] bi ; inline\r
+\r
+: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )\r
+ WSASendTo-args new\r
+ swap >>port\r
+ dup port>> handle>> handle>> >>s\r
+ swap make-sockaddr/size\r
+ [ malloc-byte-array &free ] dip\r
+ [ >>lpTo ] [ >>iToLen ] bi*\r
+ swap make-send-buffer >>lpBuffers\r
+ 1 >>dwBufferCount\r
+ 0 >>dwFlags\r
+ 0 <uint> >>lpNumberOfBytesSent\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-WSASendTo ( WSASendTo -- )\r
+ {\r
+ [ s>> ]\r
+ [ lpBuffers>> ]\r
+ [ dwBufferCount>> ]\r
+ [ lpNumberOfBytesSent>> ]\r
+ [ dwFlags>> ]\r
+ [ lpTo>> ]\r
+ [ iToLen>> ]\r
+ [ lpOverlapped>> ]\r
+ [ lpCompletionRoutine>> ]\r
+ } cleave WSASendTo socket-error* ; inline\r
+\r
+M: winnt (send) ( packet addrspec datagram -- )\r
+ [\r
+ <WSASendTo-args>\r
+ [ call-WSASendTo ]\r
+ [ wait-for-socket drop ]\r
+ bi\r
+ ] with-destructors ;\r
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
+
+[ t ]
+[
+ "abc" <string-reader> 3 limit-stream unlimit-stream
+ "abc" <string-reader> =
+] unit-test
+
+[ t ]
+[
+ "abc" <string-reader> 3 limit-stream unlimit-stream
+ "abc" <string-reader> =
+] unit-test
+
+[ t ]
+[
+ [
+ "resource:license.txt" utf8 <file-reader> &dispose
+ 3 limit-stream unlimit-stream
+ "resource:license.txt" utf8 <file-reader> &dispose
+ [ decoder? ] both?
+ ] with-destructors
+] unit-test
+
+[ "asdf" ] [
+ "asdf" <string-reader> 2 <limited-stream> [
+ unlimited-input contents
+ ] with-input-stream
+] unit-test
+
+[ "asdf" ] [
+ "asdf" <string-reader> 2 <limited-stream> [
+ [ contents ] with-unlimited-input
+ ] with-input-stream
+] unit-test
+
+[ "gh" ] [
+ "asdfgh" <string-reader> 4 <limited-stream> [
+ 2 [
+ [ contents drop ] with-unlimited-input
+ ] with-limited-input
+ [ contents ] with-unlimited-input
+ ] with-input-stream
+] unit-test
: 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 ;
<PRIVATE
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
! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel calendar timers io io.encodings accessors\r
-namespaces fry io.streams.null ;\r
+USING: accessors fry io io.encodings io.streams.null kernel\r
+namespaces timers ;\r
IN: io.timeouts\r
\r
GENERIC: timeout ( obj -- dt/f )\r
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 ) ;
$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\" <sqlite-db> [ listener ] with-db"
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:"
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"
{ $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 } ;
{ $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 } ;
[ { } ] [ { 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
! 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
<PRIVATE
[ -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 ;
+
+<PRIVATE
: (selections) ( seq n -- selections )
- dupd [ dup 1 > ] [
- 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 ;
+
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 ( -- )
! 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 )
{ +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
-
- [ 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
+ [ 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 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
[ +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
-
--- /dev/null
+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
} 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 }
{ +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
-! 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
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 ) ;
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 -- )
-! 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 ;
-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 } ]
{ 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
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" }
! 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 )
"file1" swap at filename>> "up.txt" =
] unit-test
+SYMBOL: mime-test-server
+
+: with-test-server ( quot -- )
+ [
+ <http-server>
+ f >>secure
+ 0 >>insecure
+ ] dip with-threaded-server ; inline
+
+: test-server-port ( -- n )
+ mime-test-server get insecure>> ;
+
+: a-stream ( n -- stream )
+ CHAR: a <string> <string-reader> ;
+
+[ ] [
+ [
+ ] with-test-server
+] unit-test
: 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 )
dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
: parse-multipart ( separator -- mime-parts )
- <multipart> parse-beginning fill-bytes parse-multipart-loop
- mime-parts>> ;
+ <multipart> parse-beginning fill-bytes
+ parse-multipart-loop mime-parts>> ;
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 ) ;
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 ) ;
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
drop \r
] [ \r
[\r
- "FROM: locals => [let :> ; FROM: sequences => nth ; [let " %\r
+ "FROM: locals => [let :> ; FROM: sequences => nth ; FROM: kernel => nip over ; [let " %\r
[\r
over ebnf-var? [\r
" " % # " over nth :> " %\r
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ;
-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> windows-rng
+TUPLE: windows-crypto-context < win32-handle provider type ;
-TUPLE: windows-crypto-context handle ;
-C: <windows-crypto-context> 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 <windows-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 <byte-array>
- [ CryptGenRandom win32-error=0/f ] keep
- ] with-destructors ;
+: <windows-crypto-context> ( 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 [ ] [ <byte-array> ] bi
+ [ CryptGenRandom win32-error=0/f ] keep ;
-: try-crypto-providers ( seq -- windows-rng )
- [ first2 <windows-rng> ] attempt-all
- dup windows-rng? [ no-windows-crypto-provider ] unless ;
+: try-crypto-providers ( seq -- windows-crypto-context )
+ [ first2 <windows-crypto-context> ] 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
{ 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 }
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." } ;
[ { "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
-! 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 ;
+: <hybrid> ( obj -- hybrid )
+ hybrid new
+ swap >>obj ; inline
+
+: <hybrid-insensitive> ( 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 [ <hybrid> ] map ] define-sorting >>
+<< "humani" [ find-numbers [ <hybrid-insensitive> ] map ] define-sorting >>
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
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 ;
callbacks get [ dup "stack-cleanup" word-prop <callback> ] cache ;
: callback-bottom ( params -- )
- xt>> '[ _ callback-xt ] infer-quot-here ;
+ "( callback )" <uninterned-word> >>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 ;
-
-: wrap-callback-quot ( params -- quot )
- [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
- yield-hook get
- '[ _ _ do-callback ]
- >quotation ;
+: callback-parameter-quot ( params -- quot )
+ parameters>> [ c-type ] map
+ [ [ c-type-class ] map '[ _ declare ] ]
+ [ [ c-type-boxer-quot ] map spread>quot ]
+ bi append ;
+
+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" <array> ] [ return>> void? { } { "x" } ? ] bi
+ <effect> ;
+
+: 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 )" <uninterned-word> >>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, ;
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 ;
\ <callback> { integer word } { alien } define-primitive
\ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive \ <displaced-alien> make-flushable
\ <string> { integer integer } { string } define-primitive \ <string> make-flushable
-\ <tuple> { tuple-layout } { tuple } define-primitive \ <tuple> make-flushable
+\ <tuple> { array } { tuple } define-primitive \ <tuple> make-flushable
\ <wrapper> { object } { wrapper } define-primitive \ <wrapper> 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
\ 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
\ 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
\ 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
! 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
meta-d length "x" <array>
terminated? get <terminated-effect> ;
+: check-effect ( required-effect -- )
+ [ current-effect ] dip 2dup effect<= [ 2drop ] [ effect-error ] if ;
+
: init-inference ( -- )
terminated? off
V{ } clone \ meta-d set
[
[ 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
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 ;
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 -- )
PRIVATE>
: >suffix-array ( seq -- array )
+ members
[ suffixes ] map concat natural-sort ;
SYNTAX: SA{ \ } [ >suffix-array ] parse-literal ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! 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" <c-object>
- "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 ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: math.order strings system-info.backend
-system-info.windows system-info.windows.nt
-tools.test ;
-IN: system-info.windows.nt.tests
-
-[ t ] [ cpus 0 1024 between? ] unit-test
-[ t ] [ username string? ] unit-test
+++ /dev/null
-! 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 <struct>
- 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 +
- [ <byte-array> dup ] keep <uint>
- GetComputerName win32-error=0/f alien>native-string ;
-
-: username ( -- string )
- UNLEN 1 +
- [ <byte-array> dup ] keep <uint>
- GetUserName win32-error=0/f alien>native-string ;
--- /dev/null
+USING: math.order strings system-info.backend
+system-info.windows tools.test ;
+IN: system-info.windows.tests
+
+[ t ] [ cpus 0 1024 between? ] unit-test
+[ t ] [ username string? ] unit-test
! 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
: 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 <struct>
+ 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 +
+ [ <byte-array> dup ] keep <uint>
+ GetComputerName win32-error=0/f alien>native-string ;
+
+: username ( -- string )
+ UNLEN 1 +
+ [ <byte-array> dup ] keep <uint>
+ GetUserName win32-error=0/f alien>native-string ;
-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
! 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.
+
+[ { } ] [
+ <promise> [
+ '[
+ _ [
+ callstack swap fulfill stop
+ ] start-context-and-delete
+ ] in-thread
+ ] [ ?promise callstack>array ] bi
+] unit-test
}\r
} ;\r
\r
-ARTICLE: "timers" "Alarms"\r
-"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\r
+ARTICLE: "timers" "Timers"\r
+"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\r
"The timer class:"\r
{ $subsections timer }\r
"Create a timer before starting it:"\r
USING: help.markup help.syntax strings generic vectors assocs
-math ;
+math make ;
IN: tools.completion
ARTICLE: "tools.completion" "Fuzzy 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%." } ;
! 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 ? )
: 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 ;
: chars-matching ( str -- seq )
name-map keys dup zip completions ;
+
{ $link heap-size }
{ $link <c-object> }
{ $link <c-array> }
- { $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." } ;
<http-server>
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 ;
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"
\r
ARTICLE: "tools.disassembler" "Disassembling words"\r
"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."\r
+$nl\r
+"See also " { $vocab-link "compiler.tree.debugger" } " and " { $vocab-link "compiler.cfg.debugger" } "."\r
+$nl\r
{ $subsections disassemble } ;\r
\r
ABOUT: "tools.disassembler"\r
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
: 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* ;
"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 } "." } ;
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
[ "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 <empty-tuple-array> length ] unit-test
+[ T{ empty-tuple } ] [ 100 <empty-tuple-array> first ] unit-test
+[ ] [ T{ empty-tuple } 100 <empty-tuple-array> 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
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
: 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? ;
: quaternary= ( str1 str2 -- ? )\r
0 insensitive= ;\r
\r
-<PRIVATE\r
: w/collation-key ( str -- {str,key} )\r
[ collation-key ] keep 2array ;\r
-PRIVATE>\r
\r
: sort-strings ( strings -- sorted )\r
[ w/collation-key ] map natural-sort values ;\r
CONSTANT: SOCK_STREAM 1
CONSTANT: SOCK_DGRAM 2
+CONSTANT: SOCK_RAW 3
CONSTANT: AF_UNSPEC 0
CONSTANT: AF_UNIX 1
{ 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 ) ;
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 ) ;
CONSTANT: SOCK_STREAM 1
CONSTANT: SOCK_DGRAM 2
+CONSTANT: SOCK_RAW 3
CONSTANT: AF_UNSPEC 0
CONSTANT: AF_UNIX 1
-! 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 <secure> ;
! (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
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
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
-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
-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
: 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
${
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ;
+
+: <win32-handle> ( handle -- win32-handle )
+ win32-handle new-win32-handle ;
+
+M: win32-handle dispose* ( handle -- )
+ handle>> CloseHandle win32-error=0/f ;
--- /dev/null
+windows
\ No newline at end of file
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test windows.privileges ;
+IN: windows.privileges.tests
--- /dev/null
+! 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
+
+! Security tokens
+! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
+
+: (open-process-token) ( handle -- handle )
+ flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY }
+ { PHANDLE }
+ [ OpenProcessToken win32-error=0/f ]
+ with-out-parameters ;
+
+: open-process-token ( -- handle )
+ #! remember to CloseHandle
+ GetCurrentProcess (open-process-token) ;
+
+: with-process-token ( quot -- )
+ #! quot: ( token-handle -- token-handle )
+ [ open-process-token ] dip
+ [ keep ] curry
+ [ CloseHandle drop ] [ ] cleanup ; inline
+
+: lookup-privilege ( string -- luid )
+ [ f ] dip LUID <struct>
+ [ LookupPrivilegeValue win32-error=0/f ] keep ;
+
+:: make-token-privileges ( name enabled? -- obj )
+ TOKEN_PRIVILEGES <struct>
+ 1 >>PrivilegeCount
+ LUID_AND_ATTRIBUTES malloc-struct &free
+ enabled? [ SE_PRIVILEGE_ENABLED >>Attributes ] when
+ name lookup-privilege >>Luid
+ >>Privileges ;
+
+: set-privilege ( name ? -- )
+ '[
+ 0
+ _ _ make-token-privileges
+ dup byte-length
+ f
+ 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
! 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 )
! 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
FROM: alien.c-types => short ;
IN: windows.winsock
-TYPEDEF: void* SOCKET
+TYPEDEF: int* SOCKET
: <wsadata> ( -- byte-array )
HEX: 190 <byte-array> ;
: INVALID_SOCKET ( -- n ) -1 <alien> ; inline
-CONSTANT: SOCKET_ERROR -1
+: SOCKET_ERROR ( -- n ) -1 <alien> ; inline
CONSTANT: SD_RECV 0
CONSTANT: SD_SEND 1
{ length short }
{ addr-list void* } ;
+STRUCT: protoent
+ { name c-string }
+ { aliases void* }
+ { proto short } ;
+
STRUCT: addrinfo
{ flags int }
{ family int }
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
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 (
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 -- )
dup WSA_IO_PENDING = [
drop
] [
- (winsock-error-string) throw
+ (maybe-winsock-exception) throw
] if
] when ;
! 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" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
[ "blah" ] [ "<foo attr='blah'/>" string>xml "foo" deep-tag-named "attr" attr ] unit-test
[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test
+
+[ { "blah" } ] [ "<foo><bar attr='blah'/></foo>" string>xml "blah" "attr" tags-with-attr [ "attr" attr ] map ] unit-test
+[ { "blah" } ] [ "bar" { { "attr" "blah" } } f <tag> 1array "blah" "attr" tags-with-attr [ "attr" attr ] map ] unit-test
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 ;
! 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
{ "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
{ "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" (( -- )) }
{ "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 -- ? )) }
ARTICLE: "class-linearization" "Class linearization"\r
"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:"\r
{ $list\r
- "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."\r
+ "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."\r
{ "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." }\r
}\r
"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:"\r
[ 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
[ 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
[ 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
[ 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 } ;
: <anonymous-intersection> ( 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> anonymous-complement
+M: anonymous-complement rank-class drop 3 ;
+
DEFER: (class<=)
DEFER: (class-not)
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 -- ? )
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 ;
<PRIVATE
: 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? ;
{ [ 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<= ] }
participants>> swap suffix <anonymous-intersection> ;
: (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 <anonymous-intersection> ]
- } 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 <anonymous-intersection> ]
+ } cond
+ ] [ 2drop null ] if
+ ] }
+ } case ;
: anonymous-union-or ( first second -- class )
members>> swap suffix <anonymous-union> ;
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 )
{
: 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 ;
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 ] [ 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
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? ;
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 ;
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? [
! 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? ;
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
[ 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? ;
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
[ 10 \ . compile-execute(-test-4 ] [ wrong-values? ] must-fail-with
-! Compiled
+! Cond
: cond-test-1 ( obj -- str )
{
{ [ dup 2 mod 0 = ] [ drop "even" ] }
\ 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 )
{
\ 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 )
{
\ 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 ( -- )
{
\ 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
-
-[ "really early" ] [
- 2 {
- [ drop "really early" ]
- { [ dup 2 mod 1 = ] [ drop "odd" ] }
- { [ dup 2 mod 0 = ] [ drop "even" ] }
- } cond
-] unit-test
+ } 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
+[ "early" ] [ 2 cond-test-5 ] unit-test
+[ "early" ] [ 2 \ cond-test-5 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-test-6 ( a -- b )
+ {
+ [ drop "really early" ]
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond ;
-[ { } cond ] [ class \ no-cond = ] must-fail-with
+[ "really early" ] [ 2 cond-test-6 ] unit-test
+[ "really early" ] [ 2 \ cond-test-6 def>> call ] unit-test
-! Compiled
+! Case
: case-test-1 ( obj -- obj' )
{
{ 1 [ "one" ] }
\ 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' )
{
\ 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' )
\ 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
{
{ case-const-1 [ "uno" ] }
{ case-const-2 [ "dos" ] }
- { 3 [ "tres" ] }
- { 4 [ "cuatro" ] }
- { 5 [ "cinco" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
[ drop "demasiado" ]
} case ;
[ "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 ;
[ "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
{ \ / [ "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
PRIVATE>
: case>quot ( default assoc -- quot )
- dup keys {
+ <reversed> dup keys {
{ [ dup empty? ] [ 2drop ] }
{ [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] }
{ [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
{ $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"
}
-! 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 ;
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 -- )
[
+++ /dev/null
-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> for-arguments-sake
-
-M: for-arguments-sake empty-method-test drop "Hi" ;
-
-TUPLE: another-one ;
-C: <another-one> another-one
-
-[ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
-[ T{ another-one f } ] [ <another-one> 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 ;" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
-
-[ ] [ "IN: generic.tests.b USE: strings USE: generic.tests M: string move-method-generic ;" <string-reader> "move-method-test-2" parse-stream drop ] unit-test
-
-[ ] [ "IN: generic.tests.a" <string-reader> "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
--- /dev/null
+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
+
[ number ] [ fixnum number math-class-max ] unit-test
[ number ] [ number fixnum math-class-max ] unit-test
-
+[ t ] [ \ + math-generic? ] unit-test
+++ /dev/null
-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> rectangle
-
-TUPLE: parallelogram < abstract-rectangle skew ;
-
-C: <parallelogram> parallelogram
-
-TUPLE: circle < shape radius ;
-
-C: <circle> circle
-
-GENERIC: area ( shape -- n )
-
-M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
-
-M: circle area radius>> sq pi * ;
-
-[ 12 ] [ 4 3 <rectangle> area ] unit-test
-[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
-[ t ] [ 2 <circle> 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 <rectangle> perimiter ] unit-test
-[ 30.0 ] [ 10 4 3 <parallelogram> 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 <rectangle> big-mix-test ] unit-test
-[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
-[ "circle" ] [ 100 <circle> 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
#! 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 ;
+
: <tuple-dispatch-engine> ( methods -- engine )
- echelon-sort
+ convert-tuple-inheritance echelon-sort
[ dupd <echelon-dispatch-engine> ] assoc-map
\ tuple-dispatch-engine boa ;
--- /dev/null
+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> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area ( shape -- n )
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> 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 <rectangle> perimiter ] unit-test
+[ 30.0 ] [ 10 4 3 <parallelogram> 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> for-arguments-sake
+
+M: for-arguments-sake empty-method-test drop "Hi" ;
+
+TUPLE: another-one ;
+C: <another-one> another-one
+
+[ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
+[ T{ another-one f } ] [ <another-one> 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 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> 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 ;" <string-reader> "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 ;" <string-reader> "move-method-test-2" parse-stream drop ] unit-test
+
+[ ] [ "IN: generic.standard.tests.a" <string-reader> "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 } <reversed> \ foozul method-for-object M\ reversed foozul assert= ] unit-test
+[ ] [ { 1 2 3 } <reversed> \ 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
: 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
[ 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
[ 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 )
{
-! 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 ;
GENERIC: stream-tell ( stream -- n )
GENERIC: stream-seek ( n seek-type stream -- )
-<PRIVATE
-
-SLOT: i
-
-: (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 ;
-
-PRIVATE>
-
: stream-print ( str stream -- ) [ stream-write ] [ stream-nl ] bi ;
! Default streams
[ 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 ;
[ f ]
} cond ;
+PRIVATE>
+
: absolute-path? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
[ f ]
} cond nip ;
-PRIVATE>
+: append-relative-path ( path1 path2 -- path )
+ [ trim-tail-separators ]
+ [ trim-head-separators ] bi* "/" glue ;
: append-path ( path1 path2 -- path )
{
{ [ 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 )
[ 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 <byte-reader> stream-contents dup >array swap string? ] unit-test
+[ { BIN: 1111111000000111111 } t ] [ { BIN: 11110001 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
[ B{ 121 120 } 0 ] [
B{ 0 121 120 0 0 0 0 0 0 } binary
! 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
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 ;
{ $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 } "." }
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
{ $subsections "sequences-if" }
"For inner loops:"
{ $subsections "sequences-unsafe" }
-"Implemeting sequence combinators:"
+"Implementing sequence combinators:"
{ $subsections "sequences-combinator-implementation" } ;
ABOUT: "sequences"
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
-! 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
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 <inet4> ;
+ "127.0.0.1" port get <inet4> ;
: server-loop ( server -- )
dup accept drop [
] curry "Client handler" spawn drop server-loop ;
: simple-server ( -- )
- [
- "127.0.0.1" 0 <inet4> ascii <server>
- [ 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 ( -- )
[
: clients ( n -- )
dup pprint " clients: " write [
- <promise> port-promise set
+ <promise> server-promise set
dup <count-down> counter set
+ "127.0.0.1" 0 <inet4> ascii <server>
+ [ 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 ( -- )
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2010 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types classes.struct kernel memory
-system vm ;
-IN: benchmark.struct
-
-STRUCT: benchmark-data
- { time ulonglong }
- { data-room data-heap-room }
- { code-room mark-sweep-sizes } ;
-
-STRUCT: benchmark-data-pair
- { start benchmark-data }
- { stop benchmark-data } ;
-
-: <benchmark-data> ( -- benchmark-data )
- \ benchmark-data <struct>
- nano-count >>time
- code-room >>code-room
- data-room >>data-room ; inline
-
-: <benchmark-data-pair> ( start stop -- benchmark-data-pair )
- \ benchmark-data-pair <struct>
- swap >>stop
- swap >>start ; inline
-
-: with-benchmarking ( ... quot -- ... benchmark-data-pair )
- <benchmark-data>
- [ call ] dip
- <benchmark-data> <benchmark-data-pair> ; inline
-
--- /dev/null
+Chris Double
--- /dev/null
+! 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."
+} ;
+
+
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+: bitcoin-url ( -- url )
+ <url>
+ "http" >>protocol
+ "/" >>path
+ bitcoin-server >>host
+ bitcoin-port >>port ;
+
+:: payload ( method params -- data )
+ "text/plain" <post-data>
+ 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 <post-request>
+ 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 ;
+
--- /dev/null
+Client for getting information from a bitcoin server
--- /dev/null
+client
+bitcoin
DEFER: stream>assoc
+ERROR: unknown-bson-type type msg ;
+
<PRIVATE
DEFER: read-elements
{ T_Binary_Default [ read ] }
{ T_Binary_Bytes_Deprecated [ drop read-int32 read ] }
{ T_Binary_Custom [ read bytes>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 )
{ T_Code [ read-int32 read-sized-string ] }
{ T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc <mongo-scoped-code> ] }
{ T_NULL [ f ] }
+ [ "type unknown" unknown-bson-type ]
} case ; inline recursive
TYPED: (read-object) ( type: integer name: string -- )
TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline
TYPED: write-utf8-string ( string: string -- )
- output-stream get utf8 <encoder> stream-write ; inline
+ get-output utf8 encode-string ; inline
TYPED: write-cstring ( string: string -- )
write-utf8-string 0 write1 ; inline
! 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
! (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
--- /dev/null
+IN: cpu.arm.assembler.tests
+USING: cpu.arm.assembler math tools.test namespaces make
+sequences kernel quotations ;
+FROM: cpu.arm.assembler => B ;
+
+: test-opcode ( expect quot -- ) [ { } make first ] curry unit-test ;
+
+[ HEX: ea000000 ] [ 0 B ] test-opcode
+[ HEX: eb000000 ] [ 0 BL ] test-opcode
+! [ HEX: e12fff30 ] [ R0 BLX ] test-opcode
+
+[ HEX: e24cc004 ] [ IP IP 4 SUB ] test-opcode
+[ HEX: e24cb004 ] [ FP IP 4 SUB ] test-opcode
+[ HEX: e087e3ac ] [ LR R7 IP 7 <LSR> ADD ] test-opcode
+[ HEX: e08c0109 ] [ R0 IP R9 2 <LSL> ADD ] test-opcode
+[ HEX: 02850004 ] [ R0 R5 4 EQ ADD ] test-opcode
+[ HEX: 00000000 ] [ R0 R0 R0 EQ AND ] test-opcode
+
+[ HEX: e1a0c00c ] [ IP IP MOV ] test-opcode
+[ HEX: e1a0c00d ] [ IP SP MOV ] test-opcode
+[ HEX: e3a03003 ] [ R3 3 MOV ] test-opcode
+[ HEX: e1a00003 ] [ R0 R3 MOV ] test-opcode
+[ HEX: e1e01c80 ] [ R1 R0 25 <LSL> MVN ] test-opcode
+[ HEX: e1e00ca1 ] [ R0 R1 25 <LSR> MVN ] test-opcode
+[ HEX: 11a021ac ] [ R2 IP 3 <LSR> NE MOV ] test-opcode
+
+[ HEX: e3530007 ] [ R3 7 CMP ] test-opcode
+
+[ HEX: e008049a ] [ R8 SL R4 MUL ] test-opcode
+
+[ HEX: e5151004 ] [ R1 R5 4 <-> LDR ] test-opcode
+[ HEX: e41c2004 ] [ R2 IP 4 <-!> LDR ] test-opcode
+[ HEX: e50e2004 ] [ R2 LR 4 <-> STR ] test-opcode
+
+[ HEX: e7910002 ] [ R0 R1 R2 <+> LDR ] test-opcode
+[ HEX: e7910102 ] [ R0 R1 R2 2 <LSL> <+> LDR ] test-opcode
+
+[ HEX: e1d310bc ] [ R1 R3 12 <+> LDRH ] test-opcode
+[ HEX: e1d310fc ] [ R1 R3 12 <+> LDRSH ] test-opcode
+[ HEX: e1d310dc ] [ R1 R3 12 <+> LDRSB ] test-opcode
+[ HEX: e1c310bc ] [ R1 R3 12 <+> STRH ] test-opcode
+[ HEX: e19310b4 ] [ R1 R3 R4 <+> LDRH ] test-opcode
+[ HEX: e1f310fc ] [ R1 R3 12 <!+> LDRSH ] test-opcode
+[ HEX: e1b310d4 ] [ R1 R3 R4 <!+> LDRSB ] test-opcode
+[ HEX: e0c317bb ] [ R1 R3 123 <+!> STRH ] test-opcode
+[ HEX: e08310b4 ] [ R1 R3 R4 <+!> STRH ] test-opcode
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators kernel make math math.bitwise
+namespaces sequences words words.symbol parser ;
+IN: cpu.arm.assembler
+
+! Registers
+<<
+
+SYMBOL: registers
+
+V{ } registers set-global
+
+SYNTAX: REGISTER:
+ CREATE-WORD
+ [ define-symbol ]
+ [ registers get length "register" set-word-prop ]
+ [ registers get push ]
+ tri ;
+
+>>
+
+REGISTER: R0
+REGISTER: R1
+REGISTER: R2
+REGISTER: R3
+REGISTER: R4
+REGISTER: R5
+REGISTER: R6
+REGISTER: R7
+REGISTER: R8
+REGISTER: R9
+REGISTER: R10
+REGISTER: R11
+REGISTER: R12
+REGISTER: R13
+REGISTER: R14
+REGISTER: R15
+
+ALIAS: SL R10 ALIAS: FP R11 ALIAS: IP R12
+ALIAS: SP R13 ALIAS: LR R14 ALIAS: PC R15
+
+<PRIVATE
+
+PREDICATE: register < word register >boolean ;
+
+GENERIC: register ( register -- n )
+M: word register "register" word-prop ;
+M: f register drop 0 ;
+
+PRIVATE>
+
+! Condition codes
+SYMBOL: cond-code
+
+: >CC ( n -- )
+ cond-code set ;
+
+: CC> ( -- n )
+ #! Default value is BIN: 1110 AL (= always)
+ cond-code [ f ] change BIN: 1110 or ;
+
+: EQ ( -- ) BIN: 0000 >CC ;
+: NE ( -- ) BIN: 0001 >CC ;
+: CS ( -- ) BIN: 0010 >CC ;
+: CC ( -- ) BIN: 0011 >CC ;
+: LO ( -- ) BIN: 0100 >CC ;
+: PL ( -- ) BIN: 0101 >CC ;
+: VS ( -- ) BIN: 0110 >CC ;
+: VC ( -- ) BIN: 0111 >CC ;
+: HI ( -- ) BIN: 1000 >CC ;
+: LS ( -- ) BIN: 1001 >CC ;
+: GE ( -- ) BIN: 1010 >CC ;
+: LT ( -- ) BIN: 1011 >CC ;
+: GT ( -- ) BIN: 1100 >CC ;
+: LE ( -- ) BIN: 1101 >CC ;
+: AL ( -- ) BIN: 1110 >CC ;
+: NV ( -- ) BIN: 1111 >CC ;
+
+<PRIVATE
+
+: (insn) ( n -- ) CC> 28 shift bitor , ;
+
+: insn ( bitspec -- ) bitfield (insn) ; inline
+
+! Branching instructions
+GENERIC# (B) 1 ( target l -- )
+
+M: integer (B) { 24 { 1 25 } { 0 26 } { 1 27 } 0 } insn ;
+
+PRIVATE>
+
+: B ( target -- ) 0 (B) ;
+: BL ( target -- ) 1 (B) ;
+
+! Data processing instructions
+<PRIVATE
+
+SYMBOL: updates-cond-code
+
+PRIVATE>
+
+: S ( -- ) updates-cond-code on ;
+
+: S> ( -- ? ) updates-cond-code [ f ] change ;
+
+<PRIVATE
+
+: sinsn ( bitspec -- )
+ bitfield S> [ 20 2^ bitor ] when (insn) ; inline
+
+GENERIC# shift-imm/reg 2 ( shift-imm/Rs Rm shift -- n )
+
+M: integer shift-imm/reg ( shift-imm Rm shift -- n )
+ { { 0 4 } 5 { register 0 } 7 } bitfield ;
+
+M: register shift-imm/reg ( Rs Rm shift -- n )
+ {
+ { 1 4 }
+ { 0 7 }
+ 5
+ { register 8 }
+ { register 0 }
+ } bitfield ;
+
+PRIVATE>
+
+TUPLE: IMM immed rotate ;
+C: <IMM> IMM
+
+TUPLE: shifter Rm by shift ;
+C: <shifter> shifter
+
+<PRIVATE
+
+GENERIC: shifter-op ( shifter-op -- n )
+
+M: IMM shifter-op
+ [ immed>> ] [ rotate>> ] bi { { 1 25 } 8 0 } bitfield ;
+
+M: shifter shifter-op
+ [ by>> ] [ Rm>> ] [ shift>> ] tri shift-imm/reg ;
+
+PRIVATE>
+
+: <LSL> ( Rm shift-imm/Rs -- shifter-op ) BIN: 00 <shifter> ;
+: <LSR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 01 <shifter> ;
+: <ASR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 10 <shifter> ;
+: <ROR> ( Rm shift-imm/Rs -- shifter-op ) BIN: 11 <shifter> ;
+: <RRX> ( Rm -- shifter-op ) 0 <ROR> ;
+
+M: register shifter-op 0 <LSL> shifter-op ;
+M: integer shifter-op 0 <IMM> shifter-op ;
+
+<PRIVATE
+
+: addr1 ( Rd Rn shifter-op opcode -- )
+ {
+ 21 ! opcode
+ { shifter-op 0 }
+ { register 16 } ! Rn
+ { register 12 } ! Rd
+ } sinsn ;
+
+PRIVATE>
+
+: AND ( Rd Rn shifter-op -- ) BIN: 0000 addr1 ;
+: EOR ( Rd Rn shifter-op -- ) BIN: 0001 addr1 ;
+: SUB ( Rd Rn shifter-op -- ) BIN: 0010 addr1 ;
+: RSB ( Rd Rn shifter-op -- ) BIN: 0011 addr1 ;
+: ADD ( Rd Rn shifter-op -- ) BIN: 0100 addr1 ;
+: ADC ( Rd Rn shifter-op -- ) BIN: 0101 addr1 ;
+: SBC ( Rd Rn shifter-op -- ) BIN: 0110 addr1 ;
+: RSC ( Rd Rn shifter-op -- ) BIN: 0111 addr1 ;
+: ORR ( Rd Rn shifter-op -- ) BIN: 1100 addr1 ;
+: BIC ( Rd Rn shifter-op -- ) BIN: 1110 addr1 ;
+
+: MOV ( Rd shifter-op -- ) [ f ] dip BIN: 1101 addr1 ;
+: MVN ( Rd shifter-op -- ) [ f ] dip BIN: 1111 addr1 ;
+
+! These always update the condition code flags
+<PRIVATE
+
+: (CMP) ( Rn shifter-op opcode -- ) [ f ] 3dip S addr1 ;
+
+PRIVATE>
+
+: TST ( Rn shifter-op -- ) BIN: 1000 (CMP) ;
+: TEQ ( Rn shifter-op -- ) BIN: 1001 (CMP) ;
+: CMP ( Rn shifter-op -- ) BIN: 1010 (CMP) ;
+: CMN ( Rn shifter-op -- ) BIN: 1011 (CMP) ;
+
+! Multiply instructions
+<PRIVATE
+
+: (MLA) ( Rd Rm Rs Rn a -- )
+ {
+ 21
+ { register 12 }
+ { register 8 }
+ { register 0 }
+ { register 16 }
+ { 1 7 }
+ { 1 4 }
+ } sinsn ;
+
+: (S/UMLAL) ( RdLo RdHi Rm Rs s a -- )
+ {
+ { 1 23 }
+ 22
+ 21
+ { register 8 }
+ { register 0 }
+ { register 16 }
+ { register 12 }
+ { 1 7 }
+ { 1 4 }
+ } sinsn ;
+
+PRIVATE>
+
+: MUL ( Rd Rm Rs -- ) f 0 (MLA) ;
+: MLA ( Rd Rm Rs Rn -- ) 1 (MLA) ;
+
+: SMLAL ( RdLo RdHi Rm Rs -- ) 1 1 (S/UMLAL) ;
+: SMULL ( RdLo RdHi Rm Rs -- ) 1 0 (S/UMLAL) ;
+: UMLAL ( RdLo RdHi Rm Rs -- ) 0 1 (S/UMLAL) ;
+: UMULL ( RdLo RdHi Rm Rs -- ) 0 0 (S/UMLAL) ;
+
+! Miscellaneous arithmetic instructions
+: CLZ ( Rd Rm -- )
+ {
+ { 1 24 }
+ { 1 22 }
+ { 1 21 }
+ { BIN: 111 16 }
+ { BIN: 1111 8 }
+ { 1 4 }
+ { register 0 }
+ { register 12 }
+ } sinsn ;
+
+! Status register acess instructions
+
+! Load and store instructions
+<PRIVATE
+
+GENERIC: addressing-mode-2 ( addressing-mode -- n )
+
+TUPLE: addressing base p u w ;
+C: <addressing> addressing
+
+M: addressing addressing-mode-2
+ { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-2 ] } cleave
+ { 0 21 23 24 } bitfield ;
+
+M: integer addressing-mode-2 ;
+
+M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
+
+: addr2 ( Rd Rn addressing-mode b l -- )
+ {
+ { 1 26 }
+ 20
+ 22
+ { addressing-mode-2 0 }
+ { register 16 }
+ { register 12 }
+ } insn ;
+
+PRIVATE>
+
+! Offset
+: <+> ( base -- addressing ) 1 1 0 <addressing> ;
+: <-> ( base -- addressing ) 1 0 0 <addressing> ;
+
+! Pre-indexed
+: <!+> ( base -- addressing ) 1 1 1 <addressing> ;
+: <!-> ( base -- addressing ) 1 0 1 <addressing> ;
+
+! Post-indexed
+: <+!> ( base -- addressing ) 0 1 0 <addressing> ;
+: <-!> ( base -- addressing ) 0 0 0 <addressing> ;
+
+: LDR ( Rd Rn addressing-mode -- ) 0 1 addr2 ;
+: LDRB ( Rd Rn addressing-mode -- ) 1 1 addr2 ;
+: STR ( Rd Rn addressing-mode -- ) 0 0 addr2 ;
+: STRB ( Rd Rn addressing-mode -- ) 1 0 addr2 ;
+
+! We might have to simulate these instructions since older ARM
+! chips don't have them.
+SYMBOL: have-BX?
+SYMBOL: have-BLX?
+
+<PRIVATE
+
+GENERIC# (BX) 1 ( Rm l -- )
+
+M: register (BX) ( Rm l -- )
+ {
+ { 1 24 }
+ { 1 21 }
+ { BIN: 1111 16 }
+ { BIN: 1111 12 }
+ { BIN: 1111 8 }
+ 5
+ { 1 4 }
+ { register 0 }
+ } insn ;
+
+PRIVATE>
+
+: BX ( Rm -- ) have-BX? get [ 0 (BX) ] [ [ PC ] dip MOV ] if ;
+
+: BLX ( Rm -- ) have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
+
+! More load and store instructions
+<PRIVATE
+
+GENERIC: addressing-mode-3 ( addressing-mode -- n )
+
+: b>n/n ( b -- n n ) [ -4 shift ] [ HEX: f bitand ] bi ;
+
+M: addressing addressing-mode-3
+ { [ p>> ] [ u>> ] [ w>> ] [ base>> addressing-mode-3 ] } cleave
+ { 0 21 23 24 } bitfield ;
+
+M: integer addressing-mode-3
+ b>n/n {
+ ! { 1 24 }
+ { 1 22 }
+ { 1 7 }
+ { 1 4 }
+ 0
+ 8
+ } bitfield ;
+
+M: object addressing-mode-3
+ shifter-op {
+ ! { 1 24 }
+ { 1 7 }
+ { 1 4 }
+ 0
+ } bitfield ;
+
+: addr3 ( Rn Rd addressing-mode h l s -- )
+ {
+ 6
+ 20
+ 5
+ { addressing-mode-3 0 }
+ { register 16 }
+ { register 12 }
+ } insn ;
+
+PRIVATE>
+
+: LDRH ( Rn Rd addressing-mode -- ) 1 1 0 addr3 ;
+: LDRSB ( Rn Rd addressing-mode -- ) 0 1 1 addr3 ;
+: LDRSH ( Rn Rd addressing-mode -- ) 1 1 1 addr3 ;
+: STRH ( Rn Rd addressing-mode -- ) 1 0 0 addr3 ;
+
+! Load and store multiple instructions
+
+! Semaphore instructions
+
+! Exception-generating instructions
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: cpu.ppc.assembler tools.test arrays kernel namespaces
+make vocabs sequences byte-arrays.hex ;
+FROM: cpu.ppc.assembler => B ;
+IN: cpu.ppc.assembler.tests
+
+: test-assembler ( expected quot -- )
+ [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
+
+HEX{ 38 22 00 03 } [ 1 2 3 ADDI ] test-assembler
+HEX{ 3c 22 00 03 } [ 1 2 3 ADDIS ] test-assembler
+HEX{ 30 22 00 03 } [ 1 2 3 ADDIC ] test-assembler
+HEX{ 34 22 00 03 } [ 1 2 3 ADDIC. ] test-assembler
+HEX{ 38 40 00 01 } [ 1 2 LI ] test-assembler
+HEX{ 3c 40 00 01 } [ 1 2 LIS ] test-assembler
+HEX{ 38 22 ff fd } [ 1 2 3 SUBI ] test-assembler
+HEX{ 1c 22 00 03 } [ 1 2 3 MULI ] test-assembler
+HEX{ 7c 22 1a 14 } [ 1 2 3 ADD ] test-assembler
+HEX{ 7c 22 1a 15 } [ 1 2 3 ADD. ] test-assembler
+HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
+HEX{ 7c 22 1e 15 } [ 1 2 3 ADDO. ] test-assembler
+HEX{ 7c 22 18 14 } [ 1 2 3 ADDC ] test-assembler
+HEX{ 7c 22 18 15 } [ 1 2 3 ADDC. ] test-assembler
+HEX{ 7c 22 1e 14 } [ 1 2 3 ADDO ] test-assembler
+HEX{ 7c 22 1c 15 } [ 1 2 3 ADDCO. ] test-assembler
+HEX{ 7c 22 19 14 } [ 1 2 3 ADDE ] test-assembler
+HEX{ 7c 41 18 38 } [ 1 2 3 AND ] test-assembler
+HEX{ 7c 41 18 39 } [ 1 2 3 AND. ] test-assembler
+HEX{ 7c 22 1b d6 } [ 1 2 3 DIVW ] test-assembler
+HEX{ 7c 22 1b 96 } [ 1 2 3 DIVWU ] test-assembler
+HEX{ 7c 41 1a 38 } [ 1 2 3 EQV ] test-assembler
+HEX{ 7c 41 1b b8 } [ 1 2 3 NAND ] test-assembler
+HEX{ 7c 41 18 f8 } [ 1 2 3 NOR ] test-assembler
+HEX{ 7c 41 10 f8 } [ 1 2 NOT ] test-assembler
+HEX{ 60 41 00 03 } [ 1 2 3 ORI ] test-assembler
+HEX{ 64 41 00 03 } [ 1 2 3 ORIS ] test-assembler
+HEX{ 7c 41 1b 78 } [ 1 2 3 OR ] test-assembler
+HEX{ 7c 41 13 78 } [ 1 2 MR ] test-assembler
+HEX{ 7c 22 18 96 } [ 1 2 3 MULHW ] test-assembler
+HEX{ 1c 22 00 03 } [ 1 2 3 MULLI ] test-assembler
+HEX{ 7c 22 18 16 } [ 1 2 3 MULHWU ] test-assembler
+HEX{ 7c 22 19 d6 } [ 1 2 3 MULLW ] test-assembler
+HEX{ 7c 41 18 30 } [ 1 2 3 SLW ] test-assembler
+HEX{ 7c 41 1e 30 } [ 1 2 3 SRAW ] test-assembler
+HEX{ 7c 41 1c 30 } [ 1 2 3 SRW ] test-assembler
+HEX{ 7c 41 1e 70 } [ 1 2 3 SRAWI ] test-assembler
+HEX{ 7c 22 18 50 } [ 1 2 3 SUBF ] test-assembler
+HEX{ 7c 22 18 10 } [ 1 2 3 SUBFC ] test-assembler
+HEX{ 7c 22 19 10 } [ 1 2 3 SUBFE ] test-assembler
+HEX{ 7c 41 07 74 } [ 1 2 EXTSB ] test-assembler
+HEX{ 68 41 00 03 } [ 1 2 3 XORI ] test-assembler
+HEX{ 7c 41 1a 78 } [ 1 2 3 XOR ] test-assembler
+HEX{ 7c 22 00 d0 } [ 1 2 NEG ] test-assembler
+HEX{ 2c 22 00 03 } [ 1 2 3 CMPI ] test-assembler
+HEX{ 28 22 00 03 } [ 1 2 3 CMPLI ] test-assembler
+HEX{ 7c 41 18 00 } [ 1 2 3 CMP ] test-assembler
+HEX{ 54 22 19 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
+HEX{ 54 22 18 38 } [ 1 2 3 SLWI ] test-assembler
+HEX{ 54 22 e8 fe } [ 1 2 3 SRWI ] test-assembler
+HEX{ 88 22 00 03 } [ 1 2 3 LBZ ] test-assembler
+HEX{ 8c 22 00 03 } [ 1 2 3 LBZU ] test-assembler
+HEX{ a8 22 00 03 } [ 1 2 3 LHA ] test-assembler
+HEX{ ac 22 00 03 } [ 1 2 3 LHAU ] test-assembler
+HEX{ a0 22 00 03 } [ 1 2 3 LHZ ] test-assembler
+HEX{ a4 22 00 03 } [ 1 2 3 LHZU ] test-assembler
+HEX{ 80 22 00 03 } [ 1 2 3 LWZ ] test-assembler
+HEX{ 84 22 00 03 } [ 1 2 3 LWZU ] test-assembler
+HEX{ 7c 41 18 ae } [ 1 2 3 LBZX ] test-assembler
+HEX{ 7c 41 18 ee } [ 1 2 3 LBZUX ] test-assembler
+HEX{ 7c 41 1a ae } [ 1 2 3 LHAX ] test-assembler
+HEX{ 7c 41 1a ee } [ 1 2 3 LHAUX ] test-assembler
+HEX{ 7c 41 1a 2e } [ 1 2 3 LHZX ] test-assembler
+HEX{ 7c 41 1a 6e } [ 1 2 3 LHZUX ] test-assembler
+HEX{ 7c 41 18 2e } [ 1 2 3 LWZX ] test-assembler
+HEX{ 7c 41 18 6e } [ 1 2 3 LWZUX ] test-assembler
+HEX{ 7c 41 1c 2e } [ 1 2 3 LFSX ] test-assembler
+HEX{ 7c 41 1c 6e } [ 1 2 3 LFSUX ] test-assembler
+HEX{ 7c 41 1c ae } [ 1 2 3 LFDX ] test-assembler
+HEX{ 7c 41 1c ee } [ 1 2 3 LFDUX ] test-assembler
+HEX{ 7c 41 1d 2e } [ 1 2 3 STFSX ] test-assembler
+HEX{ 7c 41 1d 6e } [ 1 2 3 STFSUX ] test-assembler
+HEX{ 7c 41 1d ae } [ 1 2 3 STFDX ] test-assembler
+HEX{ 7c 41 1d ee } [ 1 2 3 STFDUX ] test-assembler
+HEX{ 48 00 00 01 } [ 1 B ] test-assembler
+HEX{ 48 00 00 01 } [ 1 BL ] test-assembler
+HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
+HEX{ 41 81 00 04 } [ 1 BGT ] test-assembler
+HEX{ 40 81 00 04 } [ 1 BLE ] test-assembler
+HEX{ 40 80 00 04 } [ 1 BGE ] test-assembler
+HEX{ 41 80 00 04 } [ 1 BLT ] test-assembler
+HEX{ 40 82 00 04 } [ 1 BNE ] test-assembler
+HEX{ 41 82 00 04 } [ 1 BEQ ] test-assembler
+HEX{ 41 83 00 04 } [ 1 BO ] test-assembler
+HEX{ 40 83 00 04 } [ 1 BNO ] test-assembler
+HEX{ 4c 20 00 20 } [ 1 BCLR ] test-assembler
+HEX{ 4e 80 00 20 } [ BLR ] test-assembler
+HEX{ 4e 80 00 21 } [ BLRL ] test-assembler
+HEX{ 4c 20 04 20 } [ 1 BCCTR ] test-assembler
+HEX{ 4e 80 04 20 } [ BCTR ] test-assembler
+HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
+HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
+HEX{ 7c 69 02 a6 } [ 3 MFCTR ] test-assembler
+HEX{ 7c 61 03 a6 } [ 3 MTXER ] test-assembler
+HEX{ 7c 68 03 a6 } [ 3 MTLR ] test-assembler
+HEX{ 7c 69 03 a6 } [ 3 MTCTR ] test-assembler
+HEX{ 7c 61 02 a6 } [ 3 MFXER ] test-assembler
+HEX{ 7c 68 02 a6 } [ 3 MFLR ] test-assembler
+HEX{ c0 22 00 03 } [ 1 2 3 LFS ] test-assembler
+HEX{ c4 22 00 03 } [ 1 2 3 LFSU ] test-assembler
+HEX{ c8 22 00 03 } [ 1 2 3 LFD ] test-assembler
+HEX{ cc 22 00 03 } [ 1 2 3 LFDU ] test-assembler
+HEX{ d0 22 00 03 } [ 1 2 3 STFS ] test-assembler
+HEX{ d4 22 00 03 } [ 1 2 3 STFSU ] test-assembler
+HEX{ d8 22 00 03 } [ 1 2 3 STFD ] test-assembler
+HEX{ dc 22 00 03 } [ 1 2 3 STFDU ] test-assembler
+HEX{ fc 20 10 90 } [ 1 2 FMR ] test-assembler
+HEX{ fc 40 08 90 } [ 2 1 FMR ] test-assembler
+HEX{ fc 20 10 91 } [ 1 2 FMR. ] test-assembler
+HEX{ fc 40 08 91 } [ 2 1 FMR. ] test-assembler
+HEX{ fc 20 10 1e } [ 1 2 FCTIWZ ] test-assembler
+HEX{ fc 22 18 2a } [ 1 2 3 FADD ] test-assembler
+HEX{ fc 22 18 2b } [ 1 2 3 FADD. ] test-assembler
+HEX{ fc 22 18 28 } [ 1 2 3 FSUB ] test-assembler
+HEX{ fc 22 00 f2 } [ 1 2 3 FMUL ] test-assembler
+HEX{ fc 22 18 24 } [ 1 2 3 FDIV ] test-assembler
+HEX{ fc 20 10 2c } [ 1 2 FSQRT ] test-assembler
+HEX{ fc 41 18 00 } [ 1 2 3 FCMPU ] test-assembler
+HEX{ fc 41 18 40 } [ 1 2 3 FCMPO ] test-assembler
+HEX{ 3c 60 12 34 60 63 56 78 } [ HEX: 12345678 3 LOAD ] test-assembler
--- /dev/null
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces words math math.order locals
+cpu.ppc.assembler.backend ;
+IN: cpu.ppc.assembler
+
+! See the Motorola or IBM documentation for details. The opcode
+! names are standard, and the operand order is the same as in
+! the docs, except a few differences, namely, in IBM/Motorola
+! assembler syntax, loads and stores are written like:
+!
+! stw r14,10(r15)
+!
+! In Factor, we write:
+!
+! 14 15 10 STW
+
+! D-form
+D: ADDI 14
+D: ADDIC 12
+D: ADDIC. 13
+D: ADDIS 15
+D: CMPI 11
+D: CMPLI 10
+D: LBZ 34
+D: LBZU 35
+D: LFD 50
+D: LFDU 51
+D: LFS 48
+D: LFSU 49
+D: LHA 42
+D: LHAU 43
+D: LHZ 40
+D: LHZU 41
+D: LWZ 32
+D: LWZU 33
+D: MULI 7
+D: MULLI 7
+D: STB 38
+D: STBU 39
+D: STFD 54
+D: STFDU 55
+D: STFS 52
+D: STFSU 53
+D: STH 44
+D: STHU 45
+D: STW 36
+D: STWU 37
+
+! SD-form
+SD: ANDI 28
+SD: ANDIS 29
+SD: ORI 24
+SD: ORIS 25
+SD: XORI 26
+SD: XORIS 27
+
+! X-form
+X: AND 0 28 31
+X: AND. 1 28 31
+X: CMP 0 0 31
+X: CMPL 0 32 31
+X: EQV 0 284 31
+X: EQV. 1 284 31
+X: FCMPO 0 32 63
+X: FCMPU 0 0 63
+X: LBZUX 0 119 31
+X: LBZX 0 87 31
+X: LFDUX 0 631 31
+X: LFDX 0 599 31
+X: LFSUX 0 567 31
+X: LFSX 0 535 31
+X: LHAUX 0 375 31
+X: LHAX 0 343 31
+X: LHZUX 0 311 31
+X: LHZX 0 279 31
+X: LWZUX 0 55 31
+X: LWZX 0 23 31
+X: NAND 0 476 31
+X: NAND. 1 476 31
+X: NOR 0 124 31
+X: NOR. 1 124 31
+X: OR 0 444 31
+X: OR. 1 444 31
+X: ORC 0 412 31
+X: ORC. 1 412 31
+X: SLW 0 24 31
+X: SLW. 1 24 31
+X: SRAW 0 792 31
+X: SRAW. 1 792 31
+X: SRAWI 0 824 31
+X: SRW 0 536 31
+X: SRW. 1 536 31
+X: STBUX 0 247 31
+X: STBX 0 215 31
+X: STFDUX 0 759 31
+X: STFDX 0 727 31
+X: STFSUX 0 695 31
+X: STFSX 0 663 31
+X: STHUX 0 439 31
+X: STHX 0 407 31
+X: STWUX 0 183 31
+X: STWX 0 151 31
+X: XOR 0 316 31
+X: XOR. 1 316 31
+X1: EXTSB 0 954 31
+X1: EXTSB. 1 954 31
+: FRSP ( a s -- ) [ 0 ] 2dip 0 12 63 x-insn ;
+: FRSP. ( a s -- ) [ 0 ] 2dip 1 12 63 x-insn ;
+: FMR ( a s -- ) [ 0 ] 2dip 0 72 63 x-insn ;
+: FMR. ( a s -- ) [ 0 ] 2dip 1 72 63 x-insn ;
+: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
+: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
+
+! XO-form
+XO: ADD 0 0 266 31
+XO: ADD. 0 1 266 31
+XO: ADDC 0 0 10 31
+XO: ADDC. 0 1 10 31
+XO: ADDCO 1 0 10 31
+XO: ADDCO. 1 1 10 31
+XO: ADDE 0 0 138 31
+XO: ADDE. 0 1 138 31
+XO: ADDEO 1 0 138 31
+XO: ADDEO. 1 1 138 31
+XO: ADDO 1 0 266 31
+XO: ADDO. 1 1 266 31
+XO: DIVW 0 0 491 31
+XO: DIVW. 0 1 491 31
+XO: DIVWO 1 0 491 31
+XO: DIVWO. 1 1 491 31
+XO: DIVWU 0 0 459 31
+XO: DIVWU. 0 1 459 31
+XO: DIVWUO 1 0 459 31
+XO: DIVWUO. 1 1 459 31
+XO: MULHW 0 0 75 31
+XO: MULHW. 0 1 75 31
+XO: MULHWU 0 0 11 31
+XO: MULHWU. 0 1 11 31
+XO: MULLW 0 0 235 31
+XO: MULLW. 0 1 235 31
+XO: MULLWO 1 0 235 31
+XO: MULLWO. 1 1 235 31
+XO: SUBF 0 0 40 31
+XO: SUBF. 0 1 40 31
+XO: SUBFC 0 0 8 31
+XO: SUBFC. 0 1 8 31
+XO: SUBFCO 1 0 8 31
+XO: SUBFCO. 1 1 8 31
+XO: SUBFE 0 0 136 31
+XO: SUBFE. 0 1 136 31
+XO: SUBFEO 1 0 136 31
+XO: SUBFEO. 1 1 136 31
+XO: SUBFO 1 0 40 31
+XO: SUBFO. 1 1 40 31
+XO1: NEG 0 0 104 31
+XO1: NEG. 0 1 104 31
+XO1: NEGO 1 0 104 31
+XO1: NEGO. 1 1 104 31
+
+! A-form
+: RLWINM ( d a b c xo -- ) 0 21 a-insn ;
+: RLWINM. ( d a b c xo -- ) 1 21 a-insn ;
+: FADD ( d a b -- ) 0 21 0 63 a-insn ;
+: FADD. ( d a b -- ) 0 21 1 63 a-insn ;
+: FSUB ( d a b -- ) 0 20 0 63 a-insn ;
+: FSUB. ( d a b -- ) 0 20 1 63 a-insn ;
+: FMUL ( d a c -- ) 0 swap 25 0 63 a-insn ;
+: FMUL. ( d a c -- ) 0 swap 25 1 63 a-insn ;
+: FDIV ( d a b -- ) 0 18 0 63 a-insn ;
+: FDIV. ( d a b -- ) 0 18 1 63 a-insn ;
+: FSQRT ( d b -- ) 0 swap 0 22 0 63 a-insn ;
+: FSQRT. ( d b -- ) 0 swap 0 22 1 63 a-insn ;
+
+! Branches
+: B ( dest -- ) 0 0 (B) ;
+: BL ( dest -- ) 0 1 (B) ;
+BC: LT 12 0
+BC: GE 4 0
+BC: GT 12 1
+BC: LE 4 1
+BC: EQ 12 2
+BC: NE 4 2
+BC: O 12 3
+BC: NO 4 3
+B: CLR 0 8 0 0 19
+B: CLRL 0 8 0 1 19
+B: CCTR 0 264 0 0 19
+: BLR ( -- ) 20 BCLR ;
+: BLRL ( -- ) 20 BCLRL ;
+: BCTR ( -- ) 20 BCCTR ;
+
+! Special registers
+MFSPR: XER 1
+MFSPR: LR 8
+MFSPR: CTR 9
+MTSPR: XER 1
+MTSPR: LR 8
+MTSPR: CTR 9
+
+! Pseudo-instructions
+: LI ( value dst -- ) swap [ 0 ] dip ADDI ; inline
+: SUBI ( dst src1 src2 -- ) neg ADDI ; inline
+: LIS ( value dst -- ) swap [ 0 ] dip ADDIS ; inline
+: SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline
+: SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline
+: NOT ( dst src -- ) dup NOR ; inline
+: NOT. ( dst src -- ) dup NOR. ; inline
+: MR ( dst src -- ) dup OR ; inline
+: MR. ( dst src -- ) dup OR. ; inline
+: (SLWI) ( d a b -- d a b x y ) 0 31 pick - ; inline
+: SLWI ( d a b -- ) (SLWI) RLWINM ;
+: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
+: (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline
+: SRWI ( d a b -- ) (SRWI) RLWINM ;
+: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
+:: LOAD32 ( n r -- )
+ n -16 shift HEX: ffff bitand r LIS
+ r r n HEX: ffff bitand ORI ;
+: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
+: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
+
+! Altivec/VMX instructions
+VA: VMHADDSHS 32 4
+VA: VMHRADDSHS 33 4
+VA: VMLADDUHM 34 4
+VA: VMSUMUBM 36 4
+VA: VMSUMMBM 37 4
+VA: VMSUMUHM 38 4
+VA: VMSUMUHS 39 4
+VA: VMSUMSHM 40 4
+VA: VMSUMSHS 41 4
+VA: VSEL 42 4
+VA: VPERM 43 4
+VA: VSLDOI 44 4
+VA: VMADDFP 46 4
+VA: VNMSUBFP 47 4
+
+VX: VADDUBM 0 4
+VX: VADDUHM 64 4
+VX: VADDUWM 128 4
+VX: VADDCUW 384 4
+VX: VADDUBS 512 4
+VX: VADDUHS 576 4
+VX: VADDUWS 640 4
+VX: VADDSBS 768 4
+VX: VADDSHS 832 4
+VX: VADDSWS 896 4
+
+VX: VSUBUBM 1024 4
+VX: VSUBUHM 1088 4
+VX: VSUBUWM 1152 4
+VX: VSUBCUW 1408 4
+VX: VSUBUBS 1536 4
+VX: VSUBUHS 1600 4
+VX: VSUBUWS 1664 4
+VX: VSUBSBS 1792 4
+VX: VSUBSHS 1856 4
+VX: VSUBSWS 1920 4
+
+VX: VMAXUB 2 4
+VX: VMAXUH 66 4
+VX: VMAXUW 130 4
+VX: VMAXSB 258 4
+VX: VMAXSH 322 4
+VX: VMAXSW 386 4
+
+VX: VMINUB 514 4
+VX: VMINUH 578 4
+VX: VMINUW 642 4
+VX: VMINSB 770 4
+VX: VMINSH 834 4
+VX: VMINSW 898 4
+
+VX: VAVGUB 1026 4
+VX: VAVGUH 1090 4
+VX: VAVGUW 1154 4
+VX: VAVGSB 1282 4
+VX: VAVGSH 1346 4
+VX: VAVGSW 1410 4
+
+VX: VRLB 4 4
+VX: VRLH 68 4
+VX: VRLW 132 4
+VX: VSLB 260 4
+VX: VSLH 324 4
+VX: VSLW 388 4
+VX: VSL 452 4
+VX: VSRB 516 4
+VX: VSRH 580 4
+VX: VSRW 644 4
+VX: VSR 708 4
+VX: VSRAB 772 4
+VX: VSRAH 836 4
+VX: VSRAW 900 4
+
+VX: VAND 1028 4
+VX: VANDC 1092 4
+VX: VOR 1156 4
+VX: VNOR 1284 4
+VX: VXOR 1220 4
+
+VXD: MFVSCR 1540 4
+VXB: MTVSCR 1604 4
+
+VX: VMULOUB 8 4
+VX: VMULOUH 72 4
+VX: VMULOSB 264 4
+VX: VMULOSH 328 4
+VX: VMULEUB 520 4
+VX: VMULEUH 584 4
+VX: VMULESB 776 4
+VX: VMULESH 840 4
+VX: VSUM4UBS 1544 4
+VX: VSUM4SBS 1800 4
+VX: VSUM4SHS 1608 4
+VX: VSUM2SWS 1672 4
+VX: VSUMSWS 1928 4
+
+VX: VADDFP 10 4
+VX: VSUBFP 74 4
+
+VXDB: VREFP 266 4
+VXDB: VRSQRTEFP 330 4
+VXDB: VEXPTEFP 394 4
+VXDB: VLOGEFP 458 4
+VXDB: VRFIN 522 4
+VXDB: VRFIZ 586 4
+VXDB: VRFIP 650 4
+VXDB: VRFIM 714 4
+
+VX: VCFUX 778 4
+VX: VCFSX 842 4
+VX: VCTUXS 906 4
+VX: VCTSXS 970 4
+
+VX: VMAXFP 1034 4
+VX: VMINFP 1098 4
+
+VX: VMRGHB 12 4
+VX: VMRGHH 76 4
+VX: VMRGHW 140 4
+VX: VMRGLB 268 4
+VX: VMRGLH 332 4
+VX: VMRGLW 396 4
+
+VX: VSPLTB 524 4
+VX: VSPLTH 588 4
+VX: VSPLTW 652 4
+
+VXA: VSPLTISB 780 4
+VXA: VSPLTISH 844 4
+VXA: VSPLTISW 908 4
+
+VX: VSLO 1036 4
+VX: VSRO 1100 4
+
+VX: VPKUHUM 14 4
+VX: VPKUWUM 78 4
+VX: VPKUHUS 142 4
+VX: VPKUWUS 206 4
+VX: VPKSHUS 270 4
+VX: VPKSWUS 334 4
+VX: VPKSHSS 398 4
+VX: VPKSWSS 462 4
+VX: VPKPX 782 4
+
+VXDB: VUPKHSB 526 4
+VXDB: VUPKHSH 590 4
+VXDB: VUPKLSB 654 4
+VXDB: VUPKLSH 718 4
+VXDB: VUPKHPX 846 4
+VXDB: VUPKLPX 974 4
+
+: -T ( strm a b -- strm-t a b ) [ 16 bitor ] 2dip ;
+
+XD: DST 0 342 31
+: DSTT ( strm a b -- ) -T DST ;
+
+XD: DSTST 0 374 31
+: DSTSTT ( strm a b -- ) -T DSTST ;
+
+XD: (DSS) 0 822 31
+: DSS ( strm -- ) 0 0 (DSS) ;
+: DSSALL ( -- ) 16 0 0 (DSS) ;
+
+XD: LVEBX 0 7 31
+XD: LVEHX 0 39 31
+XD: LVEWX 0 71 31
+XD: LVSL 0 6 31
+XD: LVSR 0 38 31
+XD: LVX 0 103 31
+XD: LVXL 0 359 31
+
+XD: STVEBX 0 135 31
+XD: STVEHX 0 167 31
+XD: STVEWX 0 199 31
+XD: STVX 0 231 31
+XD: STVXL 0 487 31
+
+VXR: VCMPBFP 0 966 4
+VXR: VCMPEQFP 0 198 4
+VXR: VCMPEQUB 0 6 4
+VXR: VCMPEQUH 0 70 4
+VXR: VCMPEQUW 0 134 4
+VXR: VCMPGEFP 0 454 4
+VXR: VCMPGTFP 0 710 4
+VXR: VCMPGTSB 0 774 4
+VXR: VCMPGTSH 0 838 4
+VXR: VCMPGTSW 0 902 4
+VXR: VCMPGTUB 0 518 4
+VXR: VCMPGTUH 0 582 4
+VXR: VCMPGTUW 0 646 4
+
+VXR: VCMPBFP. 1 966 4
+VXR: VCMPEQFP. 1 198 4
+VXR: VCMPEQUB. 1 6 4
+VXR: VCMPEQUH. 1 70 4
+VXR: VCMPEQUW. 1 134 4
+VXR: VCMPGEFP. 1 454 4
+VXR: VCMPGTFP. 1 710 4
+VXR: VCMPGTSB. 1 774 4
+VXR: VCMPGTSH. 1 838 4
+VXR: VCMPGTSW. 1 902 4
+VXR: VCMPGTUB. 1 518 4
+VXR: VCMPGTUH. 1 582 4
+VXR: VCMPGTUW. 1 646 4
+
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces make sequences words math
+math.bitwise io.binary parser lexer fry ;
+IN: cpu.ppc.assembler.backend
+
+: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
+
+: a-insn ( d a b c xo rc opcode -- )
+ [ { 0 1 6 11 16 21 } bitfield ] dip insn ;
+
+: b-insn ( bo bi bd aa lk opcode -- )
+ [ { 0 1 2 16 21 } bitfield ] dip insn ;
+
+: s>u16 ( s -- u ) HEX: ffff bitand ;
+
+: d-insn ( d a simm opcode -- )
+ [ s>u16 { 0 16 21 } bitfield ] dip insn ;
+
+: define-d-insn ( word opcode -- )
+ [ d-insn ] curry (( d a simm -- )) define-declared ;
+
+SYNTAX: D: CREATE scan-word define-d-insn ;
+
+: sd-insn ( d a simm opcode -- )
+ [ s>u16 { 0 21 16 } bitfield ] dip insn ;
+
+: define-sd-insn ( word opcode -- )
+ [ sd-insn ] curry (( d a simm -- )) define-declared ;
+
+SYNTAX: SD: CREATE scan-word define-sd-insn ;
+
+: i-insn ( li aa lk opcode -- )
+ [ { 0 1 0 } bitfield ] dip insn ;
+
+: x-insn ( a s b rc xo opcode -- )
+ [ { 1 0 11 21 16 } bitfield ] dip insn ;
+
+: xd-insn ( d a b rc xo opcode -- )
+ [ { 1 0 11 16 21 } bitfield ] dip insn ;
+
+: (X) ( -- word quot )
+ CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
+
+: (XD) ( -- word quot )
+ CREATE scan-word scan-word scan-word [ xd-insn ] 3curry ;
+
+SYNTAX: X: (X) (( a s b -- )) define-declared ;
+SYNTAX: XD: (XD) (( d a b -- )) define-declared ;
+
+: (1) ( quot -- quot' ) [ 0 ] prepose ;
+
+SYNTAX: X1: (X) (1) (( a s -- )) define-declared ;
+
+: xfx-insn ( d spr xo opcode -- )
+ [ { 1 11 21 } bitfield ] dip insn ;
+
+: CREATE-MF ( -- word ) scan "MF" prepend create-in ;
+
+SYNTAX: MFSPR:
+ CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
+ (( d -- )) define-declared ;
+
+: CREATE-MT ( -- word ) scan "MT" prepend create-in ;
+
+SYNTAX: MTSPR:
+ CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
+ (( d -- )) define-declared ;
+
+: xo-insn ( d a b oe rc xo opcode -- )
+ [ { 1 0 10 11 16 21 } bitfield ] dip insn ;
+
+: (XO) ( -- word quot )
+ CREATE scan-word scan-word scan-word scan-word
+ [ xo-insn ] 2curry 2curry ;
+
+SYNTAX: XO: (XO) (( d a b -- )) define-declared ;
+
+SYNTAX: XO1: (XO) (1) (( d a -- )) define-declared ;
+
+GENERIC# (B) 2 ( dest aa lk -- )
+M: integer (B) 18 i-insn ;
+
+GENERIC: BC ( a b c -- )
+M: integer BC 0 0 16 b-insn ;
+
+: CREATE-B ( -- word ) scan "B" prepend create-in ;
+
+SYNTAX: BC:
+ CREATE-B scan-word scan-word
+ '[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
+
+SYNTAX: B:
+ CREATE-B scan-word scan-word scan-word scan-word scan-word
+ '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
+
+: va-insn ( d a b c xo opcode -- )
+ [ { 0 6 11 16 21 } bitfield ] dip insn ;
+
+: (VA) ( -- word quot )
+ CREATE scan-word scan-word [ va-insn ] 2curry ;
+
+SYNTAX: VA: (VA) (( d a b c -- )) define-declared ;
+
+: vx-insn ( d a b xo opcode -- )
+ [ { 0 11 16 21 } bitfield ] dip insn ;
+
+: (VX) ( -- word quot )
+ CREATE scan-word scan-word [ vx-insn ] 2curry ;
+: (VXD) ( -- word quot )
+ CREATE scan-word scan-word '[ 0 0 _ _ vx-insn ] ;
+: (VXA) ( -- word quot )
+ CREATE scan-word scan-word '[ [ 0 ] dip 0 _ _ vx-insn ] ;
+: (VXB) ( -- word quot )
+ CREATE scan-word scan-word '[ [ 0 0 ] dip _ _ vx-insn ] ;
+: (VXDB) ( -- word quot )
+ CREATE scan-word scan-word '[ [ 0 ] dip _ _ vx-insn ] ;
+
+SYNTAX: VX: (VX) (( d a b -- )) define-declared ;
+SYNTAX: VXD: (VXD) (( d -- )) define-declared ;
+SYNTAX: VXA: (VXA) (( a -- )) define-declared ;
+SYNTAX: VXB: (VXB) (( b -- )) define-declared ;
+SYNTAX: VXDB: (VXDB) (( d b -- )) define-declared ;
+
+: vxr-insn ( d a b rc xo opcode -- )
+ [ { 0 10 11 16 21 } bitfield ] dip insn ;
+
+: (VXR) ( -- word quot )
+ CREATE scan-word scan-word scan-word [ vxr-insn ] 3curry ;
+
+SYNTAX: VXR: (VXR) (( d a b -- )) define-declared ;
+
--- /dev/null
+PowerPC assembler
-! 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 ;
<PRIVATE
: start-listener ( -- )
- [ [ print-error-and-restarts drop ] error-hook set listener ] with-scope ;
+ [ [ drop print-error-and-restarts ] error-hook set listener ] with-scope ;
: server ( port -- server )
utf8 <threaded-server>
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 ;
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
<< "libgdbm" {
{ [ os macosx? ] [ "libgdbm.dylib" ] }
{ [ os unix? ] [ "libgdbm.so" ] }
- { [ os winnt? ] [ "gdbm.dll" ] }
+ { [ os winnt? ] [ "gdbm3.dll" ] }
} cond cdecl add-library >>
LIBRARY: libgdbm
: 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? [
{ $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
--- /dev/null
+! 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
! 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 )
[ <enum> >alist ] [ '[ second @ ] ] bi* filter ; inline
-: find-nth ( seq quot n -- i elt )
- [ <enum> >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
: 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
] 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
: 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 ;
-
-: <link> ( 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' )
[ 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
[
{
{ [ dup name>> "form" = ]
- [ "form action: " write attributes>> "action" swap at print ] }
+ [ "form action: " write "action" attribute print ] }
{ [ dup name>> "input" = ] [ input. ] }
[ drop ]
} cond
"?" 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 ;
+
+: <link> ( 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 ;
! 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
<PRIVATE
[ '[ _ load-reference-image ] ] bi
unit-test
] with-variable ;
+
+: <rgb-image> ( -- image )
+ <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
! 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
: 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 ;
! 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 ( -- )
! 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
-! 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
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 ]
[ 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
] 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
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" ? ;
] if ;
: build-child ( -- status )
- copy-image
{
{ [ notify-make-vm make-vm ] [ compile-failed ] }
{ [ notify-boot boot ] [ boot-failed ] }
[ "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
-! 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
#! 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 )
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"
! 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
! 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?
! 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
--- /dev/null
+Slava Pestov
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+! 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
! 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 -- )
- <email>
- builder-from get >>from
- builder-recipients get >>to
- swap >>subject
- swap >>content-type
- swap >>body
- send-email ;
+ '[
+ <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 ;
: 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 ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+: git-clone-cmd ( -- cmd )
+ {
+ "git"
+ "clone"
+ "git://factorcode.org/git/factor.git"
+ } ;
+
+: git-clone ( -- )
+ #! Must be run from builds-dir
+ git-clone-cmd try-output-process ;
+
+: git-pull-cmd ( -- cmd )
+ {
+ "git"
+ "pull"
+ "git://factorcode.org/git/factor.git"
+ "master"
+ } ;
+
+: repo-corrupted-body ( error -- string )
+ [
+ "Corrupted repository on " write host-name write " will be re-cloned." print
+ "Error while pulling was:" print
+ nl
+ error.
+ ] with-string-writer ;
+
+: git-repo-corrupted ( error -- )
+ repo-corrupted-body "corrupted repo" email-fatal
+ "factor" really-delete-tree
+ git-clone ;
+
+: git-pull-failed ( error -- )
+ dup output-process-error? [
+ dup output>> "not uptodate. Cannot merge." swap start
+ [ git-repo-corrupted ]
+ [ rethrow ]
+ if
+ ] [ rethrow ] if ;
+
+: with-process-reader* ( desc encoding quot -- )
+ [ <process-reader*> ] 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 ;
+++ /dev/null
-! 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
! 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 ;
+
+: fatal-error-body ( error callstack -- string )
+ [
+ "Fatal error on " write host-name print nl
+ [ error. ] [ callstack. ] bi*
+ ] with-string-writer ;
-: build-loop-fatal ( error -- )
- "FATAL BUILDER ERROR:" print
- error. flush ;
+: 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
! 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 ]
[ 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 ]
-! 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
: push-to-clean-branch-cmd ( -- args )
[
- "git" , "push" ,
+ { "git" "push" "-f" } %
[
branch-username get % "@" %
branch-host get % ":" %
-! 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 )
target-os get
target-cpu get
short-host-name
+ disk-usage
build-dir
current-git-id get git-link
[XML
<h1>Build report for <->/<-></h1>
<table>
<tr><td>Build machine:</td><td><-></td></tr>
+ <tr><td>Disk usage:</td><td><-></td></tr>
<tr><td>Build directory:</td><td><-></td></tr>
<tr><td>GIT ID:</td><td><-></td></tr>
</table>
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! 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
-
-CONSTANT: +starting+ "starting"
-CONSTANT: +make-vm+ "make-vm"
-CONSTANT: +boot+ "boot"
-CONSTANT: +test+ "test"
-CONSTANT: +clean+ "status-clean"
-CONSTANT: +dirty+ "status-dirty"
-CONSTANT: +error+ "status-error"
-
-TUPLE: builder
-host-name os cpu
-clean-git-id clean-timestamp
-last-release release-git-id
-last-git-id last-timestamp last-report
-current-git-id current-timestamp
-status ;
-
-builder "BUILDERS" {
- { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
- { "os" "OS" TEXT +user-assigned-id+ }
- { "cpu" "CPU" TEXT +user-assigned-id+ }
-
- { "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 }
-
- { "current-git-id" "CURRENT_GIT_ID" TEXT }
- ! Can't name it CURRENT_TIMESTAMP because of bug in db library
- { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
- { "status" "STATUS" TEXT }
-} define-persistent
-
-: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
-
-: with-mason-db ( quot -- )
- [ mason-db ] dip with-db ; inline
! 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"
- } ;
-
-: updates-available? ( -- ? )
- git-id
- git-pull-cmd short-running-process
- git-id
- = not ;
-
-: new-image-available? ( -- ? )
- boot-image-name maybe-download-image ;
-
-: new-code-available? ( -- ? )
- updates-available? new-image-available? or ;
+TUPLE: sources git-id boot-image counter ;
+
+C: <sources> sources
+
+SYMBOLS: latest-sources last-built-sources ;
+
+[
+ 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 <sources>
+ 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 ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
-
-: binary-release-command ( version builder -- command )
- [
- "cp " %
- [ nip binary-package-name % " " % ]
- [ remote-binary-release-name % ]
- 2bi
- ] "" make ;
-
-: binary-release-script ( version builders -- string )
- [ binary-release-command ] with map "\n" join ;
-
-: do-binary-release ( version builders -- )
- "Copying binary releases to release directory..." print flush
- binary-release-script execute-on-server ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2010 Slava Pestov.
-! 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
-
-: execute-on-server ( string -- )
- [ "ssh" , upload-host get , "-l" , upload-username get , ] { } make
- <process>
- swap >>command
- 5 minutes >>timeout
- ascii [ write ] with-process-writer ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
-
-TUPLE: release
-host-name os cpu
-last-release release-git-id ;
-
-release "RELEASES" {
- { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
- { "os" "OS" TEXT +user-assigned-id+ }
- { "cpu" "CPU" TEXT +user-assigned-id+ }
- { "last-release" "LAST_RELEASE" TEXT }
- { "release-git-id" "RELEASE_GIT_ID" TEXT }
-} define-persistent
-
-:: <release> ( version builder -- release )
- release new
- builder host-name>> >>host-name
- builder os>> >>os
- builder cpu>> >>cpu
- builder release-git-id>> >>release-git-id
- version builder binary-release-name >>last-release ;
-
-: update-binary-releases ( version builders -- )
- [
- release new delete-tuples
- [ <release> insert-tuple ] with each
- ] with-transaction ;
-
-TUPLE: version
-id version git-id timestamp source-path announcement-url ;
-
-version "VERSIONS" {
- { "id" "ID" INTEGER +db-assigned-id+ }
- { "version" "VERSION" TEXT }
- { "git-id" "GIT_ID" TEXT }
- { "timestamp" "TIMESTAMP" TIMESTAMP }
- { "source-path" "SOURCE_PATH" TEXT }
- { "announcement-url" "ANNOUNCEMENT_URL" TEXT }
-} define-persistent
-
-: update-version ( version git-id announcement-url -- )
- version new
- swap >>announcement-url
- swap >>git-id
- swap [ >>version ] [ source-release-name >>source-path ] bi
- now >>timestamp
- insert-tuple ;
-
-: latest-version ( -- version )
- version new select-tuples last ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2010 Slava Pestov.
-! 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
-
-: release-directory ( string version -- string )
- [ "releases/" % % "/" % % ] "" make ;
-
-: remote-directory ( string -- string' )
- [ upload-directory get ] dip "/" glue ;
-
-SLOT: os
-SLOT: cpu
-
-: platform ( builder -- string )
- [ os>> ] [ cpu>> ] bi (platform) ;
-
-: binary-package-name ( builder -- string )
- [ [ platform % "/" % ] [ last-release>> % ] bi ] "" make
- remote-directory ;
-
-: binary-release-name ( version builder -- string )
- [
- [
- [ "factor-" % platform % "-" % % ]
- [ os>> extension % ]
- bi
- ] "" make
- ] [ drop ] 2bi release-directory ;
-
-: remote-binary-release-name ( version builder -- string )
- binary-release-name remote-directory ;
-
-: source-release-name ( version -- string )
- [ "factor-src-" ".zip" surround ] keep release-directory ;
-
-: remote-source-release-name ( version -- string )
- source-release-name remote-directory ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2010 Slava Pestov.
-! 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
-
-: clone-factor ( -- )
- { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ;
-
-: git-reset ( git-id -- )
- { "git" "reset" "--hard" } swap suffix try-process ;
-
-: save-git-id ( git-id -- )
- "git-id" to-file ;
-
-: delete-git-tree ( -- )
- ".git" delete-tree
- ".gitignore" delete-file ;
-
-: download-images ( -- )
- images [ download-image ] each ;
-
-: prepare-source ( git-id -- )
- "factor" [
- [ git-reset ] [ save-git-id ] bi
- delete-git-tree
- download-images
- ] with-directory ;
-
-: (make-source-release) ( version -- path )
- [ { "zip" "-qr9" } ] dip source-release-name file-name
- [ suffix "factor" suffix try-process ] keep ;
-
-: 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
- ] with-unique-directory drop ;
-
-: upload-source-release ( package version -- )
- "Uploading source release..." print flush
- [ upload-username get upload-host get ] dip
- remote-source-release-name
- upload-safely ;
-
-: do-source-release ( version git-id -- )
- [ make-source-release ] [ drop upload-source-release ] 2bi ;
+++ /dev/null
-! 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
-
-: check-releases ( builders -- )
- [ release-git-id>> ] map all-equal?
- [ "Some builders are out of date" throw ] unless ;
-
-: make-release-directory ( version -- )
- "Creating release directory..." print flush
- [ "mkdir -p " % "" release-directory remote-directory % "\n" % ] "" make
- execute-on-server ;
-
-: tweet-release ( version announcement-url -- )
- [
- "Factor " %
- [ % " released -- " % ] [ shorten-url % ] bi*
- ] "" make mason-tweet ;
-
-:: (do-release) ( version announcement-url -- )
- [
- builder new select-tuples :> builders
- builders first release-git-id>> :> git-id
-
- builders check-releases
- version make-release-directory
- version builders do-binary-release
- version builders update-binary-releases
- version git-id do-source-release
- version git-id announcement-url update-version
- version announcement-url tweet-release
-
- "Done." print flush
- ] with-mason-db ;
-
-: send-release-email ( string version -- )
- [ "text/plain" ] dip "Release output: " prepend mason-email ;
-
-:: do-release ( version announcement-url -- )
- [
- [
- [
- version announcement-url (do-release)
- ] try
- ] with-string-writer
- version send-release-email
- ] "Mason release" spawn drop ;
! 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
[ 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
+
[ (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 ^ * * ;
+
+++ /dev/null
-Hans Schmid
+++ /dev/null
-USING: help.markup help.syntax sequences ;
-IN: math.transforms.fft
-
-HELP: fft
-{ $values { "seq" sequence } { "seq'" sequence } }
-{ $description "Fast Fourier transform function." } ;
-
+++ /dev/null
-! Copyright (c) 2007 Hans Schmid.
-! See http://factorcode.org/license.txt for BSD license.
-USING: columns grouping kernel math math.constants math.functions math.vectors
- sequences ;
-IN: math.transforms.fft
-
-! Fast Fourier Transform
-
-<PRIVATE
-
-: n^v ( n v -- w ) [ ^ ] with map ;
-
-: omega ( n -- n' )
- recip -2 pi i* * * exp ;
-
-: twiddle ( seq -- seq' )
- dup length [ omega ] [ n^v ] bi v* ;
-
-PRIVATE>
-
-DEFER: fft
-
-: two ( seq -- seq' )
- fft 2 v/n dup append ;
-
-<PRIVATE
-
-: even ( seq -- seq' ) 2 group 0 <column> ;
-: odd ( seq -- seq' ) 2 group 1 <column> ;
-
-: (fft) ( seq -- seq' )
- [ odd two twiddle ] [ even two ] bi v+ ;
-
-PRIVATE>
-
-: fft ( seq -- seq' )
- dup length 1 = [ (fft) ] unless ;
-
+++ /dev/null
-Fast fourier transform
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 )
] with-connection ; inline
: open-connection ( mdb-connection node -- mdb-connection )
- [ >>node ] [ address>> ] bi
- [ >>remote ] keep binary <client>
- [ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
+ [ >>node ] [ address>> ] bi
+ [ >>remote ] keep binary <client>
+ [ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
: get-ismaster ( -- result )
"admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
: check-node ( mdb node -- )
[ <mdb-connection> &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 ;
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 [ <mdb-connection> ] keep
- master-node open-connection
- [ authenticate-connection ] keep ;
+ clone [ verify-nodes ] [ <mdb-connection> ] [ ] 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 ;
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)" } ;
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 ;
: <query> ( collection assoc -- mdb-query-msg )
<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
[ check-collection ] 2dip <mdb-update-msg> ;
: >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 ;
: run-cmd ( cmd -- result )
send-cmd ; inline
-: delete ( collection selector -- )
- [ check-collection ] dip
- <mdb-delete-msg> send-message-check-error ;
+: <delete> ( collection selector -- mdb-delete-msg )
+ [ check-collection ] dip <mdb-delete-msg> ;
-: delete-unsafe ( collection selector -- )
- [ check-collection ] dip
- <mdb-delete-msg> 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>> <mdb-killcursors-msg> send-message ;
"person \"persons\" { } { $[ \"ageIdx\" [ \"age\" asc ] key-spec <tuple-index> ] } define-persistent "
"\"db\" \"127.0.0.1\" 27017 <mdb>"
"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"
"" }
;
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
{
[ flags>> write-int32 ]
[ collection>> write-cstring ]
- [ upsert?>> write-int32 ]
+ [ update-flags>> write-int32 ]
[ selector>> assoc>stream ]
[ object>> assoc>stream ]
} cleave
: 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 -- )
IN: mongodb.tuple
-SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ +unique+ ;
-
SYNTAX: MDBTUPLE:
parse-tuple-definition
mdb-check-slots
: delete-tuple ( tuple -- )
[ tuple-collection name>> ] keep
- id-selector delete ;
+ id-selector <delete> delete ;
: delete-tuples ( seq -- )
[ delete-tuple ] each ;
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 <int> f <void*> 0 <int> 0 <int>
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 <int> f <void*> 0 <int> 0 <int>
--- /dev/null
+John Benediktsson
--- /dev/null
+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
--- /dev/null
+! 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
+
+<PRIVATE
+
+TUPLE: echo type identifier sequence data ;
+
+: <echo> ( 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> 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: <ping-port> os ( inet -- port )
+
+M: object <ping-port> <raw> ;
+
+M: macosx <ping-port> <datagram> ;
+
+: ping ( host -- reply )
+ <icmp> resolve-host [ icmp4? ] filter random
+ f <icmp4> <ping-port>
+ 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 ;
+
--- /dev/null
+windows
+macosx
--- /dev/null
+Uses ICMP to test the reachability of a network host.
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 ;
over >>currently-spidering
swap 0 <unique-deque> [ push-url ] keep >>todo
<unique-deque> >>nonmatching
- 0 >>max-depth
- 0 >>count
- 1/0. >>max-count
H{ } clone >>spidered
- 1 [ >>#threads ] [ <semaphore> >>semaphore ] bi ;
+ 1 <semaphore> >>semaphore ;
: <spider-result> ( url depth -- spider-result )
spider-result new
swap >>depth
- swap >>url ;
+ swap >>url ; inline
<PRIVATE
: apply-filters ( links spider -- links' )
- filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
+ filters>> [
+ '[ [ _ 1&& ] filter ] call( seq -- seq' )
+ ] when* ;
: push-links ( links level unique-deque -- )
'[ _ _ push-url ] each ;
[ 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 ;
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&& ;
: run-spider ( spider -- spider )
"spider" [
- dup queue-initial-links [ run-spider-loop ] keep
+ queue-initial-links
+ [ run-spider-loop ] keep
] with-logging ;
! 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 ( -- )
1234 >>insecure
[ handle-time-client ] >>handler ;
-: start-time-server ( -- threaded-server )
- <time-server> [ start-server ] in-thread ;
+: start-time-server ( -- )
+ <time-server> start-server drop ;
MAIN: start-time-server
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types classes.struct kernel memory
+system vm ;
+IN: tools.time.struct
+
+STRUCT: benchmark-data
+ { time ulonglong }
+ { data-room data-heap-room }
+ { code-room mark-sweep-sizes } ;
+
+STRUCT: benchmark-data-pair
+ { start benchmark-data }
+ { stop benchmark-data } ;
+
+: <benchmark-data> ( -- benchmark-data )
+ \ benchmark-data <struct>
+ nano-count >>time
+ code-room >>code-room
+ data-room >>data-room ; inline
+
+: <benchmark-data-pair> ( start stop -- benchmark-data-pair )
+ \ benchmark-data-pair <struct>
+ swap >>stop
+ swap >>start ; inline
+
+: with-benchmarking ( ... quot -- ... benchmark-data-pair )
+ <benchmark-data>
+ [ call ] dip
+ <benchmark-data> <benchmark-data-pair> ; inline
+
"tty-server" >>name
swap local-server >>insecure
[ listener ] >>handler
- start-server ;
+ start-server drop ;
: tty-server ( -- ) 9999 <tty-server> ;
! 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
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
<request-token-params>
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
<access-token-params>
swap >>verifier
swap >>request-token
[ [ '[ _ 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 )
[ <oauth-request-params> set-oauth ] with-twitter-oauth ;
] H{ } make-assoc ;
: (tweet) ( string -- json )
- update-post-data "update" twitter-url
+ update-post-data "update" status-url
<post-request> twitter-request ;
PRIVATE>
<PRIVATE
: timeline ( url -- tweets )
- twitter-url <get-request>
+ status-url <get-request>
twitter-request json>twitter-statuses ;
PRIVATE>
! 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 ;
<calculator>
calculator-db <alloy>
main-responder set-global
- 8080 httpd ;
+ 8080 httpd drop ;
MAIN: run-calculator
<counter-app>
counter-db <alloy>
main-responder set-global
- 8080 httpd ;
+ 8080 httpd drop ;
MAIN: run-counter
! 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 ;
: run-ip-app ( -- )
<ip-app> main-responder set-global
- 8080 httpd ;
+ 8080 httpd drop ;
MAIN: run-ip-app
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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 <sqlite-db> [
+ init-mason-db
+
+ counter-value
+ increment-counter-value
+ increment-counter-value
+ ] with-db
+] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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: +upload+ "upload"
+CONSTANT: +finish+ "finish"
+
+CONSTANT: +dirty+ "status-dirty"
+CONSTANT: +error+ "status-error"
+CONSTANT: +clean+ "status-clean"
+
+TUPLE: builder
+host-name os cpu heartbeat-timestamp
+clean-git-id clean-timestamp
+last-release release-git-id
+last-git-id last-timestamp last-report
+current-git-id current-timestamp
+status ;
+
+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 }
+
+ { "current-git-id" "CURRENT_GIT_ID" TEXT }
+ ! Can't name it CURRENT_TIMESTAMP because of bug in db library
+ { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
+ { "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" <sqlite-db> ;
+
+: with-mason-db ( quot -- )
+ mason-db [ with-transaction ] with-db ; inline
+
+: init-mason-db ( -- )
+ { builder counter } ensure-tables ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 <li><-></li> XML] ] map
+ <XML
+ <html>
+ <body>
+ <p>Machines which are not sending heartbeats:</p>
+ <ul><-></ul>
+ <a href="http://builds.factorcode.org/dashboard">Dashboard</a>
+ </body>
+ </html>
+ 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 ;
--- /dev/null
+! 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
+
+: <counter-action> ( -- action )
+ <action>
+ [
+ [
+ counter-value number>string
+ "text/plain" <content>
+ ] with-mason-db
+ ] >>display ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Mason dashboard</t:title>
+
+ <h1>Crashed build machines</h1>
+ <p>Machines which are not sending heartbeats:</p>
+ <t:xml t:name="crashed" />
+
+ <h1>Broken build machines</h1>
+ <p>Machines with failing builds:</p>
+ <t:xml t:name="broken" />
+
+ <h1>Force build now</h1>
+ <p>Requires build engineer status.</p>
+
+ <t:form t:action="$mason-app/dashboard/increment-counter">
+ <p><button type="submit">Increment counter</button></p>
+ </t:form>
+
+ <h1>Make a release</h1>
+ <p>Requires build engineer status.</p>
+
+ <t:form t:action="$mason-app/dashboard/make-release">
+ <table>
+ <tr><td>Version:</td><td><t:field t:name="version" /></td></tr>
+ <tr><td>Announcement URL:</td><td><t:field t:name="announcement-url" /></td></tr>
+ </table>
+
+ <p><button type="submit">Go</button></p>
+ </t:form>
+</t:chloe>
--- /dev/null
+! 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 <li><a href=<->><-></a></li> XML]
+ ] map
+ [ [XML <p>No machines.</p> XML] ]
+ [ [XML <ul><-></ul> XML] ]
+ if-empty ;
+
+: <dashboard-action> ( -- action )
+ <page-action>
+ [
+ [
+ funny-builders
+ [ builder-list ] tri@
+ [ "crashed" set-value ]
+ [ "broken" set-value ] bi*
+ ] with-mason-db
+ ] >>init ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
+
+: <docs-update-action> ( -- action )
+ <action>
+ [ validate-secret ] >>validate
+ [
+ [ update-docs ] "Documentation update" spawn drop
+ "OK" "text/plain" <content>
+ ] >>submit ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-<html xmlns="http://www.w3.org/1999/xhtml">
- <head>
- <link rel="stylesheet" href="http://factorcode.org/css/master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <title>Factor binary package for <t:label t:name="platform" /></title>
- </head>
- <body>
- <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
+ <t:title>Factor binary package for <t:label t:name="platform" /></t:title>
- <h1>Factor binary package for <t:label t:name="platform" /></h1>
+ <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
- <p>Requirements:</p>
- <t:xml t:name="requirements" />
+ <h1>Factor binary package for <t:label t:name="platform" /></h1>
- <h2>Download <t:xml t:name="package" /></h2>
+ <p>Requirements:</p>
+ <t:xml t:name="requirements" />
- <p>This package was built from GIT ID <t:xml t:name="git-id" />.</p>
+ <h2>Download <t:xml t:name="package" /></h2>
- <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Getting started">get started</a> with the language.</p>
+ <p>This package was built from GIT ID <t:xml t:name="git-id" />.</p>
- <h1>Build machine information</h1>
+ <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Learning">start learning</a> the language!</p>
- <table border="1">
- <tr><td>Host name:</td><td><t:xml t:name="host-name" /></td></tr>
- <tr><td>Last heartbeat:</td><td><t:label t:name="current-timestamp" /></td></tr>
- <tr><td>Current status:</td><td><t:xml t:name="status" /></td></tr>
- <tr><td>Last build:</td><td><t:xml t:name="last-build" /></td></tr>
- <tr><td>Last clean build:</td><td><t:xml t:name="last-clean-build" /></td></tr>
- <tr><td>Binaries:</td><td><t:xml t:name="binaries" /></td></tr>
- <tr><td>Clean images:</td><td><t:xml t:name="clean-images" /></td></tr>
- </table>
+ <h1>Build machine information</h1>
- <p><t:xml t:name="last-report" /></p>
- </body>
-</html>
+ <table border="1">
+ <tr><td>Host name:</td><td><t:xml t:name="host-name" /></td></tr>
+ <tr><td>Last heartbeat:</td><td><t:label t:name="heartbeat-timestamp" /></td></tr>
+ <tr><td>Current status:</td><td><t:xml t:name="status" /></td></tr>
+ <tr><td>Last build:</td><td><t:xml t:name="last-build" /></td></tr>
+ <tr><td>Last clean build:</td><td><t:xml t:name="last-clean-build" /></td></tr>
+ <tr><td>Binaries:</td><td><t:xml t:name="binaries" /></td></tr>
+ <tr><td>Clean images:</td><td><t:xml t:name="clean-images" /></td></tr>
+ </table>
+
+ <p><t:xml t:name="last-report" /></p>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-<html xmlns="http://www.w3.org/1999/xhtml">
- <head>
- <link rel="stylesheet" href="http://factorcode.org/css/master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
- <title>Factor binary package for <t:label t:name="platform" /></title>
- </head>
- <body>
- <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
+ <t:title>Factor binary package for <t:label t:name="platform" /></t:title>
- <h1>Factor binary package for <t:label t:name="platform" /></h1>
+ <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
- <p>Requirements:</p>
- <t:xml t:name="requirements" />
+ <h1>Factor binary package for <t:label t:name="platform" /></h1>
- <h2>Download <t:xml t:name="release" /></h2>
+ <p>Requirements:</p>
+ <t:xml t:name="requirements" />
- <p>This release was built from GIT ID <t:xml t:name="git-id" />.</p>
+ <h2>Download <t:xml t:name="release" /></h2>
- <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Getting started">get started</a> with the language.</p>
- </body>
-</html>
+ <p>This release was built from GIT ID <t:xml t:name="git-id" />.</p>
+
+ <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Learning">start learning</a> the language!</p>
</t:chloe>
-<?xml version='1.0' ?>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<h2>Stable release: <t:link t:name="stable-release" /></h2>
<t:xml t:name="package-grid" />
</table>
+<p>Stable and development releases are built and uploaded by the <a href="http://concatenative.org/wiki/view/Factor/Build farm">build farm</a>. Follow <a href="http://twitter.com/FactorBuilds">@FactorBuilds</a> on Twitter to receive notifications. If you're curious, take a look at the <t:a t:href="$mason-app/dashboard">build farm dashboard</t:a>.</p>
+
</t:chloe>
! 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 )
! 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 )
{
{ "x86.32" "x86" }
{ "x86.64" "x86-64" }
- { "ppc" "PowerPC" }
}
: render-grid-header ( -- xml )
</table>
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* ;
] 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 ;
--- /dev/null
+! 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
+
+: <increment-counter-action> ( -- action )
+ <action>
+ [
+ [
+ increment-counter-value
+ number>string "text/plain" <content>
+ ] with-mason-db
+ ] >>submit ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
- <head>
- <title>Make release</title>
- </head>
- <body>
- <t:form t:action="$mason-app/make-release">
- <table>
- <tr><td>Version:</td><td><t:field t:name="version" /></td></tr>
- <tr><td>Announcement URL:</td><td><t:field t:name="announcement-url" /></td></tr>
- </table>
-
- <p><button type="submit">Go</button></p>
- </t:form>
- </body>
-</html>
-
-</t:chloe>
! 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
: <make-release-action> ( -- action )
- <page-action>
+ <action>
[
{
{ "version" [ v-one-line ] }
! 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
+
+: <mason-protected> ( responder -- responder' )
+ <protected>
+ "access the build farm dashboard" >>description
+ { build-engineer? } >>capabilities ;
: <mason-app> ( -- dispatcher )
mason-app new-dispatcher
{ mason-app "downloads" } >>template
"downloads" add-responder
- <make-release-action>
- { mason-app "make-release" } >>template
- <protected>
- "make releases" >>description
- { can-make-releases? } >>capabilities
- "make-release" add-responder
-
<status-update-action>
- "status-update" add-responder ;
+ "status-update" add-responder
+
+ <docs-update-action>
+ "docs-update" add-responder
+
+ <counter-action>
+ "counter" add-responder
+
+ <dispatcher>
+ <dashboard-action>
+ { mason-app "dashboard" } >>template
+ "" add-responder
+
+ <make-release-action> <mason-protected>
+ "make-release" add-responder
+
+ <increment-counter-action> <mason-protected>
+ "increment-counter" add-responder
+
+ "dashboard" add-responder ;
! 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 )
: 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 ;
[ 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 ]
! 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 )
! 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
: <build-report-action> ( -- action )
! 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 ;
+
+: status ( builder status -- )
+ >>status
+ now >>current-timestamp
+ drop ;
+
+: idle ( builder -- ) +idle+ status ;
-: make-vm ( builder -- ) +make-vm+ >>status drop ;
+: git-id ( builder id -- ) >>current-git-id +starting+ status ;
-: boot ( builder -- ) +boot+ >>status drop ;
+: make-vm ( builder -- ) +make-vm+ status ;
-: test ( builder -- ) +test+ >>status drop ;
+: boot ( builder -- ) +boot+ status ;
-: report ( builder status content -- )
- [ >>status ] [ >>last-report ] bi*
- dup status>> +clean+ = [
+: 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
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
: 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 ;
{ "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" <content>
- ] if-secure
+ "host-name" value
+ "target-os" value
+ "target-cpu" value
+ find-builder
+ [ update-builder ] [ update-tuple ] bi
+ ] with-mason-db
+ "OK" "text/plain" <content>
] >>submit ;
! 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 )
: 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 ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io kernel make sequences webapps.mason.version.common
+webapps.mason.version.files ;
+IN: webapps.mason.version.binary
+
+: binary-release-command ( version builder -- command )
+ [
+ "cp " %
+ [ nip binary-package-name % " " % ]
+ [ remote-binary-release-name % ]
+ 2bi
+ ] "" make ;
+
+: binary-release-script ( version builders -- string )
+ [ binary-release-command ] with map "\n" join ;
+
+: do-binary-release ( version builders -- )
+ "Copying binary releases to release directory..." print flush
+ binary-release-script execute-on-server ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar io io.encodings.ascii io.launcher
+kernel make mason.config namespaces ;
+IN: webapps.mason.version.common
+
+: execute-on-server ( string -- )
+ [ "ssh" , upload-host get , "-l" , upload-username get , ] { } make
+ <process>
+ swap >>command
+ 5 minutes >>timeout
+ ascii [ write ] with-process-writer ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar db db.tuples db.types kernel locals
+webapps.mason.version.files sequences ;
+IN: webapps.mason.version.data
+
+TUPLE: release
+host-name os cpu
+last-release release-git-id ;
+
+release "RELEASES" {
+ { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
+ { "os" "OS" TEXT +user-assigned-id+ }
+ { "cpu" "CPU" TEXT +user-assigned-id+ }
+ { "last-release" "LAST_RELEASE" TEXT }
+ { "release-git-id" "RELEASE_GIT_ID" TEXT }
+} define-persistent
+
+:: <release> ( version builder -- release )
+ release new
+ builder host-name>> >>host-name
+ builder os>> >>os
+ builder cpu>> >>cpu
+ builder release-git-id>> >>release-git-id
+ version builder binary-release-name >>last-release ;
+
+: update-binary-releases ( version builders -- )
+ [
+ release new delete-tuples
+ [ <release> insert-tuple ] with each
+ ] with-transaction ;
+
+TUPLE: version
+id version git-id timestamp source-path announcement-url ;
+
+version "VERSIONS" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "version" "VERSION" TEXT }
+ { "git-id" "GIT_ID" TEXT }
+ { "timestamp" "TIMESTAMP" TIMESTAMP }
+ { "source-path" "SOURCE_PATH" TEXT }
+ { "announcement-url" "ANNOUNCEMENT_URL" TEXT }
+} define-persistent
+
+: update-version ( version git-id announcement-url -- )
+ version new
+ swap >>announcement-url
+ swap >>git-id
+ swap [ >>version ] [ source-release-name >>source-path ] bi
+ now >>timestamp
+ insert-tuple ;
+
+: latest-version ( -- version )
+ version new select-tuples last ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry kernel make mason.config mason.platform
+mason.release.archive namespaces sequences ;
+IN: webapps.mason.version.files
+
+: release-directory ( string version -- string )
+ [ "releases/" % % "/" % % ] "" make ;
+
+: remote-directory ( string -- string' )
+ [ upload-directory get ] dip "/" glue ;
+
+SLOT: os
+SLOT: cpu
+
+: platform ( builder -- string )
+ [ os>> ] [ cpu>> ] bi (platform) ;
+
+: binary-package-name ( builder -- string )
+ [ [ platform % "/" % ] [ last-release>> % ] bi ] "" make
+ remote-directory ;
+
+: binary-release-name ( version builder -- string )
+ [
+ [
+ [ "factor-" % platform % "-" % % ]
+ [ os>> extension % ]
+ bi
+ ] "" make
+ ] [ drop ] 2bi release-directory ;
+
+: remote-binary-release-name ( version builder -- string )
+ binary-release-name remote-directory ;
+
+: source-release-name ( version -- string )
+ [ "factor-src-" ".zip" surround ] keep release-directory ;
+
+: remote-source-release-name ( version -- string )
+ source-release-name remote-directory ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! 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 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 ;
+
+: git-reset ( git-id -- )
+ { "git" "reset" "--hard" } swap suffix try-process ;
+
+: save-git-id ( git-id -- )
+ "git-id" to-file ;
+
+: delete-git-tree ( -- )
+ ".git" delete-tree
+ ".gitignore" delete-file ;
+
+: download-images ( -- )
+ images [ boot-image-name download-image ] each ;
+
+: prepare-source ( git-id -- )
+ "factor" [
+ [ git-reset ] [ save-git-id ] bi
+ delete-git-tree
+ download-images
+ ] with-directory ;
+
+: (make-source-release) ( version -- path )
+ [ { "zip" "-qr9" } ] dip source-release-name file-name
+ [ suffix "factor" suffix try-process ] keep ;
+
+: make-source-release ( version git-id -- path )
+ "Creating source release..." print flush
+ [
+ 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 -- )
+ "Uploading source release..." print flush
+ [ upload-username get upload-host get ] dip
+ remote-source-release-name
+ upload-safely ;
+
+: do-source-release ( version git-id -- )
+ [ make-source-release ] [ drop upload-source-release ] 2bi ;
--- /dev/null
+! 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 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?
+ [ "Some builders are out of date" throw ] unless ;
+
+: make-release-directory ( version -- )
+ "Creating release directory..." print flush
+ [ "mkdir -p " % "" release-directory remote-directory % "\n" % ] "" make
+ execute-on-server ;
+
+: tweet-release ( version announcement-url -- )
+ [
+ "Factor " %
+ [ % " released -- " % ] [ shorten-url % ] bi*
+ ] "" make mason-tweet ;
+
+:: (do-release) ( version announcement-url -- )
+ [
+ builder new select-tuples :> builders
+ builders first release-git-id>> :> git-id
+
+ builders check-releases
+ version make-release-directory
+ version builders do-binary-release
+ version builders update-binary-releases
+ version git-id do-source-release
+ version git-id announcement-url update-version
+ version announcement-url tweet-release
+
+ "Done." print flush
+ ] with-mason-db ;
+
+: send-release-email ( string version -- )
+ [ "text/plain" ] dip "Release output: " prepend mason-email ;
+
+:: do-release ( version announcement-url -- )
+ [
+ [
+ [
+ version announcement-url (do-release)
+ ] try
+ ] with-string-writer
+ version send-release-email
+ ] "Mason release" spawn drop ;
: start-site-watcher ( -- )
init-db
site-watcher-db run-site-watcher
- <site-watcher-server> start-server ;
+ <site-watcher-server> start-server drop ;
: run-todo ( -- )
<todo-app> main-responder set-global
todo-db start-expiring
- <todo-website-server> start-server ;
+ <todo-website-server> start-server drop ;
MAIN: run-todo
! 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
"administer users" >>description
{ can-administer-users? } >>capabilities ;
-: make-admin ( username -- )
- <user>
- select-tuple
- [ can-administer-users? suffix ] change-capabilities
+: give-capability ( username capability -- )
+ [ <user> select-tuple ] dip
+ '[ _ suffix ] change-capabilities
update-tuple ;
+
+: make-admin ( username -- )
+ can-administer-users? give-capability ;
[ list-revisions ] >>entries ;
: rollback-description ( description -- description' )
- [ "Rollback of '" "'" surround ] [ "Rollback" ] if* ;
+ [ "Rollback to '" "'" surround ] [ "Rollback" ] if* ;
: <rollback-action> ( -- action )
<action>
webapps.wiki
webapps.user-admin
webapps.help
-webapps.mason ;
+webapps.mason
+webapps.mason.backend ;
IN: websites.concatenative
: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
: init-factor-db ( -- )
+ mason-db [ init-mason-db ] with-db
+
test-db [
init-furnace-tables
<user-admin> <login-config> <factor-boilerplate> "user-admin" add-responder
<pastebin> <factor-recaptcha> <login-config> <factor-boilerplate> "pastebin" add-responder
<planet> <login-config> <factor-boilerplate> "planet" add-responder
- <mason-app> <login-config> "mason" add-responder
+ <mason-app> <login-config> <factor-boilerplate> "mason" add-responder
"/tmp/docs/" <help-webapp> "docs" add-responder
test-db <alloy>
main-responder set-global ;
<login-config> <factor-boilerplate> test-db <alloy> "concatenative.org" add-responder
<pastebin> <factor-recaptcha> <login-config> <factor-boilerplate> test-db <alloy> "paste.factorcode.org" add-responder
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
- <mason-app> <login-config> test-db <alloy> "builds.factorcode.org" add-responder
+ <mason-app> <login-config>
<factor-boilerplate> test-db <alloy> "builds.factorcode.org" add-responder
home "docs" append-path <help-webapp> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
main-responder set-global ;
8080 >>insecure
8431 >>secure ;
-: start-website ( -- )
+: start-website ( -- server )
test-db start-expiring
test-db start-update-task
http-insomniac
* Quick key reference
Triple chords ending in a single letter <x> accept also C-<x> (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 <command>, 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):
| 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 |
| 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 |
|-----------+----------------------------------------------------------|
;;; 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 <jao@gnu.org>
(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))
;;; 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 <jao@gnu.org>
(require 'fuel-eval)
(require 'fuel-popup)
(require 'fuel-font-lock)
+(require 'fuel-menu)
(require 'fuel-base)
\f
(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)
`(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.
;;; 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 <jao@gnu.org>
(require 'fuel-syntax)
(require 'fuel-font-lock)
(require 'fuel-popup)
+(require 'fuel-menu)
(require 'fuel-base)
(require 'button)
(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))
+
\f
;;; IN: support
;;; 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 <jao@gnu.org>
(require 'fuel-eval)
(require 'fuel-connection)
(require 'fuel-syntax)
+(require 'fuel-menu)
(require 'fuel-base)
(require 'comint)
: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)
+
\f
;;; Listener history:
(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))
\f
;;; Fuel listener buffer/process:
"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)
\f
(provide 'fuel-listener)
--- /dev/null
+;;; 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 <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sat Jun 12, 2010 03:01
+\f
+
+(require 'fuel-base)
+
+\f
+;;; 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)
+
+
+\f
+(provide 'fuel-menu)
+;;; fuel-menu.el ends here
+
;;; 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 <jao@gnu.org>
(require 'fuel-font-lock)
(require 'fuel-edit)
(require 'fuel-syntax)
+(require 'fuel-menu)
(require 'fuel-base)
\f
(fuel-scaffold--maybe-insert))))
\f
-;;; Keys:
-
-(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)
+;;; Keys and menu:
+
+(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)))
\f
(provide 'fuel-mode)
;;; 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 <jao@gnu.org>
(require 'fuel-syntax)
(require 'fuel-popup)
(require 'fuel-font-lock)
+(require 'fuel-menu)
(require 'fuel-base)
(require 'button)
(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))
\f
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-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 <win32-file> ] 3apply
- [ <input-port> ] [ <output-port> ] [ <output-port> ] tri*
- ] with-variable ;
+++ /dev/null
-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
+++ /dev/null
-Doug Coleman
-Slava Pestov
+++ /dev/null
-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 ;
+++ /dev/null
-IN: io.windows.ce.privileges\r
-USING: io.windows.privileges system ;\r
-\r
-M: wince set-privilege 2drop ;\r
+++ /dev/null
-Doug Coleman
-Slava Pestov
+++ /dev/null
-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 <win32-socket> dup <ports> ;
-
-M: wince (server) ( addrspec -- handle )
- windows.winsock:SOCK_STREAM server-fd
- dup listen-on-socket
- <win32-socket> ;
-
-M: wince (accept) ( server -- client )
- [
- [
- dup port-handle win32-file-handle
- swap server-port-addr sockaddr-type heap-size
- dup <byte-array> [
- swap <int> f 0
- windows.winsock:WSAAccept
- dup windows.winsock:INVALID_SOCKET =
- [ windows.winsock:winsock-error ] when
- ] keep
- ] keep server-port-addr parse-sockaddr swap
- <win32-socket> <ports>
- ] with-timeout ;
-
-M: wince <datagram> ( addrspec -- datagram )
- [
- windows.winsock:SOCK_DGRAM server-fd <win32-socket>
- ] keep <datagram-port> ;
-
-: 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" <c-object>
- [ 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 <byte-array> receive-buffer set-global
-
-M: wince receive ( datagram -- packet addrspec )
- dup check-datagram-port
- [
- port-handle win32-file-handle
- receive-WSABUF
- 1
- 0 <uint> [
- 0 <uint>
- 64 "char" <c-array> [
- 64 <int>
- 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 <uint> 0 r> r> f f
- windows.winsock:WSASendTo
- windows.winsock:winsock-error!=0/f ;
+++ /dev/null
-Microsoft Windows CE native I/O implementation
--- /dev/null
+Hans Schmid
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: math.transforms.fft
+
+HELP: fft
+{ $values { "seq" sequence } { "seq'" sequence } }
+{ $description "Fast Fourier transform function." } ;
+
--- /dev/null
+! Copyright (c) 2007 Hans Schmid.
+! See http://factorcode.org/license.txt for BSD license.
+USING: columns grouping kernel math math.constants math.functions math.vectors
+ sequences ;
+IN: math.transforms.fft
+
+! Fast Fourier Transform
+
+<PRIVATE
+
+: n^v ( n v -- w ) [ ^ ] with map ;
+
+: omega ( n -- n' )
+ recip -2 pi i* * * exp ;
+
+: twiddle ( seq -- seq' )
+ dup length [ omega ] [ n^v ] bi v* ;
+
+PRIVATE>
+
+DEFER: fft
+
+: two ( seq -- seq' )
+ fft 2 v/n dup append ;
+
+<PRIVATE
+
+: even ( seq -- seq' ) 2 group 0 <column> ;
+: odd ( seq -- seq' ) 2 group 1 <column> ;
+
+: (fft) ( seq -- seq' )
+ [ odd two twiddle ] [ even two ] bi v+ ;
+
+PRIVATE>
+
+: fft ( seq -- seq' )
+ dup length 1 = [ (fft) ] unless ;
+
--- /dev/null
+Fast fourier transform
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007, 2010 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: bootstrap.image.private kernel kernel.private namespaces\r
+system cpu.ppc.assembler compiler.units compiler.constants math\r
+math.private math.ranges layouts words vocabs slots.private\r
+locals locals.backend generic.single.private fry sequences\r
+threads.private strings.private ;\r
+FROM: cpu.ppc.assembler => B ;\r
+IN: bootstrap.ppc\r
+\r
+4 \ cell set\r
+big-endian on\r
+\r
+CONSTANT: ds-reg 13\r
+CONSTANT: rs-reg 14\r
+CONSTANT: vm-reg 15\r
+CONSTANT: ctx-reg 16\r
+CONSTANT: nv-reg 17\r
+\r
+: jit-call ( string -- )\r
+ 0 2 LOAD32 rc-absolute-ppc-2/2 jit-dlsym\r
+ 2 MTLR\r
+ BLRL ;\r
+\r
+: jit-call-quot ( -- )\r
+ 4 3 quot-entry-point-offset LWZ\r
+ 4 MTLR\r
+ BLRL ;\r
+\r
+: jit-jump-quot ( -- )\r
+ 4 3 quot-entry-point-offset LWZ\r
+ 4 MTCTR\r
+ BCTR ;\r
+\r
+: factor-area-size ( -- n ) 16 ;\r
+\r
+: stack-frame ( -- n )\r
+ reserved-size\r
+ factor-area-size +\r
+ 16 align ;\r
+\r
+: next-save ( -- n ) stack-frame 4 - ;\r
+: xt-save ( -- n ) stack-frame 8 - ;\r
+\r
+: param-size ( -- n ) 32 ;\r
+\r
+: save-at ( m -- n ) reserved-size + param-size + ;\r
+\r
+: save-int ( register offset -- ) [ 1 ] dip save-at STW ;\r
+: restore-int ( register offset -- ) [ 1 ] dip save-at LWZ ;\r
+\r
+: save-fp ( register offset -- ) [ 1 ] dip save-at STFD ;\r
+: restore-fp ( register offset -- ) [ 1 ] dip save-at LFD ;\r
+\r
+: save-vec ( register offset -- ) save-at 2 LI 2 1 STVXL ;\r
+: restore-vec ( register offset -- ) save-at 2 LI 2 1 LVXL ;\r
+\r
+: nv-int-regs ( -- seq ) 13 31 [a,b] ;\r
+: nv-fp-regs ( -- seq ) 14 31 [a,b] ;\r
+: nv-vec-regs ( -- seq ) 20 31 [a,b] ;\r
+\r
+: saved-int-regs-size ( -- n ) 96 ;\r
+: saved-fp-regs-size ( -- n ) 144 ;\r
+: saved-vec-regs-size ( -- n ) 208 ;\r
+\r
+: callback-frame-size ( -- n )\r
+ reserved-size\r
+ param-size +\r
+ saved-int-regs-size +\r
+ saved-fp-regs-size +\r
+ saved-vec-regs-size +\r
+ 4 +\r
+ 16 align ;\r
+\r
+: old-context-save-offset ( -- n )\r
+ 432 save-at ;\r
+\r
+[\r
+ ! Save old stack pointer\r
+ 11 1 MR\r
+\r
+ ! Create stack frame\r
+ 0 MFLR\r
+ 1 1 callback-frame-size SUBI\r
+ 0 1 callback-frame-size lr-save + STW\r
+\r
+ ! Save all non-volatile registers\r
+ nv-int-regs [ 4 * save-int ] each-index\r
+ nv-fp-regs [ 8 * 80 + save-fp ] each-index\r
+ nv-vec-regs [ 16 * 224 + save-vec ] each-index\r
+\r
+ ! Stick old stack pointer in a non-volatile register so that\r
+ ! callbacks can access their arguments\r
+ nv-reg 11 MR\r
+\r
+ ! Load VM into vm-reg\r
+ 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
+\r
+ ! Save old context\r
+ 2 vm-reg vm-context-offset LWZ\r
+ 2 1 old-context-save-offset STW\r
+\r
+ ! Switch over to the spare context\r
+ 2 vm-reg vm-spare-context-offset LWZ\r
+ 2 vm-reg vm-context-offset STW\r
+\r
+ ! Save C callstack pointer\r
+ 1 2 context-callstack-save-offset STW\r
+\r
+ ! Load Factor callstack pointer\r
+ 1 2 context-callstack-bottom-offset LWZ\r
+\r
+ ! Call into Factor code\r
+ 0 2 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel\r
+ 2 MTLR\r
+ BLRL\r
+\r
+ ! Load VM again, pointlessly\r
+ 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
+\r
+ ! Load C callstack pointer\r
+ 2 vm-reg vm-context-offset LWZ\r
+ 1 2 context-callstack-save-offset LWZ\r
+\r
+ ! Load old context\r
+ 2 1 old-context-save-offset LWZ\r
+ 2 vm-reg vm-context-offset STW\r
+\r
+ ! Restore non-volatile registers\r
+ nv-vec-regs [ 16 * 224 + restore-vec ] each-index\r
+ nv-fp-regs [ 8 * 80 + restore-fp ] each-index\r
+ nv-int-regs [ 4 * restore-int ] each-index\r
+\r
+ ! Tear down stack frame and return\r
+ 0 1 callback-frame-size lr-save + LWZ\r
+ 1 1 callback-frame-size ADDI\r
+ 0 MTLR\r
+ BLR\r
+] callback-stub jit-define\r
+\r
+: jit-conditional* ( test-quot false-quot -- )\r
+ [ '[ 4 /i 1 + @ ] ] dip jit-conditional ; inline\r
+\r
+: jit-load-context ( -- )\r
+ ctx-reg vm-reg vm-context-offset LWZ ;\r
+\r
+: jit-save-context ( -- )\r
+ jit-load-context\r
+ 1 ctx-reg context-callstack-top-offset STW\r
+ ds-reg ctx-reg context-datastack-offset STW\r
+ rs-reg ctx-reg context-retainstack-offset STW ;\r
+\r
+: jit-restore-context ( -- )\r
+ ds-reg ctx-reg context-datastack-offset LWZ\r
+ rs-reg ctx-reg context-retainstack-offset LWZ ;\r
+\r
+[\r
+ 0 12 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
+ 11 12 profile-count-offset LWZ\r
+ 11 11 1 tag-fixnum ADDI\r
+ 11 12 profile-count-offset STW\r
+ 11 12 word-code-offset LWZ\r
+ 11 11 compiled-header-size ADDI\r
+ 11 MTCTR\r
+ BCTR\r
+] jit-profiling jit-define\r
+\r
+[\r
+ 0 2 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
+ 0 MFLR\r
+ 1 1 stack-frame SUBI\r
+ 2 1 xt-save STW\r
+ stack-frame 2 LI\r
+ 2 1 next-save STW\r
+ 0 1 lr-save stack-frame + STW\r
+] jit-prolog jit-define\r
+\r
+[\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
+ 3 ds-reg 4 STWU\r
+] jit-push jit-define\r
+\r
+[\r
+ jit-save-context\r
+ 3 vm-reg MR\r
+ 0 4 LOAD32 rc-absolute-ppc-2/2 rt-dlsym jit-rel\r
+ 4 MTLR\r
+ BLRL\r
+ jit-restore-context\r
+] jit-primitive jit-define\r
+\r
+[ 0 BL rc-relative-ppc-3 rt-entry-point-pic jit-rel ] jit-word-call jit-define\r
+\r
+[\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel\r
+ 0 B rc-relative-ppc-3 rt-entry-point-pic-tail jit-rel\r
+] jit-word-jump jit-define\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 0 3 \ f type-number CMPI\r
+ [ BEQ ] [ 0 B rc-relative-ppc-3 rt-entry-point jit-rel ] jit-conditional*\r
+ 0 B rc-relative-ppc-3 rt-entry-point jit-rel\r
+] jit-if jit-define\r
+\r
+: jit->r ( -- )\r
+ 4 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 4 rs-reg 4 STWU ;\r
+\r
+: jit-2>r ( -- )\r
+ 4 ds-reg 0 LWZ\r
+ 5 ds-reg -4 LWZ\r
+ ds-reg dup 8 SUBI\r
+ rs-reg dup 8 ADDI\r
+ 4 rs-reg 0 STW\r
+ 5 rs-reg -4 STW ;\r
+\r
+: jit-3>r ( -- )\r
+ 4 ds-reg 0 LWZ\r
+ 5 ds-reg -4 LWZ\r
+ 6 ds-reg -8 LWZ\r
+ ds-reg dup 12 SUBI\r
+ rs-reg dup 12 ADDI\r
+ 4 rs-reg 0 STW\r
+ 5 rs-reg -4 STW\r
+ 6 rs-reg -8 STW ;\r
+\r
+: jit-r> ( -- )\r
+ 4 rs-reg 0 LWZ\r
+ rs-reg dup 4 SUBI\r
+ 4 ds-reg 4 STWU ;\r
+\r
+: jit-2r> ( -- )\r
+ 4 rs-reg 0 LWZ\r
+ 5 rs-reg -4 LWZ\r
+ rs-reg dup 8 SUBI\r
+ ds-reg dup 8 ADDI\r
+ 4 ds-reg 0 STW\r
+ 5 ds-reg -4 STW ;\r
+\r
+: jit-3r> ( -- )\r
+ 4 rs-reg 0 LWZ\r
+ 5 rs-reg -4 LWZ\r
+ 6 rs-reg -8 LWZ\r
+ rs-reg dup 12 SUBI\r
+ ds-reg dup 12 ADDI\r
+ 4 ds-reg 0 STW\r
+ 5 ds-reg -4 STW\r
+ 6 ds-reg -8 STW ;\r
+\r
+[\r
+ jit->r\r
+ 0 BL rc-relative-ppc-3 rt-entry-point jit-rel\r
+ jit-r>\r
+] jit-dip jit-define\r
+\r
+[\r
+ jit-2>r\r
+ 0 BL rc-relative-ppc-3 rt-entry-point jit-rel\r
+ jit-2r>\r
+] jit-2dip jit-define\r
+\r
+[\r
+ jit-3>r\r
+ 0 BL rc-relative-ppc-3 rt-entry-point jit-rel\r
+ jit-3r>\r
+] jit-3dip jit-define\r
+\r
+[\r
+ 0 1 lr-save stack-frame + LWZ\r
+ 1 1 stack-frame ADDI\r
+ 0 MTLR\r
+] jit-epilog jit-define\r
+\r
+[ BLR ] jit-return jit-define\r
+\r
+! ! ! Polymorphic inline caches\r
+\r
+! Don't touch r6 here; it's used to pass the tail call site\r
+! address for tail PICs\r
+\r
+! Load a value from a stack position\r
+[\r
+ 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel\r
+] pic-load jit-define\r
+\r
+[ 4 4 tag-mask get ANDI ] pic-tag jit-define\r
+\r
+[\r
+ 3 4 MR\r
+ 4 4 tag-mask get ANDI\r
+ 0 4 tuple type-number CMPI\r
+ [ BNE ]\r
+ [ 4 3 tuple-class-offset LWZ ]\r
+ jit-conditional*\r
+] pic-tuple jit-define\r
+\r
+[\r
+ 0 4 0 CMPI rc-absolute-ppc-2 rt-untagged jit-rel\r
+] pic-check-tag jit-define\r
+\r
+[\r
+ 0 5 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
+ 4 0 5 CMP\r
+] pic-check-tuple jit-define\r
+\r
+[\r
+ [ BNE ] [ 0 B rc-relative-ppc-3 rt-entry-point jit-rel ] jit-conditional*\r
+] pic-hit jit-define\r
+\r
+! Inline cache miss entry points\r
+: jit-load-return-address ( -- ) 6 MFLR ;\r
+\r
+! These are always in tail position with an existing stack\r
+! frame, and the stack. The frame setup takes this into account.\r
+: jit-inline-cache-miss ( -- )\r
+ jit-save-context\r
+ 3 6 MR\r
+ 4 vm-reg MR\r
+ "inline_cache_miss" jit-call\r
+ jit-load-context\r
+ jit-restore-context ;\r
+\r
+[ jit-load-return-address jit-inline-cache-miss ]\r
+[ 3 MTLR BLRL ]\r
+[ 3 MTCTR BCTR ]\r
+\ inline-cache-miss define-combinator-primitive\r
+\r
+[ jit-inline-cache-miss ]\r
+[ 3 MTLR BLRL ]\r
+[ 3 MTCTR BCTR ]\r
+\ inline-cache-miss-tail define-combinator-primitive\r
+\r
+! ! ! Megamorphic caches\r
+\r
+[\r
+ ! class = ...\r
+ 3 4 MR\r
+ 4 4 tag-mask get ANDI\r
+ 4 4 tag-bits get SLWI\r
+ 0 4 tuple type-number tag-fixnum CMPI\r
+ [ BNE ]\r
+ [ 4 3 tuple-class-offset LWZ ]\r
+ jit-conditional*\r
+ ! cache = ...\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
+ ! key = hashcode(class)\r
+ 5 4 1 SRAWI\r
+ ! key &= cache.length - 1\r
+ 5 5 mega-cache-size get 1 - 4 * ANDI\r
+ ! cache += array-start-offset\r
+ 3 3 array-start-offset ADDI\r
+ ! cache += key\r
+ 3 3 5 ADD\r
+ ! if(get(cache) == class)\r
+ 6 3 0 LWZ\r
+ 6 0 4 CMP\r
+ [ BNE ]\r
+ [\r
+ ! megamorphic_cache_hits++\r
+ 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel\r
+ 5 4 0 LWZ\r
+ 5 5 1 ADDI\r
+ 5 4 0 STW\r
+ ! ... goto get(cache + 4)\r
+ 3 3 4 LWZ\r
+ 3 3 word-entry-point-offset LWZ\r
+ 3 MTCTR\r
+ BCTR\r
+ ]\r
+ jit-conditional*\r
+ ! fall-through on miss\r
+] mega-lookup jit-define\r
+\r
+! ! ! Sub-primitives\r
+\r
+! Quotations and words\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+]\r
+[ jit-call-quot ]\r
+[ jit-jump-quot ] \ (call) define-combinator-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 4 3 word-entry-point-offset LWZ\r
+]\r
+[ 4 MTLR BLRL ]\r
+[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 4 3 word-entry-point-offset LWZ\r
+ 4 MTCTR BCTR\r
+] jit-execute jit-define\r
+\r
+! Special primitives\r
+[\r
+ nv-reg 3 MR\r
+\r
+ 3 vm-reg MR\r
+ "begin_callback" jit-call\r
+\r
+ jit-load-context\r
+ jit-restore-context\r
+\r
+ ! Call quotation\r
+ 3 nv-reg MR\r
+ jit-call-quot\r
+\r
+ jit-save-context\r
+\r
+ 3 vm-reg MR\r
+ "end_callback" jit-call\r
+] \ c-to-factor define-sub-primitive\r
+\r
+[\r
+ ! Unwind stack frames\r
+ 1 4 MR\r
+\r
+ ! Load VM pointer into vm-reg, since we're entering from\r
+ ! C code\r
+ 0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm\r
+\r
+ ! Load ds and rs registers\r
+ jit-load-context\r
+ jit-restore-context\r
+\r
+ ! We have changed the stack; load return address again\r
+ 0 1 lr-save LWZ\r
+ 0 MTLR\r
+\r
+ ! Call quotation\r
+ jit-call-quot\r
+] \ unwind-native-frames define-sub-primitive\r
+\r
+[\r
+ ! Load callstack object\r
+ 6 ds-reg 0 LWZ\r
+ ds-reg ds-reg 4 SUBI\r
+ ! Get ctx->callstack_bottom\r
+ jit-load-context\r
+ 3 ctx-reg context-callstack-bottom-offset LWZ\r
+ ! Get top of callstack object -- 'src' for memcpy\r
+ 4 6 callstack-top-offset ADDI\r
+ ! Get callstack length, in bytes --- 'len' for memcpy\r
+ 5 6 callstack-length-offset LWZ\r
+ 5 5 tag-bits get SRAWI\r
+ ! Compute new stack pointer -- 'dst' for memcpy\r
+ 3 5 3 SUBF\r
+ ! Install new stack pointer\r
+ 1 3 MR\r
+ ! Call memcpy; arguments are now in the correct registers\r
+ 1 1 -64 STWU\r
+ "factor_memcpy" jit-call\r
+ 1 1 0 LWZ\r
+ ! Return with new callstack\r
+ 0 1 lr-save LWZ\r
+ 0 MTLR\r
+ BLR\r
+] \ set-callstack define-sub-primitive\r
+\r
+[\r
+ jit-save-context\r
+ 4 vm-reg MR\r
+ "lazy_jit_compile" jit-call\r
+]\r
+[ jit-call-quot ]\r
+[ jit-jump-quot ]\r
+\ lazy-jit-compile define-combinator-primitive\r
+\r
+! Objects\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 tag-mask get ANDI\r
+ 3 3 tag-bits get SLWI\r
+ 3 ds-reg 0 STW\r
+] \ tag define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZU\r
+ 3 3 2 SRAWI\r
+ 4 4 0 0 31 tag-bits get - RLWINM\r
+ 4 3 3 LWZX\r
+ 3 ds-reg 0 STW\r
+] \ slot define-sub-primitive\r
+\r
+[\r
+ ! load string index from stack\r
+ 3 ds-reg -4 LWZ\r
+ 3 3 tag-bits get SRAWI\r
+ ! load string from stack\r
+ 4 ds-reg 0 LWZ\r
+ ! load character\r
+ 4 4 string-offset ADDI\r
+ 3 3 4 LBZX\r
+ 3 3 tag-bits get SLWI\r
+ ! store character to stack\r
+ ds-reg ds-reg 4 SUBI\r
+ 3 ds-reg 0 STW\r
+] \ string-nth-fast define-sub-primitive\r
+\r
+! Shufflers\r
+[\r
+ ds-reg dup 4 SUBI\r
+] \ drop define-sub-primitive\r
+\r
+[\r
+ ds-reg dup 8 SUBI\r
+] \ 2drop define-sub-primitive\r
+\r
+[\r
+ ds-reg dup 12 SUBI\r
+] \ 3drop define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 ds-reg 4 STWU\r
+] \ dup define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg dup 8 ADDI\r
+ 3 ds-reg 0 STW\r
+ 4 ds-reg -4 STW\r
+] \ 2dup define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 5 ds-reg -8 LWZ\r
+ ds-reg dup 12 ADDI\r
+ 3 ds-reg 0 STW\r
+ 4 ds-reg -4 STW\r
+ 5 ds-reg -8 STW\r
+] \ 3dup define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 3 ds-reg 0 STW\r
+] \ nip define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 8 SUBI\r
+ 3 ds-reg 0 STW\r
+] \ 2nip define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg -4 LWZ\r
+ 3 ds-reg 4 STWU\r
+] \ over define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg -8 LWZ\r
+ 3 ds-reg 4 STWU\r
+] \ pick define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 4 ds-reg 0 STW\r
+ 3 ds-reg 4 STWU\r
+] \ dupd define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 3 ds-reg -4 STW\r
+ 4 ds-reg 0 STW\r
+] \ swap define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg -4 LWZ\r
+ 4 ds-reg -8 LWZ\r
+ 3 ds-reg -8 STW\r
+ 4 ds-reg -4 STW\r
+] \ swapd define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 5 ds-reg -8 LWZ\r
+ 4 ds-reg -8 STW\r
+ 3 ds-reg -4 STW\r
+ 5 ds-reg 0 STW\r
+] \ rot define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 5 ds-reg -8 LWZ\r
+ 3 ds-reg -8 STW\r
+ 5 ds-reg -4 STW\r
+ 4 ds-reg 0 STW\r
+] \ -rot define-sub-primitive\r
+\r
+[ jit->r ] \ load-local define-sub-primitive\r
+\r
+! Comparisons\r
+: jit-compare ( insn -- )\r
+ t jit-literal\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
+ 4 ds-reg 0 LWZ\r
+ 5 ds-reg -4 LWZU\r
+ 5 0 4 CMP\r
+ 2 swap execute( offset -- ) ! magic number\r
+ \ f type-number 3 LI\r
+ 3 ds-reg 0 STW ;\r
+\r
+: define-jit-compare ( insn word -- )\r
+ [ [ jit-compare ] curry ] dip define-sub-primitive ;\r
+\r
+\ BEQ \ eq? define-jit-compare\r
+\ BGE \ fixnum>= define-jit-compare\r
+\ BLE \ fixnum<= define-jit-compare\r
+\ BGT \ fixnum> define-jit-compare\r
+\ BLT \ fixnum< define-jit-compare\r
+\r
+! Math\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg ds-reg 4 SUBI\r
+ 4 ds-reg 0 LWZ\r
+ 3 3 4 OR\r
+ 3 3 tag-mask get ANDI\r
+ \ f type-number 4 LI\r
+ 0 3 0 CMPI\r
+ [ BNE ] [ 1 tag-fixnum 4 LI ] jit-conditional*\r
+ 4 ds-reg 0 STW\r
+] \ both-fixnums? define-sub-primitive\r
+\r
+: jit-math ( insn -- )\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZU\r
+ [ 5 3 4 ] dip execute( dst src1 src2 -- )\r
+ 5 ds-reg 0 STW ;\r
+\r
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive\r
+\r
+[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZU\r
+ 4 4 tag-bits get SRAWI\r
+ 5 3 4 MULLW\r
+ 5 ds-reg 0 STW\r
+] \ fixnum*fast define-sub-primitive\r
+\r
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive\r
+\r
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive\r
+\r
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 NOT\r
+ 3 3 tag-mask get XORI\r
+ 3 ds-reg 0 STW\r
+] \ fixnum-bitnot define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 tag-bits get SRAWI\r
+ ds-reg ds-reg 4 SUBI\r
+ 4 ds-reg 0 LWZ\r
+ 5 4 3 SLW\r
+ 6 3 NEG\r
+ 7 4 6 SRAW\r
+ 7 7 0 0 31 tag-bits get - RLWINM\r
+ 0 3 0 CMPI\r
+ [ BGT ] [ 5 7 MR ] jit-conditional*\r
+ 5 ds-reg 0 STW\r
+] \ fixnum-shift-fast define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg ds-reg 4 SUBI\r
+ 4 ds-reg 0 LWZ\r
+ 5 4 3 DIVW\r
+ 6 5 3 MULLW\r
+ 7 6 4 SUBF\r
+ 7 ds-reg 0 STW\r
+] \ fixnum-mod define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg ds-reg 4 SUBI\r
+ 4 ds-reg 0 LWZ\r
+ 5 4 3 DIVW\r
+ 5 5 tag-bits get SLWI\r
+ 5 ds-reg 0 STW\r
+] \ fixnum/i-fast define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 5 4 3 DIVW\r
+ 6 5 3 MULLW\r
+ 7 6 4 SUBF\r
+ 5 5 tag-bits get SLWI\r
+ 5 ds-reg -4 STW\r
+ 7 ds-reg 0 STW\r
+] \ fixnum/mod-fast define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 2 SRAWI\r
+ rs-reg 3 3 LWZX\r
+ 3 ds-reg 0 STW\r
+] \ get-local define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg ds-reg 4 SUBI\r
+ 3 3 2 SRAWI\r
+ rs-reg 3 rs-reg SUBF\r
+] \ drop-locals define-sub-primitive\r
+\r
+! Overflowing fixnum arithmetic\r
+:: jit-overflow ( insn func -- )\r
+ ds-reg ds-reg 4 SUBI\r
+ jit-save-context\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg 4 LWZ\r
+ 0 0 LI\r
+ 0 MTXER\r
+ 6 4 3 insn call( d a s -- )\r
+ 6 ds-reg 0 STW\r
+ [ BNO ]\r
+ [\r
+ 5 vm-reg MR\r
+ func jit-call\r
+ ]\r
+ jit-conditional* ;\r
+\r
+[ [ ADDO. ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive\r
+\r
+[ [ SUBFO. ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive\r
+\r
+[\r
+ ds-reg ds-reg 4 SUBI\r
+ jit-save-context\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 tag-bits get SRAWI\r
+ 4 ds-reg 4 LWZ\r
+ 0 0 LI\r
+ 0 MTXER\r
+ 6 3 4 MULLWO.\r
+ 6 ds-reg 0 STW\r
+ [ BNO ]\r
+ [\r
+ 4 4 tag-bits get SRAWI\r
+ 5 vm-reg MR\r
+ "overflow_fixnum_multiply" jit-call\r
+ ]\r
+ jit-conditional*\r
+] \ fixnum* define-sub-primitive\r
+\r
+! Contexts\r
+: jit-switch-context ( reg -- )\r
+ ! Save ds, rs registers\r
+ jit-save-context\r
+\r
+ ! Make the new context the current one\r
+ ctx-reg swap MR\r
+ ctx-reg vm-reg vm-context-offset STW\r
+\r
+ ! Load new stack pointer\r
+ 1 ctx-reg context-callstack-top-offset LWZ\r
+\r
+ ! Load new ds, rs registers\r
+ jit-restore-context ;\r
+\r
+: jit-pop-context-and-param ( -- )\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 alien-offset LWZ\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg ds-reg 8 SUBI ;\r
+\r
+: jit-push-param ( -- )\r
+ ds-reg ds-reg 4 ADDI\r
+ 4 ds-reg 0 STW ;\r
+\r
+: jit-set-context ( -- )\r
+ jit-pop-context-and-param\r
+ 3 jit-switch-context\r
+ jit-push-param ;\r
+\r
+[ jit-set-context ] \ (set-context) define-sub-primitive\r
+\r
+: jit-pop-quot-and-param ( -- )\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg ds-reg 8 SUBI ;\r
+\r
+: jit-start-context ( -- )\r
+ ! Create the new context in return-reg\r
+ 3 vm-reg MR\r
+ "new_context" jit-call\r
+ 6 3 MR\r
+\r
+ jit-pop-quot-and-param\r
+\r
+ 6 jit-switch-context\r
+\r
+ jit-push-param\r
+\r
+ jit-jump-quot ;\r
+\r
+[ jit-start-context ] \ (start-context) define-sub-primitive\r
+\r
+: jit-delete-current-context ( -- )\r
+ jit-load-context\r
+ 3 vm-reg MR\r
+ 4 ctx-reg MR\r
+ "delete_context" jit-call ;\r
+\r
+[\r
+ jit-delete-current-context\r
+ jit-set-context\r
+] \ (set-context-and-delete) define-sub-primitive\r
+\r
+[\r
+ jit-delete-current-context\r
+ jit-start-context\r
+] \ (start-context-and-delete) define-sub-primitive\r
+\r
+[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
--- /dev/null
+! Copyright (C) 2007, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser system kernel sequences ;
+IN: bootstrap.ppc
+
+: reserved-size ( -- n ) 24 ;
+: lr-save ( -- n ) 4 ;
+
+<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
+call
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel layouts
+alien.c-types cpu.architecture cpu.ppc ;
+IN: cpu.ppc.linux
+
+<<
+t "longlong" c-type stack-align?<<
+t "ulonglong" c-type stack-align?<<
+>>
+
+M: linux reserved-area-size 2 cells ;
+
+M: linux lr-save 1 cells ;
+
+M: ppc param-regs
+ drop {
+ { int-regs { 3 4 5 6 7 8 9 10 } }
+ { float-regs { 1 2 3 4 5 6 7 8 } }
+ } ;
+
+M: ppc value-struct? drop f ;
+
+M: ppc dummy-stack-params? f ;
+
+M: ppc dummy-int-params? f ;
+
+M: ppc dummy-fp-params? f ;
--- /dev/null
+Linux/PPC ABI support
--- /dev/null
+not loaded
--- /dev/null
+! Copyright (C) 2007, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser system kernel sequences ;
+IN: bootstrap.ppc
+
+: reserved-size ( -- n ) 24 ;
+: lr-save ( -- n ) 8 ;
+
+<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
+call
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel layouts
+alien.c-types cpu.architecture cpu.ppc ;
+IN: cpu.ppc.macosx
+
+M: macosx reserved-area-size 6 cells ;
+
+M: macosx lr-save 2 cells ;
+
+M: ppc param-regs
+ drop {
+ { int-regs { 3 4 5 6 7 8 9 10 } }
+ { float-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+ } ;
+
+M: ppc value-struct? drop t ;
+
+M: ppc dummy-stack-params? t ;
+
+M: ppc dummy-int-params? t ;
+
+M: ppc dummy-fp-params? f ;
--- /dev/null
+Mac OS X/PPC ABI support
--- /dev/null
+not loaded
--- /dev/null
+! Copyright (C) 2005, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sequences kernel combinators
+classes.algebra byte-arrays make math math.order math.ranges
+system namespaces locals layouts words alien alien.accessors
+alien.c-types alien.complex alien.data alien.libraries
+literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.comparisons compiler.codegen.fixup
+compiler.cfg.intrinsics compiler.cfg.stack-frame
+compiler.cfg.build-stack-frame compiler.units compiler.constants
+compiler.codegen vm ;
+QUALIFIED-WITH: alien.c-types c
+FROM: cpu.ppc.assembler => B ;
+FROM: layouts => cell ;
+FROM: math => float ;
+IN: cpu.ppc
+
+! PowerPC register assignments:
+! r2-r12: integer vregs
+! r13: data stack
+! r14: retain stack
+! r15: VM pointer
+! r16-r29: integer vregs
+! r30: integer scratch
+! f0-f29: float vregs
+! f30: float scratch
+
+! Add some methods to the assembler that are useful to us
+M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
+M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
+
+enable-float-intrinsics
+
+M: ppc machine-registers
+ {
+ { int-regs $[ 2 12 [a,b] 16 29 [a,b] append ] }
+ { float-regs $[ 0 29 [a,b] ] }
+ } ;
+
+CONSTANT: scratch-reg 30
+CONSTANT: fp-scratch-reg 30
+
+M: ppc complex-addressing? f ;
+
+M: ppc fused-unboxing? f ;
+
+M: ppc %load-immediate ( reg n -- ) swap LOAD ;
+
+M: ppc %load-reference ( reg obj -- )
+ [ [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ]
+ [ \ f type-number swap LI ]
+ if* ;
+
+M: ppc %alien-global ( register symbol dll -- )
+ [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
+
+CONSTANT: ds-reg 13
+CONSTANT: rs-reg 14
+CONSTANT: vm-reg 15
+
+: %load-vm-addr ( reg -- ) vm-reg MR ;
+
+M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
+
+M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
+
+GENERIC: loc-reg ( loc -- reg )
+
+M: ds-loc loc-reg drop ds-reg ;
+M: rs-loc loc-reg drop rs-reg ;
+
+: loc>operand ( loc -- reg n )
+ [ loc-reg ] [ n>> cells neg ] bi ; inline
+
+M: ppc %peek loc>operand LWZ ;
+M: ppc %replace loc>operand STW ;
+
+:: (%inc) ( n reg -- ) reg reg n cells ADDI ; inline
+
+M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
+M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
+
+HOOK: reserved-area-size os ( -- n )
+
+! The start of the stack frame contains the size of this frame
+! as well as the currently executing code block
+: factor-area-size ( -- n ) 2 cells ; foldable
+: next-save ( n -- i ) cell - ; foldable
+: xt-save ( n -- i ) 2 cells - ; foldable
+
+! Next, we have the spill area as well as the FFI parameter area.
+! It is safe for them to overlap, since basic blocks with FFI calls
+! will never spill -- indeed, basic blocks with FFI calls do not
+! use vregs at all, and the FFI call is a stack analysis sync point.
+! In the future this will change and the stack frame logic will
+! need to be untangled somewhat.
+
+: param@ ( n -- x ) reserved-area-size + ; inline
+
+: param-save-size ( -- n ) 8 cells ; foldable
+
+: local@ ( n -- x )
+ reserved-area-size param-save-size + + ; inline
+
+: spill@ ( n -- offset )
+ spill-offset local@ ;
+
+! Some FP intrinsics need a temporary scratch area in the stack
+! frame, 8 bytes in size. This is in the param-save area so it
+! does not overlap with spill slots.
+: scratch@ ( n -- offset )
+ factor-area-size + ;
+
+! Finally we have the linkage area
+HOOK: lr-save os ( -- n )
+
+M: ppc stack-frame-size ( stack-frame -- i )
+ (stack-frame-size)
+ param-save-size +
+ reserved-area-size +
+ factor-area-size +
+ 4 cells align ;
+
+M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
+
+M: ppc %jump ( word -- )
+ 0 6 LOAD32 4 rc-absolute-ppc-2/2 rel-here
+ 0 B rc-relative-ppc-3 rel-word-pic-tail ;
+
+M: ppc %jump-label ( label -- ) B ;
+M: ppc %return ( -- ) BLR ;
+
+M:: ppc %dispatch ( src temp -- )
+ 0 temp LOAD32
+ 3 cells rc-absolute-ppc-2/2 rel-here
+ temp temp src LWZX
+ temp MTCTR
+ BCTR ;
+
+: (%slot) ( dst obj slot scale tag -- obj dst slot )
+ [ 0 assert= ] bi@ swapd ;
+
+M: ppc %slot ( dst obj slot scale tag -- ) (%slot) LWZX ;
+M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
+M: ppc %set-slot ( src obj slot scale tag -- ) (%slot) STWX ;
+M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
+
+M: ppc %add ADD ;
+M: ppc %add-imm ADDI ;
+M: ppc %sub swap SUBF ;
+M: ppc %sub-imm SUBI ;
+M: ppc %mul MULLW ;
+M: ppc %mul-imm MULLI ;
+M: ppc %and AND ;
+M: ppc %and-imm ANDI ;
+M: ppc %or OR ;
+M: ppc %or-imm ORI ;
+M: ppc %xor XOR ;
+M: ppc %xor-imm XORI ;
+M: ppc %shl SLW ;
+M: ppc %shl-imm swapd SLWI ;
+M: ppc %shr SRW ;
+M: ppc %shr-imm swapd SRWI ;
+M: ppc %sar SRAW ;
+M: ppc %sar-imm SRAWI ;
+M: ppc %not NOT ;
+M: ppc %neg NEG ;
+
+:: overflow-template ( label dst src1 src2 cc insn -- )
+ 0 0 LI
+ 0 MTXER
+ dst src2 src1 insn call
+ cc {
+ { cc-o [ label BO ] }
+ { cc/o [ label BNO ] }
+ } case ; inline
+
+M: ppc %fixnum-add ( label dst src1 src2 cc -- )
+ [ ADDO. ] overflow-template ;
+
+M: ppc %fixnum-sub ( label dst src1 src2 cc -- )
+ [ SUBFO. ] overflow-template ;
+
+M: ppc %fixnum-mul ( label dst src1 src2 cc -- )
+ [ MULLWO. ] overflow-template ;
+
+M: ppc %add-float FADD ;
+M: ppc %sub-float FSUB ;
+M: ppc %mul-float FMUL ;
+M: ppc %div-float FDIV ;
+
+M: ppc integer-float-needs-stack-frame? t ;
+
+M:: ppc %integer>float ( dst src -- )
+ HEX: 4330 scratch-reg LIS
+ scratch-reg 1 0 scratch@ STW
+ scratch-reg src MR
+ scratch-reg dup HEX: 8000 XORIS
+ scratch-reg 1 4 scratch@ STW
+ dst 1 0 scratch@ LFD
+ scratch-reg 4503601774854144.0 %load-reference
+ fp-scratch-reg scratch-reg float-offset LFD
+ dst dst fp-scratch-reg FSUB ;
+
+M:: ppc %float>integer ( dst src -- )
+ fp-scratch-reg src FCTIWZ
+ fp-scratch-reg 1 0 scratch@ STFD
+ dst 1 4 scratch@ LWZ ;
+
+M: ppc %copy ( dst src rep -- )
+ 2over eq? [ 3drop ] [
+ {
+ { tagged-rep [ MR ] }
+ { int-rep [ MR ] }
+ { double-rep [ FMR ] }
+ } case
+ ] if ;
+
+GENERIC: float-function-param* ( dst src -- )
+
+M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
+M: integer float-function-param* FMR ;
+
+: float-function-param ( i src -- )
+ [ float-regs cdecl param-regs at nth ] dip float-function-param* ;
+
+: float-function-return ( reg -- )
+ float-regs return-regs at first double-rep %copy ;
+
+M:: ppc %unary-float-function ( dst src func -- )
+ 0 src float-function-param
+ func f %c-invoke
+ dst float-function-return ;
+
+M:: ppc %binary-float-function ( dst src1 src2 func -- )
+ 0 src1 float-function-param
+ 1 src2 float-function-param
+ func f %c-invoke
+ dst float-function-return ;
+
+! Internal format is always double-precision on PowerPC
+M: ppc %single>double-float double-rep %copy ;
+M: ppc %double>single-float FRSP ;
+
+M: ppc %unbox-alien ( dst src -- )
+ alien-offset LWZ ;
+
+M:: ppc %unbox-any-c-ptr ( dst src -- )
+ [
+ "end" define-label
+ 0 dst LI
+ ! Is the object f?
+ 0 src \ f type-number CMPI
+ "end" get BEQ
+ ! Compute tag in dst register
+ dst src tag-mask get ANDI
+ ! Is the object an alien?
+ 0 dst alien type-number CMPI
+ ! Add an offset to start of byte array's data
+ dst src byte-array-offset ADDI
+ "end" get BNE
+ ! If so, load the offset and add it to the address
+ dst src alien-offset LWZ
+ "end" resolve-label
+ ] with-scope ;
+
+: alien@ ( n -- n' ) cells alien type-number - ;
+
+M:: ppc %box-alien ( dst src temp -- )
+ [
+ "f" define-label
+ dst \ f type-number %load-immediate
+ 0 src 0 CMPI
+ "f" get BEQ
+ dst 5 cells alien temp %allot
+ temp \ f type-number %load-immediate
+ temp dst 1 alien@ STW
+ temp dst 2 alien@ STW
+ src dst 3 alien@ STW
+ src dst 4 alien@ STW
+ "f" resolve-label
+ ] with-scope ;
+
+:: %box-displaced-alien/f ( dst displacement base -- )
+ base dst 1 alien@ STW
+ displacement dst 3 alien@ STW
+ displacement dst 4 alien@ STW ;
+
+:: %box-displaced-alien/alien ( dst displacement base temp -- )
+ ! Set new alien's base to base.base
+ temp base 1 alien@ LWZ
+ temp dst 1 alien@ STW
+
+ ! Compute displacement
+ temp base 3 alien@ LWZ
+ temp temp displacement ADD
+ temp dst 3 alien@ STW
+
+ ! Compute address
+ temp base 4 alien@ LWZ
+ temp temp displacement ADD
+ temp dst 4 alien@ STW ;
+
+:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
+ base dst 1 alien@ STW
+ displacement dst 3 alien@ STW
+ temp base byte-array-offset ADDI
+ temp temp displacement ADD
+ temp dst 4 alien@ STW ;
+
+:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
+ "not-f" define-label
+ "not-alien" define-label
+
+ ! Is base f?
+ 0 base \ f type-number CMPI
+ "not-f" get BNE
+
+ ! Yes, it is f. Fill in new object
+ dst displacement base %box-displaced-alien/f
+
+ "end" get B
+
+ "not-f" resolve-label
+
+ ! Check base type
+ temp base tag-mask get ANDI
+
+ ! Is base an alien?
+ 0 temp alien type-number CMPI
+ "not-alien" get BNE
+
+ dst displacement base temp %box-displaced-alien/alien
+
+ ! We are done
+ "end" get B
+
+ ! Is base a byte array? It has to be, by now...
+ "not-alien" resolve-label
+
+ dst displacement base temp %box-displaced-alien/byte-array ;
+
+M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
+ ! This is ridiculous
+ [
+ "end" define-label
+
+ ! If displacement is zero, return the base
+ dst base MR
+ 0 displacement 0 CMPI
+ "end" get BEQ
+
+ ! Displacement is non-zero, we're going to be allocating a new
+ ! object
+ dst 5 cells alien temp %allot
+
+ ! Set expired to f
+ temp \ f type-number %load-immediate
+ temp dst 2 alien@ STW
+
+ dst displacement base temp
+ {
+ { [ base-class \ f class<= ] [ drop %box-displaced-alien/f ] }
+ { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
+ { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
+ [ %box-displaced-alien/dynamic ]
+ } cond
+
+ "end" resolve-label
+ ] with-scope ;
+
+: (%memory) ( val base displacement scale offset rep c-type -- base val displacement rep c-type )
+ [ [ 0 assert= ] bi@ swapd ] 2dip ; inline
+
+M: ppc %load-memory-imm ( dst base offset rep c-type -- )
+ [
+ {
+ { c:char [ [ dup ] 2dip LBZ dup EXTSB ] }
+ { c:uchar [ LBZ ] }
+ { c:short [ LHA ] }
+ { c:ushort [ LHZ ] }
+ { c:int [ LWZ ] }
+ { c:uint [ LWZ ] }
+ } case
+ ] [
+ {
+ { int-rep [ LWZ ] }
+ { float-rep [ LFS ] }
+ { double-rep [ LFD ] }
+ } case
+ ] ?if ;
+
+M: ppc %load-memory ( dst base displacement scale offset rep c-type -- )
+ (%memory) [
+ {
+ { c:char [ [ LBZX ] [ drop dup EXTSB ] 2bi ] }
+ { c:uchar [ LBZX ] }
+ { c:short [ LHAX ] }
+ { c:ushort [ LHZX ] }
+ { c:int [ LWZX ] }
+ { c:uint [ LWZX ] }
+ } case
+ ] [
+ {
+ { int-rep [ LWZX ] }
+ { float-rep [ LFSX ] }
+ { double-rep [ LFDX ] }
+ } case
+ ] ?if ;
+
+M: ppc %store-memory-imm ( src base offset rep c-type -- )
+ [
+ {
+ { c:char [ STB ] }
+ { c:uchar [ STB ] }
+ { c:short [ STH ] }
+ { c:ushort [ STH ] }
+ { c:int [ STW ] }
+ { c:uint [ STW ] }
+ } case
+ ] [
+ {
+ { int-rep [ STW ] }
+ { float-rep [ STFS ] }
+ { double-rep [ STFD ] }
+ } case
+ ] ?if ;
+
+M: ppc %store-memory ( src base displacement scale offset rep c-type -- )
+ (%memory) [
+ {
+ { c:char [ STBX ] }
+ { c:uchar [ STBX ] }
+ { c:short [ STHX ] }
+ { c:ushort [ STHX ] }
+ { c:int [ STWX ] }
+ { c:uint [ STWX ] }
+ } case
+ ] [
+ {
+ { int-rep [ STWX ] }
+ { float-rep [ STFSX ] }
+ { double-rep [ STFDX ] }
+ } case
+ ] ?if ;
+
+: load-zone-ptr ( reg -- )
+ vm-reg "nursery" vm-field-offset ADDI ;
+
+: load-allot-ptr ( nursery-ptr allot-ptr -- )
+ [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
+
+:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
+ scratch-reg allot-ptr n data-alignment get align ADDI
+ scratch-reg nursery-ptr 0 STW ;
+
+:: store-header ( dst class -- )
+ class type-number tag-header scratch-reg LI
+ scratch-reg dst 0 STW ;
+
+: store-tagged ( dst tag -- )
+ dupd type-number ORI ;
+
+M:: ppc %allot ( dst size class nursery-ptr -- )
+ nursery-ptr dst load-allot-ptr
+ nursery-ptr dst size inc-allot-ptr
+ dst class store-header
+ dst class store-tagged ;
+
+: load-cards-offset ( dst -- )
+ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-cards-offset ;
+
+: load-decks-offset ( dst -- )
+ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-decks-offset ;
+
+:: (%write-barrier) ( temp1 temp2 -- )
+ card-mark scratch-reg LI
+
+ ! Mark the card
+ temp1 temp1 card-bits SRWI
+ temp2 load-cards-offset
+ temp1 scratch-reg temp2 STBX
+
+ ! Mark the card deck
+ temp1 temp1 deck-bits card-bits - SRWI
+ temp2 load-decks-offset
+ temp1 scratch-reg temp2 STBX ;
+
+M:: ppc %write-barrier ( src slot scale tag temp1 temp2 -- )
+ scale 0 assert= tag 0 assert=
+ temp1 src slot ADD
+ temp1 temp2 (%write-barrier) ;
+
+M:: ppc %write-barrier-imm ( src slot tag temp1 temp2 -- )
+ temp1 src slot tag slot-offset ADDI
+ temp1 temp2 (%write-barrier) ;
+
+M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
+ temp1 vm-reg "nursery" vm-field-offset LWZ
+ temp2 vm-reg "nursery" vm-field-offset 2 cells + LWZ
+ temp1 temp1 size ADDI
+ ! is here >= end?
+ temp1 0 temp2 CMP
+ cc {
+ { cc<= [ label BLE ] }
+ { cc/<= [ label BGT ] }
+ } case ;
+
+: gc-root-offsets ( seq -- seq' )
+ [ n>> spill@ ] map f like ;
+
+M: ppc %call-gc ( gc-roots -- )
+ 3 swap gc-root-offsets %load-reference
+ 4 %load-vm-addr
+ "inline_gc" f %c-invoke ;
+
+M: ppc %prologue ( n -- )
+ 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
+ 0 MFLR
+ {
+ [ [ 1 1 ] dip neg ADDI ]
+ [ [ 11 1 ] dip xt-save STW ]
+ [ 11 LI ]
+ [ [ 11 1 ] dip next-save STW ]
+ [ [ 0 1 ] dip lr-save + STW ]
+ } cleave ;
+
+M: ppc %epilogue ( n -- )
+ #! At the end of each word that calls a subroutine, we store
+ #! the previous link register value in r0 by popping it off
+ #! the stack, set the link register to the contents of r0,
+ #! and jump to the link register.
+ [ [ 0 1 ] dip lr-save + LWZ ]
+ [ [ 1 1 ] dip ADDI ] bi
+ 0 MTLR ;
+
+:: (%boolean) ( dst temp branch1 branch2 -- )
+ "end" define-label
+ dst \ f type-number %load-immediate
+ "end" get branch1 execute( label -- )
+ branch2 [ "end" get branch2 execute( label -- ) ] when
+ dst \ t %load-reference
+ "end" get resolve-label ; inline
+
+:: %boolean ( dst cc temp -- )
+ cc negate-cc order-cc {
+ { cc< [ dst temp \ BLT f (%boolean) ] }
+ { cc<= [ dst temp \ BLE f (%boolean) ] }
+ { cc> [ dst temp \ BGT f (%boolean) ] }
+ { cc>= [ dst temp \ BGE f (%boolean) ] }
+ { cc= [ dst temp \ BEQ f (%boolean) ] }
+ { cc/= [ dst temp \ BNE f (%boolean) ] }
+ } case ;
+
+: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
+
+: (%compare-integer-imm) ( src1 src2 -- )
+ [ 0 ] 2dip CMPI ; inline
+
+: (%compare-imm) ( src1 src2 -- )
+ [ tag-fixnum ] [ \ f type-number ] if* (%compare-integer-imm) ; inline
+
+: (%compare-float-unordered) ( src1 src2 -- )
+ [ 0 ] dip FCMPU ; inline
+
+: (%compare-float-ordered) ( src1 src2 -- )
+ [ 0 ] dip FCMPO ; inline
+
+:: (%compare-float) ( src1 src2 cc compare -- branch1 branch2 )
+ cc {
+ { cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] }
+ { cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNO f ] }
+ { cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] }
+ { cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BO ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BO ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BO ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO f ] }
+ } case ; inline
+
+M: ppc %compare [ (%compare) ] 2dip %boolean ;
+
+M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
+
+M: ppc %compare-integer-imm [ (%compare-integer-imm) ] 2dip %boolean ;
+
+M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
+ src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
+ dst temp branch1 branch2 (%boolean) ;
+
+M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
+ src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
+ dst temp branch1 branch2 (%boolean) ;
+
+:: %branch ( label cc -- )
+ cc order-cc {
+ { cc< [ label BLT ] }
+ { cc<= [ label BLE ] }
+ { cc> [ label BGT ] }
+ { cc>= [ label BGE ] }
+ { cc= [ label BEQ ] }
+ { cc/= [ label BNE ] }
+ } case ;
+
+M:: ppc %compare-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare)
+ label cc %branch ;
+
+M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare-imm)
+ label cc %branch ;
+
+M:: ppc %compare-integer-imm-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare-integer-imm)
+ label cc %branch ;
+
+:: (%branch) ( label branch1 branch2 -- )
+ label branch1 execute( label -- )
+ branch2 [ label branch2 execute( label -- ) ] when ; inline
+
+M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
+ src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
+ label branch1 branch2 (%branch) ;
+
+M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
+ src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
+ label branch1 branch2 (%branch) ;
+
+: load-from-frame ( dst n rep -- )
+ {
+ { int-rep [ [ 1 ] dip LWZ ] }
+ { tagged-rep [ [ 1 ] dip LWZ ] }
+ { float-rep [ [ 1 ] dip LFS ] }
+ { double-rep [ [ 1 ] dip LFD ] }
+ { stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
+ } case ;
+
+: next-param@ ( n -- reg x )
+ [ 17 ] dip param@ ;
+
+: store-to-frame ( src n rep -- )
+ {
+ { int-rep [ [ 1 ] dip STW ] }
+ { tagged-rep [ [ 1 ] dip STW ] }
+ { float-rep [ [ 1 ] dip STFS ] }
+ { double-rep [ [ 1 ] dip STFD ] }
+ { stack-params [ [ [ 0 ] dip next-param@ LWZ 0 1 ] dip STW ] }
+ } case ;
+
+M: ppc %spill ( src rep dst -- )
+ swap [ n>> spill@ ] dip store-to-frame ;
+
+M: ppc %reload ( dst rep src -- )
+ swap [ n>> spill@ ] dip load-from-frame ;
+
+M: ppc %loop-entry ;
+
+M: ppc return-regs
+ {
+ { int-regs { 3 4 5 6 } }
+ { float-regs { 1 } }
+ } ;
+
+M:: ppc %save-param-reg ( stack reg rep -- )
+ reg stack local@ rep store-to-frame ;
+
+M:: ppc %load-param-reg ( stack reg rep -- )
+ reg stack local@ rep load-from-frame ;
+
+GENERIC: load-param ( reg src -- )
+
+M: integer load-param int-rep %copy ;
+
+M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ;
+
+GENERIC: store-param ( reg dst -- )
+
+M: integer store-param swap int-rep %copy ;
+
+M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
+
+:: call-unbox-func ( src func -- )
+ 3 src load-param
+ 4 %load-vm-addr
+ func f %c-invoke ;
+
+M:: ppc %unbox ( src n rep func -- )
+ src func call-unbox-func
+ ! Store the return value on the C stack
+ n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ;
+
+M:: ppc %unbox-long-long ( src n func -- )
+ src func call-unbox-func
+ ! Store the return value on the C stack
+ n [
+ 3 1 n local@ STW
+ 4 1 n cell + local@ STW
+ ] when ;
+
+M:: ppc %unbox-large-struct ( src n c-type -- )
+ 4 src load-param
+ 3 1 n local@ ADDI
+ c-type heap-size 5 LI
+ "memcpy" "libc" load-library %c-invoke ;
+
+M:: ppc %box ( dst n rep func -- )
+ n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
+ rep double-rep? 5 4 ? %load-vm-addr
+ func f %c-invoke
+ 3 dst store-param ;
+
+M:: ppc %box-long-long ( dst n func -- )
+ n [
+ 3 1 n local@ LWZ
+ 4 1 n cell + local@ LWZ
+ ] when
+ 5 %load-vm-addr
+ func f %c-invoke
+ 3 dst store-param ;
+
+: struct-return@ ( n -- n )
+ [ stack-frame get params>> ] unless* local@ ;
+
+M: ppc %prepare-box-struct ( -- )
+ #! Compute target address for value struct return
+ 3 1 f struct-return@ ADDI
+ 3 1 0 local@ STW ;
+
+M:: ppc %box-large-struct ( dst n c-type -- )
+ ! If n = f, then we're boxing a returned struct
+ ! Compute destination address and load struct size
+ 3 1 n struct-return@ ADDI
+ c-type heap-size 4 LI
+ 5 %load-vm-addr
+ ! Call the function
+ "from_value_struct" f %c-invoke
+ 3 dst store-param ;
+
+M:: ppc %restore-context ( temp1 temp2 -- )
+ temp1 %context
+ ds-reg temp1 "datastack" context-field-offset LWZ
+ rs-reg temp1 "retainstack" context-field-offset LWZ ;
+
+M:: ppc %save-context ( temp1 temp2 -- )
+ temp1 %context
+ 1 temp1 "callstack-top" context-field-offset STW
+ ds-reg temp1 "datastack" context-field-offset STW
+ rs-reg temp1 "retainstack" context-field-offset STW ;
+
+M: ppc %c-invoke ( symbol dll -- )
+ [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
+
+M: ppc %alien-indirect ( src -- )
+ [ 11 ] dip load-param 11 MTLR BLRL ;
+
+M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
+
+M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
+
+M: ppc immediate-store? drop f ;
+
+M: ppc return-struct-in-registers? ( c-type -- ? )
+ c-type return-in-registers?>> ;
+
+M:: ppc %box-small-struct ( dst c-type -- )
+ #! Box a <= 16-byte struct returned in r3:r4:r5:r6
+ c-type heap-size 7 LI
+ 8 %load-vm-addr
+ "from_medium_struct" f %c-invoke
+ 3 dst store-param ;
+
+: %unbox-struct-1 ( -- )
+ ! Alien must be in r3.
+ 3 3 0 LWZ ;
+
+: %unbox-struct-2 ( -- )
+ ! Alien must be in r3.
+ 4 3 4 LWZ
+ 3 3 0 LWZ ;
+
+: %unbox-struct-4 ( -- )
+ ! Alien must be in r3.
+ 6 3 12 LWZ
+ 5 3 8 LWZ
+ 4 3 4 LWZ
+ 3 3 0 LWZ ;
+
+M:: ppc %unbox-small-struct ( src c-type -- )
+ src 3 load-param
+ c-type heap-size {
+ { [ dup 4 <= ] [ drop %unbox-struct-1 ] }
+ { [ dup 8 <= ] [ drop %unbox-struct-2 ] }
+ { [ dup 16 <= ] [ drop %unbox-struct-4 ] }
+ } cond ;
+
+M: ppc %begin-callback ( -- )
+ 3 %load-vm-addr
+ "begin_callback" f %c-invoke ;
+
+M: ppc %alien-callback ( quot -- )
+ 3 swap %load-reference
+ 4 3 quot-entry-point-offset LWZ
+ 4 MTLR
+ BLRL ;
+
+M: ppc %end-callback ( -- )
+ 3 %load-vm-addr
+ "end_callback" f %c-invoke ;
+
+enable-float-functions
+
+USE: vocabs.loader
+
+{
+ { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
+ { [ os linux? ] [ "cpu.ppc.linux" require ] }
+} cond
+
+complex-double c-type t >>return-in-registers? drop
--- /dev/null
+32-bit PowerPC compiler backend
--- /dev/null
+compiler
+not loaded
-CFLAGS += -mno-cygwin
-LIBS = -lm
-PLAF_DLL_OBJS += vm/os-windows.o
+CFLAGS += -mno-cygwin -mwindows
+CFLAGS_CONSOLE += -mconsole
SHARED_FLAG = -shared
+SHARED_DLL_EXTENSION=.dll
+
+LIBS = -lm
+
+PLAF_EXE_OBJS += vm/resources.o vm/main-windows.o
+
+EXE_SUFFIX=
EXE_EXTENSION=.exe
-CONSOLE_EXTENSION=.com
+DLL_SUFFIX=
DLL_EXTENSION=.dll
-SHARED_DLL_EXTENSION=.dll
+CONSOLE_EXTENSION=.com
+
LINKER = $(CPP) -shared -mno-cygwin -o
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)
+++ /dev/null
-CFLAGS += -DWINCE
-LIBS = -lm
-PLAF_DLL_OBJS += vm/os-windows-ce.o
-PLAF_EXE_OBJS += vm/main-windows-ce.o
-include vm/Config.windows
+++ /dev/null
-CC = arm-wince-mingw32ce-gcc
-DLL_SUFFIX=-ce
-EXE_SUFFIX=-ce
-include vm/Config.windows.ce vm/Config.arm
+++ /dev/null
-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
+++ /dev/null
-PLAF_DLL_OBJS += vm/os-windows-nt-x86.32.o
-DLL_PATH=http://factorcode.org/dlls
-WINDRES=windres
-include vm/Config.windows.nt
-include vm/Config.x86.32
+++ /dev/null
-PLAF_DLL_OBJS += vm/os-windows-nt-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.x86.64
--- /dev/null
+PLAF_DLL_OBJS += vm/os-windows-x86.32.o
+DLL_PATH=http://factorcode.org/dlls
+WINDRES=windres
+include vm/Config.windows
+include vm/Config.x86.32
--- /dev/null
+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
+include vm/Config.x86.64
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();
}
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))
allocator = new free_list_allocator<code_block>(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;
}
/* 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<object> *data_forwarding_map = &tenured->state;
update_code_roots_for_compaction();
callbacks->update();
- current_gc->event->ended_compaction();
+ if(event) event->ended_compaction();
}
struct code_compaction_fixup {
void factor_vm::delete_contexts()
{
assert(!ctx);
- std::vector<context *>::const_iterator iter = unused_contexts.begin();
- std::vector<context *>::const_iterator end = unused_contexts.end();
+ std::list<context *>::const_iterator iter = unused_contexts.begin();
+ std::list<context *>::const_iterator end = unused_contexts.end();
while(iter != end)
{
delete *iter;
{
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)
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<object> quot(quot_,this);
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);
void factor_vm::dump_generations()
{
+ std::cout << std::hex;
+
dump_generation("Nursery",&nursery);
dump_generation("Aging",data->aging);
dump_generation("Tenured",data->tenured);
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 {
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)
{
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);
}
c_to_factor_func(quot);
}
+template<typename Func> 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<word> 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<word> 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_func_type>(UNWIND_NATIVE_FRAMES_WORD)(quot,to);
+}
+
+cell factor_vm::get_fpu_state()
+{
+ return get_entry_point<get_fpu_state_func_type>(GET_FPU_STATE_WORD)();
+}
+
+void factor_vm::set_fpu_state(cell state)
+{
+ get_entry_point<set_fpu_state_func_type>(GET_FPU_STATE_WORD)(state);
}
}
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);
}
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);
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()
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 */
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()
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()
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()
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);
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)
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);
}
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()
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)
{
try
{
- current_gc->event->op = current_gc->op;
+ if(gc_events) current_gc->event->op = current_gc->op;
switch(current_gc->op)
{
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;
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;
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();
int c = safe_fgetc(file);
if(c == EOF && feof(file))
+ {
+ clearerr(file);
ctx->push(false_object);
+ }
else
ctx->push(tag_fixnum(c));
}
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<char>(), buf->data<char>(),c);
buf = new_buf;
{
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)
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
{
+++ /dev/null
-#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;
-}
+++ /dev/null
-#include "master.hpp"
-
-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;
-}
-
-int WINAPI WinMain(
- HINSTANCE hInstance,
- HINSTANCE hPrevInstance,
- LPSTR lpCmdLine,
- int nCmdShow)
-{
- int argc;
- wchar_t **argv;
-
- argv = CommandLineToArgvW(GetCommandLine(),&argc);
- wmain(argc,argv);
-
- // memory leak from malloc, wcsdup
- return 0;
-}
--- /dev/null
+#include "master.hpp"
+
+VM_C_API int wmain(int argc, wchar_t **argv)
+{
+ factor::init_globals();
+ factor::start_standalone_factor(argc,argv);
+ return 0;
+}
+
+int WINAPI WinMain(
+ HINSTANCE hInstance,
+ HINSTANCE hPrevInstance,
+ LPSTR lpCmdLine,
+ int nCmdShow)
+{
+ int argc;
+ wchar_t **argv = CommandLineToArgvW(GetCommandLine(),&argc);
+ wmain(argc,argv);
+
+ return 0;
+}
#include <stdlib.h>
#include <string.h>
#include <time.h>
+#include <wchar.h>
/* C++ headers */
#include <algorithm>
+#include <list>
#include <map>
#include <set>
#include <vector>
#include <iostream>
+#include <iomanip>
#define FACTOR_STRINGIZE(x) #x
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);
+++ /dev/null
-#include "master.hpp"
-
-namespace factor
-{
-
-DWORD current_vm_tls_key;
-
-void init_mvm()
-{
- if((current_vm_tls_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
- fatal_error("TlsAlloc() failed",0);
-}
-
-void register_vm_with_thread(factor_vm *vm)
-{
- if(!TlsSetValue(current_vm_tls_key, vm))
- fatal_error("TlsSetValue() failed",0);
-}
-
-factor_vm *current_vm()
-{
- factor_vm *vm = (factor_vm *)TlsGetValue(current_vm_tls_key);
- assert(vm != NULL);
- return vm;
-}
-
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+DWORD current_vm_tls_key;
+
+void init_mvm()
+{
+ if((current_vm_tls_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
+ fatal_error("TlsAlloc() failed",0);
+}
+
+void register_vm_with_thread(factor_vm *vm)
+{
+ if(!TlsSetValue(current_vm_tls_key, vm))
+ fatal_error("TlsSetValue() failed",0);
+}
+
+factor_vm *current_vm()
+{
+ factor_vm *vm = (factor_vm *)TlsGetValue(current_vm_tls_key);
+ assert(vm != NULL);
+ return vm;
+}
+
+}
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));
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();
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 */
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;
}
#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)
{
#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)
{
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)
#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)
{
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);
}
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)
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();
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);
}
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);
-
- control_read = filedes[0];
- control_write = filedes[1];
-
- if(pipe(filedes) < 0)
- fatal_error("Error opening size pipe",errno);
-
- size_read = filedes[0];
- size_write = filedes[1];
+ fatal_error("Error opening pipe",errno);
- if(pipe(filedes) < 0)
- fatal_error("Error opening stdin pipe",errno);
+ *in = filedes[0];
+ *out = filedes[1];
- stdin_read = filedes[0];
- stdin_write = filedes[1];
+ if(fcntl(*in,F_SETFD,FD_CLOEXEC) < 0)
+ fatal_error("Error with fcntl",errno);
- start_thread(stdin_loop,NULL);
+ if(fcntl(*out,F_SETFD,FD_CLOEXEC) < 0)
+ fatal_error("Error with fcntl",errno);
}
-VM_C_API void wait_for_stdin()
+void open_console()
{
- if(write(control_write,"X",1) != 1)
- {
- if(errno == EINTR)
- wait_for_stdin();
- else
- fatal_error("Error writing control fd",errno);
- }
+ safe_pipe(&control_read,&control_write);
+ safe_pipe(&size_read,&size_write);
+ safe_pipe(&stdin_read,&stdin_write);
+ start_thread(stdin_loop,NULL);
}
}
#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")
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();
+++ /dev/null
-#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() { }
-
-}
+++ /dev/null
-#ifndef UNICODE
-#define UNICODE
-#endif
-
-#include <windows.h>
-#include <ctype.h>
-
-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();
-
-}
+++ /dev/null
-#include "master.hpp"
-
-namespace factor
-{
-
-void factor_vm::c_to_factor_toplevel(cell quot)
-{
- /* 32-bit Windows SEH is set up in basis/cpu/x86/32/winnt/bootstrap.factor */
- c_to_factor(quot);
-}
-
-}
+++ /dev/null
-#include "master.hpp"
-
-namespace factor {
-
-typedef unsigned char UBYTE;
-
-const UBYTE UNW_FLAG_EHANDLER = 0x1;
-
-struct UNWIND_INFO {
- UBYTE Version:3;
- UBYTE Flags:5;
- UBYTE SizeOfProlog;
- UBYTE CountOfCodes;
- UBYTE FrameRegister:4;
- UBYTE FrameOffset:4;
- ULONG ExceptionHandler;
- ULONG ExceptionData[1];
-};
-
-struct seh_data {
- UNWIND_INFO unwind_info;
- RUNTIME_FUNCTION func;
- UBYTE handler[32];
-};
-
-void factor_vm::c_to_factor_toplevel(cell quot)
-{
- /* The annoying thing about Win64 SEH is that the offsets in
- * function tables are 32-bit integers, and the exception handler
- * itself must reside between the start and end pointers, so
- * we stick everything at the beginning of the code heap and
- * generate a small trampoline that jumps to the real
- * exception handler. */
-
- seh_data *seh_area = (seh_data *)code->seh_area;
- cell base = code->seg->start;
-
- /* Should look at generating this with the Factor assembler */
-
- /* mov rax,0 */
- seh_area->handler[0] = 0x48;
- seh_area->handler[1] = 0xb8;
- seh_area->handler[2] = 0x0;
- seh_area->handler[3] = 0x0;
- seh_area->handler[4] = 0x0;
- seh_area->handler[5] = 0x0;
- seh_area->handler[6] = 0x0;
- seh_area->handler[7] = 0x0;
- seh_area->handler[8] = 0x0;
- seh_area->handler[9] = 0x0;
-
- /* jmp rax */
- seh_area->handler[10] = 0x48;
- seh_area->handler[11] = 0xff;
- seh_area->handler[12] = 0xe0;
-
- /* Store address of exception handler in the operand of the 'mov' */
- cell handler = (cell)&factor::exception_handler;
- memcpy(&seh_area->handler[2],&handler,sizeof(cell));
-
- UNWIND_INFO *unwind_info = &seh_area->unwind_info;
- unwind_info->Version = 1;
- unwind_info->Flags = UNW_FLAG_EHANDLER;
- unwind_info->SizeOfProlog = 0;
- unwind_info->CountOfCodes = 0;
- unwind_info->FrameRegister = 0;
- unwind_info->FrameOffset = 0;
- unwind_info->ExceptionHandler = (DWORD)((cell)&seh_area->handler[0] - base);
- unwind_info->ExceptionData[0] = 0;
-
- RUNTIME_FUNCTION *func = &seh_area->func;
- func->BeginAddress = 0;
- func->EndAddress = (DWORD)(code->seg->end - base);
- func->UnwindData = (DWORD)((cell)&seh_area->unwind_info - base);
-
- if(!RtlAddFunctionTable(func,1,base))
- fatal_error("RtlAddFunctionTable() failed",0);
-
- c_to_factor(quot);
-
- if(!RtlDeleteFunctionTable(func))
- fatal_error("RtlDeleteFunctionTable() failed",0);
-}
-
-}
+++ /dev/null
-namespace factor
-{
-
-#define ESP Esp
-#define EIP Eip
-
-typedef struct DECLSPEC_ALIGN(16) _M128A {
- ULONGLONG Low;
- LONGLONG High;
-} M128A, *PM128A;
-
-/* The ExtendedRegisters field of the x86.32 CONTEXT structure uses this layout; however,
- * this structure is only made available from winnt.h on x86.64 */
-typedef struct _XMM_SAVE_AREA32 {
- WORD ControlWord; /* 000 */
- WORD StatusWord; /* 002 */
- BYTE TagWord; /* 004 */
- BYTE Reserved1; /* 005 */
- WORD ErrorOpcode; /* 006 */
- DWORD ErrorOffset; /* 008 */
- WORD ErrorSelector; /* 00c */
- WORD Reserved2; /* 00e */
- DWORD DataOffset; /* 010 */
- WORD DataSelector; /* 014 */
- WORD Reserved3; /* 016 */
- DWORD MxCsr; /* 018 */
- DWORD MxCsr_Mask; /* 01c */
- M128A FloatRegisters[8]; /* 020 */
- M128A XmmRegisters[16]; /* 0a0 */
- BYTE Reserved4[96]; /* 1a0 */
-} XMM_SAVE_AREA32, *PXMM_SAVE_AREA32;
-
-#define X87SW(ctx) (ctx)->FloatSave.StatusWord
-#define MXCSR(ctx) ((XMM_SAVE_AREA32*)((ctx)->ExtendedRegisters))->MxCsr
-
-}
+++ /dev/null
-namespace factor
-{
-
-#define ESP Rsp
-#define EIP Rip
-
-#define MXCSR(ctx) (ctx)->MxCsr
-
-}
+++ /dev/null
-#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()
-{
-}
-
-}
+++ /dev/null
-#undef _WIN32_WINNT
-#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
-
-#ifndef UNICODE
-#define UNICODE
-#endif
-
-#include <windows.h>
-#include <shellapi.h>
-
-#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(); }
-
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void factor_vm::c_to_factor_toplevel(cell quot)
+{
+ /* 32-bit Windows SEH is set up in basis/cpu/x86/32/winnt/bootstrap.factor */
+ c_to_factor(quot);
+}
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor {
+
+typedef unsigned char UBYTE;
+
+const UBYTE UNW_FLAG_EHANDLER = 0x1;
+
+struct UNWIND_INFO {
+ UBYTE Version:3;
+ UBYTE Flags:5;
+ UBYTE SizeOfProlog;
+ UBYTE CountOfCodes;
+ UBYTE FrameRegister:4;
+ UBYTE FrameOffset:4;
+ ULONG ExceptionHandler;
+ ULONG ExceptionData[1];
+};
+
+struct seh_data {
+ UNWIND_INFO unwind_info;
+ RUNTIME_FUNCTION func;
+ UBYTE handler[32];
+};
+
+void factor_vm::c_to_factor_toplevel(cell quot)
+{
+ /* The annoying thing about Win64 SEH is that the offsets in
+ * function tables are 32-bit integers, and the exception handler
+ * itself must reside between the start and end pointers, so
+ * we stick everything at the beginning of the code heap and
+ * generate a small trampoline that jumps to the real
+ * exception handler. */
+
+ seh_data *seh_area = (seh_data *)code->seh_area;
+ cell base = code->seg->start;
+
+ /* Should look at generating this with the Factor assembler */
+
+ /* mov rax,0 */
+ seh_area->handler[0] = 0x48;
+ seh_area->handler[1] = 0xb8;
+ seh_area->handler[2] = 0x0;
+ seh_area->handler[3] = 0x0;
+ seh_area->handler[4] = 0x0;
+ seh_area->handler[5] = 0x0;
+ seh_area->handler[6] = 0x0;
+ seh_area->handler[7] = 0x0;
+ seh_area->handler[8] = 0x0;
+ seh_area->handler[9] = 0x0;
+
+ /* jmp rax */
+ seh_area->handler[10] = 0x48;
+ seh_area->handler[11] = 0xff;
+ seh_area->handler[12] = 0xe0;
+
+ /* Store address of exception handler in the operand of the 'mov' */
+ cell handler = (cell)&factor::exception_handler;
+ memcpy(&seh_area->handler[2],&handler,sizeof(cell));
+
+ UNWIND_INFO *unwind_info = &seh_area->unwind_info;
+ unwind_info->Version = 1;
+ unwind_info->Flags = UNW_FLAG_EHANDLER;
+ unwind_info->SizeOfProlog = 0;
+ unwind_info->CountOfCodes = 0;
+ unwind_info->FrameRegister = 0;
+ unwind_info->FrameOffset = 0;
+ unwind_info->ExceptionHandler = (DWORD)((cell)&seh_area->handler[0] - base);
+ unwind_info->ExceptionData[0] = 0;
+
+ RUNTIME_FUNCTION *func = &seh_area->func;
+ func->BeginAddress = 0;
+ func->EndAddress = (DWORD)(code->seg->end - base);
+ func->UnwindData = (DWORD)((cell)&seh_area->unwind_info - base);
+
+ if(!RtlAddFunctionTable(func,1,base))
+ fatal_error("RtlAddFunctionTable() failed",0);
+
+ c_to_factor(quot);
+
+ if(!RtlDeleteFunctionTable(func))
+ fatal_error("RtlDeleteFunctionTable() failed",0);
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+#define ESP Esp
+#define EIP Eip
+
+typedef struct DECLSPEC_ALIGN(16) _M128A {
+ ULONGLONG Low;
+ LONGLONG High;
+} M128A, *PM128A;
+
+/* The ExtendedRegisters field of the x86.32 CONTEXT structure uses this layout; however,
+ * this structure is only made available from winnt.h on x86.64 */
+typedef struct _XMM_SAVE_AREA32 {
+ WORD ControlWord; /* 000 */
+ WORD StatusWord; /* 002 */
+ BYTE TagWord; /* 004 */
+ BYTE Reserved1; /* 005 */
+ WORD ErrorOpcode; /* 006 */
+ DWORD ErrorOffset; /* 008 */
+ WORD ErrorSelector; /* 00c */
+ WORD Reserved2; /* 00e */
+ DWORD DataOffset; /* 010 */
+ WORD DataSelector; /* 014 */
+ WORD Reserved3; /* 016 */
+ DWORD MxCsr; /* 018 */
+ DWORD MxCsr_Mask; /* 01c */
+ M128A FloatRegisters[8]; /* 020 */
+ M128A XmmRegisters[16]; /* 0a0 */
+ BYTE Reserved4[96]; /* 1a0 */
+} XMM_SAVE_AREA32, *PXMM_SAVE_AREA32;
+
+#define X87SW(ctx) (ctx)->FloatSave.StatusWord
+#define MXCSR(ctx) ((XMM_SAVE_AREA32*)((ctx)->ExtendedRegisters))->MxCsr
+
+}
--- /dev/null
+namespace factor
+{
+
+#define ESP Rsp
+#define EIP Rip
+
+#define MXCSR(ctx) (ctx)->MxCsr
+
+}
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;
}
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);
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() {}
+
}
#include <wchar.h>
#endif
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
+
+#ifndef UNICODE
+#define UNICODE
+#endif
+
+#include <windows.h>
+#include <shellapi.h>
+
+#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
#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(); }
}
#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
_(float_greatereq) \
_(float_less) \
_(float_lesseq) \
- _(float_mod) \
_(float_multiply) \
_(float_subtract) \
_(float_to_bignum) \
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));
}
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();
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;
}
int callback_id;
/* Pooling unused contexts to make context allocation cheaper */
- std::vector<context *> unused_contexts;
+ std::list<context *> unused_contexts;
/* Active contexts, for tracing by the GC */
std::set<context *> active_contexts;
/* 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;
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();
// 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<code_block *> *remembered_set);
void collect_nursery();
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();
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();
// entry points
void c_to_factor(cell quot);
+ template<typename Func> 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);
projects / factor.git / commitdiff