diff --git a/Factor.app/Contents/Info.plist b/Factor.app/Contents/Info.plist index 591886b196..629a52a123 100644 --- a/Factor.app/Contents/Info.plist +++ b/Factor.app/Contents/Info.plist @@ -34,7 +34,7 @@ CFBundleVersion 0.94 NSHumanReadableCopyright - Copyright © 2003-2010 Factor developers + Copyright © 2003-2011 Factor developers NSServices diff --git a/GNUmakefile b/GNUmakefile index 09aa5ee6bf..27f1d17e80 100755 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,14 +1,14 @@ ifdef CONFIG CC = gcc CPP = g++ - AR = ar - LD = ld VERSION = 0.94 BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib + include $(CONFIG) + CFLAGS = -Wall $(SITE_CFLAGS) ifdef DEBUG @@ -17,8 +17,6 @@ ifdef CONFIG CFLAGS += -O3 endif - include $(CONFIG) - ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) EXECUTABLE = factor$(EXE_SUFFIX)$(EXE_EXTENSION) CONSOLE_EXECUTABLE = factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) @@ -58,16 +56,86 @@ ifdef CONFIG vm/object_start_map.o \ vm/objects.o \ vm/primitives.o \ - vm/profiler.o \ vm/quotations.o \ vm/run.o \ + vm/safepoints.o \ + vm/sampling_profiler.o \ vm/strings.o \ vm/to_tenured_collector.o \ vm/tuples.o \ vm/utilities.o \ - vm/vm.o \ + vm/vm.o \ vm/words.o + MASTER_HEADERS = $(PLAF_MASTER_HEADERS) \ + vm/assert.hpp \ + vm/layouts.hpp \ + vm/platform.hpp \ + vm/primitives.hpp \ + vm/segments.hpp \ + vm/gc_info.hpp \ + vm/contexts.hpp \ + vm/run.hpp \ + vm/objects.hpp \ + vm/sampling_profiler.hpp \ + vm/errors.hpp \ + vm/bignumint.hpp \ + vm/bignum.hpp \ + vm/booleans.hpp \ + vm/instruction_operands.hpp \ + vm/code_blocks.hpp \ + vm/bump_allocator.hpp \ + vm/bitwise_hacks.hpp \ + vm/mark_bits.hpp \ + vm/free_list.hpp \ + vm/fixup.hpp \ + vm/tuples.hpp \ + vm/free_list_allocator.hpp \ + vm/write_barrier.hpp \ + vm/object_start_map.hpp \ + vm/nursery_space.hpp \ + vm/aging_space.hpp \ + vm/tenured_space.hpp \ + vm/data_heap.hpp \ + vm/code_heap.hpp \ + vm/gc.hpp \ + vm/debug.hpp \ + vm/strings.hpp \ + vm/words.hpp \ + vm/float_bits.hpp \ + vm/io.hpp \ + vm/image.hpp \ + vm/alien.hpp \ + vm/callbacks.hpp \ + vm/dispatch.hpp \ + vm/entry_points.hpp \ + vm/safepoints.hpp \ + vm/vm.hpp \ + vm/allot.hpp \ + vm/tagged.hpp \ + vm/data_roots.hpp \ + vm/code_roots.hpp \ + vm/generic_arrays.hpp \ + vm/callstack.hpp \ + vm/slot_visitor.hpp \ + vm/collector.hpp \ + vm/copying_collector.hpp \ + vm/nursery_collector.hpp \ + vm/aging_collector.hpp \ + vm/to_tenured_collector.hpp \ + vm/code_block_visitor.hpp \ + vm/compaction.hpp \ + vm/full_collector.hpp \ + vm/arrays.hpp \ + vm/math.hpp \ + vm/byte_arrays.hpp \ + vm/jit.hpp \ + vm/quotations.hpp \ + vm/inline_cache.hpp \ + vm/mvm.hpp \ + vm/factor.hpp \ + vm/utilities.hpp + EXE_OBJS = $(PLAF_EXE_OBJS) FFI_TEST_LIBRARY = libfactor-ffi-test$(SHARED_DLL_EXTENSION) @@ -81,24 +149,16 @@ default: help: @echo "Run '$(MAKE)' with one of the following parameters:" @echo "" - @echo "freebsd-x86-32" - @echo "freebsd-x86-64" @echo "linux-x86-32" @echo "linux-x86-64" - @echo "linux-ppc" + @echo "linux-ppc-32" + @echo "linux-ppc-64" @echo "linux-arm" - @echo "openbsd-x86-32" - @echo "openbsd-x86-64" - @echo "netbsd-x86-32" - @echo "netbsd-x86-64" @echo "macosx-x86-32" @echo "macosx-x86-64" - @echo "macosx-ppc" - @echo "solaris-x86-32" - @echo "solaris-x86-64" - @echo "wince-arm" - @echo "winnt-x86-32" - @echo "winnt-x86-64" + @echo "macosx-x86-fat" + @echo "windows-x86-32" + @echo "windows-x86-64" @echo "" @echo "Additional modifiers:" @echo "" @@ -109,61 +169,37 @@ help: ALL = factor factor-ffi-test factor-lib -openbsd-x86-32: - $(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.32 - -openbsd-x86-64: - $(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.64 - -freebsd-x86-32: - $(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.32 - -freebsd-x86-64: - $(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.64 - -netbsd-x86-32: - $(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.32 - -netbsd-x86-64: - $(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.64 - -macosx-ppc: - $(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.ppc - macosx-x86-32: $(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.32 macosx-x86-64: $(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.64 +macosx-x86-fat: + $(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.fat + linux-x86-32: $(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.32 linux-x86-64: $(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.64 -linux-ppc: - $(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc +linux-ppc-32: + $(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.32 + +linux-ppc-64: + $(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc.64 linux-arm: $(MAKE) $(ALL) CONFIG=vm/Config.linux.arm -solaris-x86-32: - $(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.32 +windows-x86-32: + $(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.32 + $(MAKE) factor-console CONFIG=vm/Config.windows.x86.32 -solaris-x86-64: - $(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.64 - -winnt-x86-32: - $(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.32 - $(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32 - -winnt-x86-64: - $(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64 - $(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64 - -wince-arm: - $(MAKE) $(ALL) CONFIG=vm/Config.windows.ce.arm +windows-x86-64: + $(MAKE) $(ALL) CONFIG=vm/Config.windows.x86.64 + $(MAKE) factor-console CONFIG=vm/Config.windows.x86.64 ifdef CONFIG @@ -179,12 +215,12 @@ $(ENGINE): $(DLL_OBJS) factor-lib: $(ENGINE) factor: $(EXE_OBJS) $(DLL_OBJS) - $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \ - $(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS) + $(TOOLCHAIN_PREFIX)$(CPP) $(LIBPATH) -L. $(DLL_OBJS) \ + $(CFLAGS) -o $(EXECUTABLE) $(LIBS) $(EXE_OBJS) factor-console: $(EXE_OBJS) $(DLL_OBJS) - $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \ - $(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS) + $(TOOLCHAIN_PREFIX)$(CPP) $(LIBPATH) -L. $(DLL_OBJS) \ + $(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(LIBS) $(EXE_OBJS) factor-ffi-test: $(FFI_TEST_LIBRARY) @@ -197,13 +233,16 @@ vm/resources.o: vm/ffi_test.o: vm/ffi_test.c $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $< -.cpp.o: +vm/master.hpp.gch: vm/master.hpp $(MASTER_HEADERS) + $(TOOLCHAIN_PREFIX)$(CPP) -c -x c++-header $(CFLAGS) -o $@ $< + +%.o: %.cpp vm/master.hpp.gch $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< -.S.o: - $(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $< +%.o: %.S + $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $< -.mm.o: +%.o: %.mm vm/master.hpp.gch $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< .SUFFIXES: .mm @@ -211,6 +250,7 @@ vm/ffi_test.o: vm/ffi_test.c endif clean: + rm -f vm/*.gch rm -f vm/*.o rm -f factor.dll rm -f factor.lib diff --git a/Nmakefile b/Nmakefile index 5297e49171..05aa8cb562 100755 --- a/Nmakefile +++ b/Nmakefile @@ -14,18 +14,17 @@ CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG !IF "$(PLATFORM)" == "x86-32" LINK_FLAGS = $(LINK_FLAGS) /safeseh -PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj +PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj !ELSEIF "$(PLATFORM)" == "x86-64" -PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj +PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj !ENDIF ML_FLAGS = /nologo /safeseh -EXE_OBJS = vm\main-windows-nt.obj vm\factor.res +EXE_OBJS = vm\main-windows.obj vm\factor.res DLL_OBJS = $(PLAF_DLL_OBJS) \ vm\os-windows.obj \ - vm\os-windows-nt.obj \ vm\aging_collector.obj \ vm\alien.obj \ vm\arrays.obj \ @@ -56,19 +55,20 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm\jit.obj \ vm\math.obj \ vm\mvm.obj \ - vm\mvm-windows-nt.obj \ + vm\mvm-windows.obj \ vm\nursery_collector.obj \ vm\object_start_map.obj \ vm\objects.obj \ vm\primitives.obj \ - vm\profiler.obj \ vm\quotations.obj \ vm\run.obj \ + vm\safepoints.obj \ + vm\sampling_profiler.obj \ vm\strings.obj \ vm\to_tenured_collector.obj \ vm\tuples.obj \ vm\utilities.obj \ - vm\vm.obj \ + vm\vm.obj \ vm\words.obj .cpp.obj: diff --git a/README.md b/README.md new file mode 100644 index 0000000000..7312b73d40 --- /dev/null +++ b/README.md @@ -0,0 +1,127 @@ +# Factor + +The Factor programming language combines [powerful language +features](http://concatenative.org/wiki/view/Factor/Features/The%20language) +with a [full-featured +library](http://docs.factorcode.org/content/article-vocab-index.html). The +implementation is [fully +compiled](http://concatenative.org/wiki/view/Factor/Optimizing%20compiler) +for performance, while still supporting [interactive +development](http://concatenative.org/wiki/view/Factor/Interactive%20development). +Factor applications are portable between all common platforms. Factor can +[deploy stand-alone +applications](http://concatenative.org/wiki/view/Factor/Deployment) on all +platforms. Full source code for the Factor project is available under a BSD +license. + +## Getting Started + +### Building Factor from source + +If you have a build environment set up, then you can build Factor from git. +These scripts will attempt to compile the Factor binary and bootstrap from +a boot image stored on factorcode.org. + +To check out Factor: + +* `git clone git://factorcode.org/git/factor.git` +* `cd factor` + +To build the latest complete Factor system from git: + +* Windows: `build-support\factor.cmd` +* Unix: `./build-support/factor.sh update` + +Now you should have a complete Factor system ready to run. + +More information on [building factor](http://concatenative.org/wiki/view/Factor/Building%20Factor) +and [system requirements](http://concatenative.org/wiki/view/Factor/Requirements). + +### To run a Factor binary: + +You can download a Factor binary from the grid on [http://factorcode.org](http://factorcode.org). +The nightly builds are usually a better experience than the point releases. + +* Windows: Double-click `factor.exe`, or run `.\factor.com` in a command prompt +* Mac OS X: Double-click `Factor.app` or run `open Factor.app` in a Terminal +* Unix: Run `./factor` in a shell + +### Learning Factor + +A tutorial is available that can be accessed from the Factor environment: + +```factor +"first-program" help +``` + +Some other simple things you can try in the listener: + +```factor +"Hello, world" print + +{ 4 8 15 16 23 42 } [ 2 * ] map . + +1000 [1,b] sum . + +4 iota [ + "Happy Birthday " write + 2 = "dear NAME" "to You" ? print +] each +``` + +For more tips, see [Learning Factor](http://concatenative.org/wiki/view/Factor/Learning). + +## Documentation + +The Factor environment includes extensive reference documentation and a +short "cookbook" to help you get started. The best way to read the +documentation is in the UI; press F1 in the UI listener to open the help +browser tool. You can also [browse the documentation +online](http://docs.factorcode.org). + +## Command Line Usage + +Factor supports a number of command line switches: + +``` +Usage: factor [Factor arguments] [script] [script arguments] + +Common arguments: + -help print this message and exit + -i= load Factor image file (default factor.image) + -run= run the MAIN: entry point of + -run=listener run terminal listener + -run=ui.tools run Factor development UI + -e= evaluate + -no-user-init suppress loading of .factor-rc + +Enter + "command-line" help +from within Factor for more information. +``` + +You can also write scripts that can be run from the terminal, by putting +``#!/path/to/factor`` at the top of your scripts and making them executable. + +## Source Organization + +The Factor source tree is organized as follows: + +* `build-support/` - scripts used for compiling Factor (not present in binary packages) +* `vm/` - Factor VM source code (not present in binary packages) +* `core/` - Factor core library +* `basis/` - Factor basis library, compiler, tools +* `extra/` - more libraries and applications +* `misc/` - editor modes, icons, etc +* `unmaintained/` - unmaintained contributions, please help! + +## Community + +Factor developers meet in the `#concatenative` channel on +[irc.freenode.net](http://freenode.net). Drop by if you want to discuss +anything related to Factor or language design in general. + +* [Factor homepage](http://factorcode.org) +* [Concatenative languages wiki](http://concatenative.org) + +Have fun! diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index c020feaa76..406a554f8f 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -7,7 +7,7 @@ IN: alien.arrays INSTANCE: array value-type -M: array c-type ; +M: array lookup-c-type ; M: array c-type-class drop object ; @@ -27,7 +27,7 @@ M: array base-type drop void* base-type ; PREDICATE: string-type < pair first2 [ c-string = ] [ word? ] bi* and ; -M: string-type c-type ; +M: string-type lookup-c-type ; M: string-type c-type-class drop object ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 32c1d18d51..7bc7865455 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,6 +1,6 @@ -USING: alien alien.complex help.syntax help.markup libc kernel.private -byte-arrays strings hashtables alien.syntax alien.strings sequences -io.encodings.string debugger destructors vocabs.loader +USING: alien help.syntax help.markup libc kernel.private +byte-arrays strings hashtables alien.syntax alien.strings +sequences io.encodings.string debugger destructors vocabs.loader classes.struct math kernel ; QUALIFIED: math QUALIFIED: sequences @@ -21,9 +21,9 @@ HELP: HELP: no-c-type { $values { "name" c-type-name } } { $description "Throws a " { $link no-c-type } " error." } -{ $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ; +{ $error-description "Thrown by " { $link c-type } " if a given word is not a C type." } ; -HELP: c-type +HELP: lookup-c-type { $values { "name" c-type-name } { "c-type" c-type } } { $description "Looks up a C type by name." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ; @@ -38,16 +38,6 @@ HELP: set-alien-value { $description "Stores a value at a byte offset from a base C pointer." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; -HELP: define-deref -{ $values { "c-type" "a C type" } } -{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." } -{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; - -HELP: define-out -{ $values { "c-type" "a C type" } } -{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." } -{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; - HELP: char { $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ; HELP: uchar @@ -86,17 +76,13 @@ HELP: float { $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ; HELP: double { $description "This C type represents a double-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s; output values will be returned as Factor " { $link math:float } "s." } ; -HELP: complex-float -{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ; -HELP: complex-double -{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ; HELP: pointer: { $syntax "pointer: c-type" } { $description "Constructs a " { $link pointer } " C type." } ; HELP: pointer -{ $class-description "Represents a pointer C type. The " { $snippet "to" } " slot contains the C type being pointed to." { $link byte-array } " and " { $link alien } " values can be provided as pointer function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Objects with methods on " { $link >c-ptr } ", such as structs and specialized arrays, may also be used as pointer inputs." +{ $class-description "Represents a pointer C type. The " { $snippet "to" } " slot contains the C type being pointed to. Both " { $link byte-array } " and " { $link alien } " values can be provided as pointer function inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Objects with methods on " { $link >c-ptr } ", such as structs and specialized arrays, may also be used as pointer inputs." $nl "Pointer output values are represented in Factor as " { $link alien } "s. If the pointed-to type is a struct, the alien will automatically be wrapped in a struct object if it is not null." $nl @@ -118,43 +104,6 @@ $nl "If this condition is not satisfied, " { $link "malloc" } " must be used instead." { $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ; -ARTICLE: "c-out-params" "Output parameters in C" -"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations." -$nl -"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:" -{ $subsections - - - - - - - - - - - - - -} -"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:" -{ $subsections - *char - *uchar - *short - *ushort - *int - *uint - *long - *ulong - *longlong - *ulonglong - *float - *double - *void* -} -"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link } " and " { $link *void* } " may be used." ; - ARTICLE: "c-types.primitives" "Primitive C types" "The following numerical types are defined in the " { $vocab-link "alien.c-types" } " vocabulary; a " { $snippet "u" } " prefix denotes an unsigned type:" { $table @@ -172,11 +121,8 @@ ARTICLE: "c-types.primitives" "Primitive C types" { { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } } { { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } } } -"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:" -{ $table - { { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } } - { { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } } -} +"C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary." +$nl "When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." ; ARTICLE: "c-types.pointers" "Pointer and array types" @@ -226,6 +172,8 @@ $nl POSTPONE: CALLBACK: POSTPONE: TYPEDEF: } +"Getting the c-type of a class:" +{ $subsections lookup-c-type } { $heading "Related articles" } { $subsections "c-types.primitives" diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 5e4635e018..f088878013 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -2,34 +2,31 @@ USING: alien alien.syntax alien.c-types alien.parser eval kernel tools.test sequences system libc alien.strings io.encodings.ascii io.encodings.utf8 math.constants classes.struct classes accessors compiler.units ; +FROM: alien.c-types => short ; IN: alien.c-types.tests CONSTANT: xyz 123 [ 492 ] [ { int xyz } heap-size ] unit-test -[ -1 ] [ -1 *char ] unit-test -[ -1 ] [ -1 *short ] unit-test -[ -1 ] [ -1 *int ] unit-test - UNION-STRUCT: foo { a int } { b int } ; -[ t ] [ pointer: void c-type void* c-type = ] unit-test -[ t ] [ pointer: int c-type void* c-type = ] unit-test -[ t ] [ pointer: int* c-type void* c-type = ] unit-test -[ f ] [ pointer: foo c-type void* c-type = ] unit-test -[ t ] [ pointer: foo* c-type void* c-type = ] unit-test +[ t ] [ pointer: void lookup-c-type void* lookup-c-type = ] unit-test +[ t ] [ pointer: int lookup-c-type void* lookup-c-type = ] unit-test +[ t ] [ pointer: int* lookup-c-type void* lookup-c-type = ] unit-test +[ f ] [ pointer: foo lookup-c-type void* lookup-c-type = ] unit-test +[ t ] [ pointer: foo* lookup-c-type void* lookup-c-type = ] unit-test -[ t ] [ c-string c-type c-string c-type = ] unit-test +[ t ] [ c-string lookup-c-type c-string lookup-c-type = ] unit-test [ t ] [ foo heap-size int heap-size = ] unit-test TYPEDEF: int MyInt -[ t ] [ int c-type MyInt c-type = ] unit-test -[ t ] [ void* c-type pointer: MyInt c-type = ] unit-test +[ t ] [ int lookup-c-type MyInt lookup-c-type = ] unit-test +[ t ] [ void* lookup-c-type pointer: MyInt lookup-c-type = ] unit-test [ 32 ] [ { int 8 } heap-size ] unit-test @@ -37,28 +34,20 @@ TYPEDEF: int MyInt TYPEDEF: char MyChar -[ t ] [ pointer: void c-type pointer: MyChar c-type = ] unit-test +[ t ] [ pointer: void lookup-c-type pointer: MyChar lookup-c-type = ] unit-test TYPEDEF: { c-string ascii } MyFunkyString -[ { c-string ascii } ] [ MyFunkyString c-type ] unit-test +[ { c-string ascii } ] [ MyFunkyString lookup-c-type ] unit-test TYPEDEF: c-string MyString -[ t ] [ c-string c-type MyString c-type = ] unit-test -[ t ] [ void* c-type pointer: MyString c-type = ] unit-test +[ t ] [ c-string lookup-c-type MyString lookup-c-type = ] unit-test +[ t ] [ void* lookup-c-type pointer: MyString lookup-c-type = ] unit-test TYPEDEF: int* MyIntArray -[ t ] [ void* c-type MyIntArray c-type = ] unit-test - -[ - 0 B{ 1 2 3 4 } -] must-fail - -os windows? cpu x86.64? and [ - [ -2147467259 ] [ 2147500037 *long ] unit-test -] when +[ t ] [ void* lookup-c-type MyIntArray lookup-c-type = ] unit-test [ 0 ] [ -10 uchar c-type-clamp ] unit-test [ 12 ] [ 12 uchar c-type-clamp ] unit-test @@ -68,8 +57,8 @@ os windows? cpu x86.64? and [ C-TYPE: opaque -[ t ] [ void* c-type pointer: opaque c-type = ] unit-test -[ opaque c-type ] [ no-c-type? ] must-fail-with +[ t ] [ void* lookup-c-type pointer: opaque lookup-c-type = ] unit-test +[ opaque lookup-c-type ] [ no-c-type? ] must-fail-with [ """ USING: alien.syntax ; @@ -81,8 +70,8 @@ C-TYPE: forward STRUCT: backward { x forward* } ; STRUCT: forward { x backward* } ; -[ t ] [ forward c-type struct-c-type? ] unit-test -[ t ] [ backward c-type struct-c-type? ] unit-test +[ t ] [ forward lookup-c-type struct-c-type? ] unit-test +[ t ] [ backward lookup-c-type struct-c-type? ] unit-test DEFER: struct-redefined diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 04755ea033..4f435c93d0 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -1,12 +1,9 @@ ! Copyright (C) 2004, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays arrays assocs delegate kernel kernel.private math -math.order math.parser namespaces make parser sequences strings -words splitting cpu.architecture alien alien.accessors -alien.strings quotations layouts system compiler.units io -io.files io.encodings.binary io.streams.memory accessors -combinators effects continuations fry classes vocabs -vocabs.loader words.symbol macros ; +USING: accessors alien alien.accessors arrays byte-arrays +classes combinators compiler.units cpu.architecture delegate +fry kernel layouts locals macros math math.order quotations +sequences system words words.symbol summary ; QUALIFIED: math IN: alien.c-types @@ -21,9 +18,6 @@ SYMBOLS: SINGLETON: void -DEFER: -DEFER: *char - TUPLE: abstract-c-type { class class initial: object } { boxed-class class initial: object } @@ -43,13 +37,15 @@ unboxer : ( -- c-type ) \ c-type new ; inline -ERROR: no-c-type name ; +ERROR: no-c-type word ; + +M: no-c-type summary drop "Not a C type" ; ! C type protocol -GENERIC: c-type ( name -- c-type ) foldable +GENERIC: lookup-c-type ( name -- c-type ) foldable PREDICATE: c-type-word < word - "c-type" word-prop ; + "c-type" word-prop >boolean ; TUPLE: pointer { to initial: void read-only } ; C: pointer @@ -59,12 +55,13 @@ UNION: c-type-name : resolve-typedef ( name -- c-type ) dup void? [ no-c-type ] when - dup c-type-name? [ c-type ] when ; + dup c-type-name? [ lookup-c-type ] when ; -M: word c-type +M: word lookup-c-type dup "c-type" word-prop resolve-typedef [ ] [ no-c-type ] ?if ; + GENERIC: c-type-class ( name -- class ) M: abstract-c-type c-type-class class>> ; @@ -107,12 +104,10 @@ M: abstract-c-type c-type-align-first align-first>> ; GENERIC: base-type ( c-type -- c-type ) -M: c-type-name base-type c-type ; +M: c-type-name base-type lookup-c-type ; M: c-type base-type ; -: little-endian? ( -- ? ) 1 *char 1 = ; foldable - GENERIC: heap-size ( name -- size ) M: abstract-c-type heap-size size>> ; @@ -154,7 +149,7 @@ PROTOCOL: c-type-protocol heap-size ; CONSULT: c-type-protocol c-type-name - c-type ; + lookup-c-type ; PREDICATE: typedef-word < c-type-word "c-type" word-prop [ c-type-name? ] [ array? ] bi or ; @@ -170,20 +165,7 @@ TUPLE: long-long-type < c-type ; : ( -- c-type ) long-long-type new ; -: define-deref ( c-type -- ) - [ name>> CHAR: * prefix "alien.c-types" create ] - [ '[ 0 _ alien-value ] ] - bi (( c-ptr -- value )) define-inline ; - -: define-out ( c-type -- ) - [ name>> "alien.c-types" constructor-word ] - [ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi - (( value -- c-ptr )) define-inline ; - -: define-primitive-type ( c-type name -- ) - [ typedef ] [ define-deref ] [ define-out ] tri ; - -: if-void ( c-type true false -- ) +: if-void ( ..a c-type true: ( ..a -- ..b ) false: ( ..a c-type -- ..b ) -- ..b ) pick void? [ drop nip call ] [ nip call ] if ; inline SYMBOLS: @@ -210,7 +192,6 @@ CONSTANT: primitive-types : 8-byte-alignment ( c-type -- c-type ) { - { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] } { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] } [ 8 >>align 8 >>align-first ] } cond ; @@ -231,8 +212,8 @@ CONSTANT: primitive-types PRIVATE> -M: pointer c-type - [ \ void* c-type ] dip +M: pointer lookup-c-type + [ \ void* lookup-c-type ] dip to>> dup primitive-pointer-type? [ drop ] [ (pointer-c-type) ] if ; [ @@ -247,7 +228,7 @@ M: pointer c-type [ >c-ptr ] >>unboxer-quot "allot_alien" >>boxer "alien_offset" >>unboxer - \ void* define-primitive-type + \ void* typedef fixnum >>class @@ -260,7 +241,7 @@ M: pointer c-type "from_signed_2" >>boxer "to_signed_2" >>unboxer [ >fixnum ] >>unboxer-quot - \ short define-primitive-type + \ short typedef fixnum >>class @@ -273,7 +254,7 @@ M: pointer c-type "from_unsigned_2" >>boxer "to_unsigned_2" >>unboxer [ >fixnum ] >>unboxer-quot - \ ushort define-primitive-type + \ ushort typedef fixnum >>class @@ -286,7 +267,7 @@ M: pointer c-type "from_signed_1" >>boxer "to_signed_1" >>unboxer [ >fixnum ] >>unboxer-quot - \ char define-primitive-type + \ char typedef fixnum >>class @@ -299,7 +280,7 @@ M: pointer c-type "from_unsigned_1" >>boxer "to_unsigned_1" >>unboxer [ >fixnum ] >>unboxer-quot - \ uchar define-primitive-type + \ uchar typedef math:float >>class @@ -313,7 +294,7 @@ M: pointer c-type "to_float" >>unboxer float-rep >>rep [ >float ] >>unboxer-quot - \ float define-primitive-type + \ float typedef math:float >>class @@ -326,7 +307,7 @@ M: pointer c-type "to_double" >>unboxer double-rep >>rep [ >float ] >>unboxer-quot - \ double define-primitive-type + \ double typedef cell 8 = [ @@ -340,7 +321,7 @@ M: pointer c-type "from_signed_4" >>boxer "to_signed_4" >>unboxer [ >fixnum ] >>unboxer-quot - \ int define-primitive-type + \ int typedef fixnum >>class @@ -353,7 +334,7 @@ M: pointer c-type "from_unsigned_4" >>boxer "to_unsigned_4" >>unboxer [ >fixnum ] >>unboxer-quot - \ uint define-primitive-type + \ uint typedef integer >>class @@ -365,7 +346,8 @@ M: pointer c-type 8 >>align-first "from_signed_cell" >>boxer "to_fixnum" >>unboxer - \ longlong define-primitive-type + [ >integer ] >>unboxer-quot + \ longlong typedef integer >>class @@ -377,21 +359,22 @@ M: pointer c-type 8 >>align-first "from_unsigned_cell" >>boxer "to_cell" >>unboxer - \ ulonglong define-primitive-type + [ >integer ] >>unboxer-quot + \ ulonglong typedef os windows? [ - \ int c-type \ long define-primitive-type - \ uint c-type \ ulong define-primitive-type + \ int lookup-c-type \ long typedef + \ uint lookup-c-type \ ulong typedef ] [ - \ longlong c-type \ long define-primitive-type - \ ulonglong c-type \ ulong define-primitive-type + \ longlong lookup-c-type \ long typedef + \ ulonglong lookup-c-type \ ulong typedef ] if - \ longlong c-type \ ptrdiff_t typedef - \ longlong c-type \ intptr_t typedef + \ longlong lookup-c-type \ ptrdiff_t typedef + \ longlong lookup-c-type \ intptr_t typedef - \ ulonglong c-type \ uintptr_t typedef - \ ulonglong c-type \ size_t typedef + \ ulonglong lookup-c-type \ uintptr_t typedef + \ ulonglong lookup-c-type \ size_t typedef ] [ integer >>class @@ -403,7 +386,8 @@ M: pointer c-type 4 >>align-first "from_signed_cell" >>boxer "to_fixnum" >>unboxer - \ int define-primitive-type + [ >integer ] >>unboxer-quot + \ int typedef integer >>class @@ -415,7 +399,8 @@ M: pointer c-type 4 >>align-first "from_unsigned_cell" >>boxer "to_cell" >>unboxer - \ uint define-primitive-type + [ >integer ] >>unboxer-quot + \ uint typedef integer >>class @@ -426,7 +411,8 @@ M: pointer c-type 8-byte-alignment "from_signed_8" >>boxer "to_signed_8" >>unboxer - \ longlong define-primitive-type + [ >integer ] >>unboxer-quot + \ longlong typedef integer >>class @@ -437,23 +423,24 @@ M: pointer c-type 8-byte-alignment "from_unsigned_8" >>boxer "to_unsigned_8" >>unboxer - \ ulonglong define-primitive-type + [ >integer ] >>unboxer-quot + \ ulonglong typedef - \ int c-type \ long define-primitive-type - \ uint c-type \ ulong define-primitive-type + \ int lookup-c-type \ long typedef + \ uint lookup-c-type \ ulong typedef - \ int c-type \ ptrdiff_t typedef - \ int c-type \ intptr_t typedef + \ int lookup-c-type \ ptrdiff_t typedef + \ int lookup-c-type \ intptr_t typedef - \ uint c-type \ uintptr_t typedef - \ uint c-type \ size_t typedef + \ uint lookup-c-type \ uintptr_t typedef + \ uint lookup-c-type \ size_t typedef ] if - cpu ppc? \ uint \ uchar ? c-type clone + \ uchar lookup-c-type clone [ >c-bool ] >>unboxer-quot [ c-bool> ] >>boxer-quot object >>boxed-class - \ bool define-primitive-type + \ bool typedef ] with-compilation-unit diff --git a/basis/alien/complex/complex-docs.factor b/basis/alien/complex/complex-docs.factor new file mode 100644 index 0000000000..c530b1b32d --- /dev/null +++ b/basis/alien/complex/complex-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax math ; +IN: alien.complex + +HELP: complex-float +{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link complex } " objects." } ; +HELP: complex-double +{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link complex } " objects." } ; + +ARTICLE: "alien.complex" "C99 complex number types" +"The following C99 complex number types are defined in the " { $vocab-link "alien.complex" } " vocabulary:" +{ $table + { { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link complex } " values" } } + { { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link complex } " values" } } +} ; diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor index fbf28071d0..bb9d469b86 100644 --- a/basis/alien/complex/complex.factor +++ b/basis/alien/complex/complex.factor @@ -10,6 +10,6 @@ IN: alien.complex << ! This overrides the fact that small structures are never returned -! in registers on NetBSD, Linux and Solaris running on 32-bit x86. -\ complex-float c-type t >>return-in-registers? drop +! in registers on Linux running on 32-bit x86. +\ complex-float lookup-c-type t >>return-in-registers? drop >> diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 90fb5174c1..1a4b32daa1 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -24,7 +24,7 @@ STRUCT: T-class { real N-type } { imaginary N-type } ; : *T ( alien -- z ) T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline -T-class c-type +T-class lookup-c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot complex >>boxed-class diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 02a31976c7..ae8556fa7d 100644 --- a/basis/alien/data/data-docs.factor +++ b/basis/alien/data/data-docs.factor @@ -1,39 +1,43 @@ USING: alien alien.c-types help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax alien.strings sequences io.encodings.string debugger destructors -vocabs.loader classes.struct quotations ; +vocabs.loader classes.struct quotations kernel ; IN: alien.data +HELP: >c-array +{ $values { "seq" sequence } { "c-type" "a C type" } { "array" byte-array } } +{ $description "Outputs a freshly allocated byte-array whose elements are C type values from the given sequence." } +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } +{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ; + HELP: { $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } } { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." } -{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } { $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ; -HELP: -{ $values { "type" "a C type" } { "array" byte-array } } -{ $description "Creates a byte array suitable for holding a value with the given C type." } -{ $errors "Throws an " { $link no-c-type } " error if the type does not exist." } ; - -{ malloc-object } related-words +HELP: c-array{ +{ $description "Literal syntax, consists of a C-type followed by a series of values terminated by " { $snippet "}" } } +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } +{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ; 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." } ; +HELP: cast-array +{ $values { "byte-array" byte-array } { "c-type" "a C type" } { "array" "a specialized array" } } +{ $description "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable" } +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } +{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ; + HELP: malloc-array -{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" "a specialized array" } } +{ $values { "n" "a non-negative integer" } { "c-type" "a C type" } { "array" "a specialized array" } } { $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } -{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } { $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." } @@ -62,10 +66,10 @@ classes.struct kernel math math.functions prettyprint ; IN: scratchpad -STRUCT: point { x int } { y int } ; +STRUCT: test-point { x int } { y int } ; : scoped-allocation-test ( -- x ) - { point } [ + { test-point } [ 3 >>x 4 >>y [ x>> sq ] [ y>> sq ] bi + sqrt ] with-scoped-allocation ; @@ -92,7 +96,6 @@ ARTICLE: "malloc" "Manual memory management" $nl "Allocating a C datum with a fixed address:" { $subsections - malloc-object malloc-byte-array } "The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:" @@ -134,6 +137,10 @@ ARTICLE: "c-pointers" "Passing pointers to C functions" { $warning "The Factor garbage collector can move byte arrays around, and code passing byte arrays, or objects backed by byte arrays, must obey important guidelines. See " { $link "byte-arrays-gc" } "." } ; +ARTICLE: "c-boxes" "C value boxes" +"Sometimes it is useful to create a byte array storing a single C value, like a struct with a single field. A pair of utility macros exist to make this more convenient:" +{ $subsections deref } ; + ARTICLE: "c-data" "Passing data between Factor and C" "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers." $nl @@ -144,13 +151,12 @@ $nl "malloc" "c-strings" "c-out-params" + "c-boxes" } "Important guidelines for passing data in byte arrays:" { $subsections "byte-arrays-gc" } "C-style enumerated types are supported:" -{ $subsections "alien.enums" POSTPONE: ENUM: } -"C types can be aliased for convenience and consistency with native library documentation:" -{ $subsections POSTPONE: TYPEDEF: } +{ $subsections "alien.enums" } "A utility for defining " { $link "destructors" } " for deallocating memory:" { $subsections "alien.destructors" } "C struct and union types can be defined with " { $link POSTPONE: STRUCT: } " and " { $link POSTPONE: UNION: } ". See " { $link "classes.struct" } " for details. For passing arrays to and from C, use the " { $link "specialized-arrays" } " vocabulary." ; @@ -167,15 +173,10 @@ HELP: malloc-string } } ; -HELP: require-c-array -{ $values { "c-type" "a C type" } } -{ $description "Generates a specialized array of " { $snippet "c-type" } " using the " { $link } " or " { $link } " vocabularies." } -{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence types loaded." } ; - HELP: { $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } } { $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." } -{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ; +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. See the " { $vocab-link "specialized-arrays" } " vocabulary for details on the underlying sequence type constructed." } ; ARTICLE: "c-strings" "C strings" "C string types are arrays with shape " { $snippet "{ c-string encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link c-string } " is an alias for " { $snippet "{ c-string utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors. In " { $link POSTPONE: TYPEDEF: } ", " { $link POSTPONE: FUNCTION: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: STRUCT: } " definitions, the shorthand syntax " { $snippet "c-string[encoding]" } " can be used to specify the string encoding." @@ -199,3 +200,20 @@ $nl { $subsections alien>string } "For example, if a C function returns a " { $link c-string } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "char*" } " and call " { $link (free) } " yourself." ; +HELP: +{ $values { "value" object } { "c-type" "a C type" } { "c-ptr" c-ptr } } +{ $description "Creates a new byte array to store a Factor object as a C value." } +{ $examples + { $example "USING: alien.c-types alien.data prettyprint sequences ;" "123 int length ." "4" } +} ; + +HELP: deref +{ $values { "c-ptr" c-ptr } { "c-type" "a C type" } { "value" object } } +{ $description "Loads a C value from a byte array." } +{ $examples + { $example "USING: alien.c-types alien.data prettyprint sequences ;" "321 int int deref ." "321" } +} ; + +ARTICLE: "c-out-params" "Output parameters in C" +"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations." +{ $subsection with-out-parameters } ; diff --git a/basis/alien/data/data-tests.factor b/basis/alien/data/data-tests.factor index 20a6c26b84..7d53c71815 100644 --- a/basis/alien/data/data-tests.factor +++ b/basis/alien/data/data-tests.factor @@ -1,9 +1,32 @@ -USING: alien alien.c-types alien.data alien.syntax +USING: alien alien.data alien.syntax classes.struct kernel sequences specialized-arrays -specialized-arrays.private tools.test compiler.units vocabs ; +specialized-arrays.private tools.test compiler.units vocabs +system ; +QUALIFIED-WITH: alien.c-types c IN: alien.data.tests -STRUCT: foo { a int } { b void* } { c bool } ; +[ -1 ] [ -1 c:char c:char deref ] unit-test +[ -1 ] [ -1 c:short c:short deref ] unit-test +[ -1 ] [ -1 c:int c:int deref ] unit-test + +! I don't care if this throws an error or works, but at least +! it should be consistent between platforms +[ -1 ] [ -1.0 c:int c:int deref ] unit-test +[ -1 ] [ -1.0 c:long c:long deref ] unit-test +[ -1 ] [ -1.0 c:longlong c:longlong deref ] unit-test +[ 1 ] [ 1.0 c:uint c:uint deref ] unit-test +[ 1 ] [ 1.0 c:ulong c:ulong deref ] unit-test +[ 1 ] [ 1.0 c:ulonglong c:ulonglong deref ] unit-test + +[ + 0 B{ 1 2 3 4 } c:void* +] must-fail + +os windows? cpu x86.64? and [ + [ -2147467259 ] [ 2147500037 c:long c:long deref ] unit-test +] when + +STRUCT: foo { a c:int } { b c:void* } { c c:bool } ; SPECIALIZED-ARRAY: foo diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index 52ccf6f6d1..f52b1a7f25 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -1,15 +1,20 @@ ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license -USING: accessors alien alien.c-types alien.arrays alien.strings -arrays byte-arrays cpu.architecture fry io io.encodings.binary -io.files io.streams.memory kernel libc math math.functions -sequences words macros combinators generalizations -stack-checker.dependencies combinators.short-circuit ; +USING: accessors alien alien.arrays alien.c-types alien.strings +arrays byte-arrays combinators combinators.short-circuit +cpu.architecture fry generalizations io io.streams.memory kernel +libc locals macros math math.functions parser sequences +stack-checker.dependencies summary words ; QUALIFIED: math IN: alien.data -GENERIC: require-c-array ( c-type -- ) +: ( value c-type -- c-ptr ) + [ heap-size ] keep + '[ 0 _ set-alien-value ] keep ; inline -M: array require-c-array first require-c-array ; +: deref ( c-ptr c-type -- value ) + [ 0 ] dip alien-value ; inline + +: little-endian? ( -- ? ) 1 int char deref 1 = ; foldable GENERIC: c-array-constructor ( c-type -- word ) foldable @@ -17,6 +22,26 @@ GENERIC: c-(array)-constructor ( c-type -- word ) foldable GENERIC: c-direct-array-constructor ( c-type -- word ) foldable +GENERIC: c-array-type ( c-type -- word ) foldable + +GENERIC: c-array-type? ( c-type -- word ) foldable + +GENERIC: c-array? ( obj c-type -- ? ) foldable + +M: word c-array? + c-array-type? execute( seq -- array ) ; inline + +M: pointer c-array? + drop void* c-array? ; + +GENERIC: >c-array ( seq c-type -- array ) + +M: word >c-array + c-array-type new clone-like ; inline + +M: pointer >c-array + drop void* >c-array ; + GENERIC: ( len c-type -- array ) M: word @@ -41,24 +66,24 @@ M: word M: pointer drop void* ; -: malloc-array ( n type -- array ) +SYNTAX: c-array{ \ } [ unclip >c-array ] parse-literal ; + +SYNTAX: c-array@ + scan-object [ scan-object scan-object ] dip + suffix! ; + +ERROR: bad-byte-array-length byte-array type ; + +M: bad-byte-array-length summary + drop "Byte array length doesn't divide type width" ; + +: cast-array ( byte-array c-type -- array ) + [ binary-object ] dip [ heap-size /mod 0 = ] keep swap + [ ] [ bad-byte-array-length ] if ; inline + +: malloc-array ( n c-type -- array ) [ heap-size calloc ] [ ] 2bi ; inline -: (malloc-array) ( n type -- alien ) - [ heap-size * malloc ] [ ] 2bi ; inline - -: ( type -- array ) - heap-size ; 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 ; @@ -68,11 +93,11 @@ M: pointer : malloc-string ( string encoding -- alien ) string>alien malloc-byte-array ; -M: memory-stream stream-read - [ - [ index>> ] [ alien>> ] bi - swap memory>byte-array - ] [ [ + ] change-index drop ] 2bi ; +M:: memory-stream stream-read-unsafe ( n buf stream -- count ) + stream alien>> :> src + buf src n memcpy + n src stream alien<< + n ; inline M: value-type c-type-rep drop int-rep ; @@ -102,7 +127,7 @@ ERROR: local-allocation-error ; ; MACRO: (simple-local-allot) ( c-type -- quot ) - [ depends-on-c-type ] + [ add-depends-on-c-type ] [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ; : [hairy-local-allot] ( c-type initial -- quot ) diff --git a/basis/alarms/authors.txt b/basis/alien/endian/authors.txt similarity index 100% rename from basis/alarms/authors.txt rename to basis/alien/endian/authors.txt diff --git a/basis/alien/endian/endian-docs.factor b/basis/alien/endian/endian-docs.factor new file mode 100644 index 0000000000..c15bc7d186 --- /dev/null +++ b/basis/alien/endian/endian-docs.factor @@ -0,0 +1,150 @@ +! Copyright (C) 2011 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel math quotations +classes.struct ; +IN: alien.endian + +HELP: BE-PACKED-STRUCT: +{ $description "Defines a packed " { $link struct } " where endian-unaware types become big-endian types. Note that endian-aware types will override the big-endianness of this " { $link struct } " declaration; little-endian types will stay little-endian. On big-endian platforms, the endian-unaware types will not change since they are the correct endianness already." } +{ $unchecked-example + "! When run on a big-endian platform, this struct should prettyprint the same as defined" + "! The output of this example is from a little-endian platform" + "USE: alien.endian" + "BE-PACKED-STRUCT: s1 { a char[7] } { b int } ;" + "\\ s1 see" + "USING: alien.c-types alien.endian classes.struct ; +IN: scratchpad +STRUCT: s1 { a char[7] } { b be32 initial: 0 } ;" +} ; + +HELP: BE-STRUCT: +{ $description "Defines a " { $link struct } " where endian-unaware types become big-endian types. Note that endian-aware types will override the big-endianness of this " { $link struct } " declaration; little-endian types will stay little-endian. On big-endian platforms, the endian-unaware types will not change since they are the correct endianness already." } +{ $unchecked-example + "! When run on a big-endian platform, this struct should prettyprint the same as defined" + "! The output of this example is from a little-endian platform" + "USE: alien.endian" + "BE-STRUCT: s1 { a int } { b le32 } ;" + "\\ s1 see" + "USING: alien.c-types alien.endian classes.struct ; +IN: scratchpad +STRUCT: s1 { a be32 initial: 0 } { b le32 initial: 0 } ;" +} ; + +HELP: LE-PACKED-STRUCT: +{ $description "Defines a packed " { $link struct } " where endian-unaware types become little-endian types. Note that endian-aware types will override the little-endianness of this " { $link struct } " declaration; big-endian types will stay big-endian. On little-endian platforms, the endian-unaware types will not change since they are the correct endianness already." } +{ $unchecked-example + "! When run on a little-endian platform, this struct should prettyprint the same as defined" + "! The output of this example is from a little-endian platform" + "USE: alien.endian" + "LE-PACKED-STRUCT: s1 { a char[7] } { b int } ;" + "\\ s1 see" + "USING: alien.c-types alien.endian classes.struct ; +IN: scratchpad +STRUCT: s1 { a char[7] } { b int initial: 0 } ;" +} ; + +HELP: LE-STRUCT: +{ $description "Defines a " { $link struct } " where endian-unaware types become little-endian types. Note that endian-aware types will override the little-endianness of this " { $link struct } " declaration; big-endian types will stay big-endian. On little-endian platforms, the endian-unaware types will not change since they are the correct endianness already." } +{ $unchecked-example + "! When run on a little-endian platform, this struct should prettyprint the same as defined" + "! The output of this example is from a little-endian platform" + "USE: alien.endian" + "LE-STRUCT: s1 { a int } { b be32 } ;" + "\\ s1 see" + "USING: alien.c-types alien.endian classes.struct ; +IN: scratchpad +STRUCT: s1 { a int initial: 0 } { b be32 initial: 0 } ;" +} ; + +HELP: be16 +{ $var-description "Signed bit-endian 16-bit." } ; + +HELP: be32 +{ $var-description "Signed bit-endian 32-bit." } ; + +HELP: be64 +{ $var-description "Signed bit-endian 64-bit." } ; + +HELP: be8 +{ $var-description "Signed bit-endian 8-bit." } ; + +HELP: byte-reverse +{ $values + { "n" integer } { "signed?" boolean } + { "quot" quotation } +} +{ $description "Reverses the " { $snippet "n" } " bytes in an integer with bitwise operations. The second parameter only works for 1, 2, 4, or 8 byte signed numbers." } ; + +HELP: le16 +{ $var-description "Signed little-endian 16-bit." } ; + +HELP: le32 +{ $var-description "Signed little-endian 32-bit." } ; + +HELP: le64 +{ $var-description "Signed little-endian 64-bit." } ; + +HELP: le8 +{ $var-description "Signed little-endian 8-bit." } ; + +HELP: ube16 +{ $var-description "Unsigned big-endian 16-bit." } ; + +HELP: ube32 +{ $var-description "Unsigned big-endian 32-bit." } ; + +HELP: ube64 +{ $var-description "Unsigned big-endian 64-bit." } ; + +HELP: ube8 +{ $var-description "Unsigned big-endian 8-bit." } ; + +HELP: ule16 +{ $var-description "Unsigned little-endian 16-bit." } ; + +HELP: ule32 +{ $var-description "Unsigned little-endian 32-bit." } ; + +HELP: ule64 +{ $var-description "Unsigned little-endian 64-bit." } ; + +HELP: ule8 +{ $var-description "Unsigned little-endian 8-bit." } ; + +ARTICLE: "alien.endian" "Alien endian-aware types" +"The " { $vocab-link "alien.endian" } " vocabulary defines c-types that are endian-aware for use in structs. These types will cause the bytes in a byte-array to be interpreted as little or big-endian transparently when reading or writing. There are both signed and unsigned types defined; signed is the default while unsigned are prefixed with a " { $snippet "u" } ". The intended use-case is for network protocols in network-byte-order (big-endian)." $nl +"Byte-reversal of integers:" +{ $subsections + byte-reverse +} +"The big-endian c-types are:" +{ $subsections + be8 + be16 + be32 + be64 + ube8 + ube16 + ube32 + ube64 +} +"The little-endian c-types are:" +{ $subsections + le8 + le16 + le32 + le64 + ule8 + ule16 + ule32 + ule64 +} +"Syntax for making endian-aware structs out of native types:" +{ $subsections + POSTPONE: LE-STRUCT: + POSTPONE: BE-STRUCT: + POSTPONE: LE-PACKED-STRUCT: + POSTPONE: BE-PACKED-STRUCT: +} ; + +ABOUT: "alien.endian" diff --git a/basis/alien/endian/endian-tests.factor b/basis/alien/endian/endian-tests.factor new file mode 100644 index 0000000000..6c083df8e7 --- /dev/null +++ b/basis/alien/endian/endian-tests.factor @@ -0,0 +1,241 @@ +! Copyright (C) 2011 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.endian classes.struct io +io.encodings.binary io.streams.byte-array kernel tools.test +alien.c-types ; +IN: alien.endian.tests + +STRUCT: endian-struct + { a ule16 } + { b le16 } + { c ube16 } + { d be16 } + { e ule32 } + { f le32 } + { g ube32 } + { h be32 } + { i ule64 } + { j le64 } + { k ube64 } + { l be64 } ; + +CONSTANT: endian-bytes-0f B{ + 0x0 0xff + 0x0 0xff + 0x0 0xff + 0x0 0xff + + 0x0 0x0 0x0 0xff + 0x0 0x0 0x0 0xff + 0x0 0x0 0x0 0xff + 0x0 0x0 0x0 0xff + + 0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff + 0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff + 0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff + 0x0 0x0 0x0 0x0 0x0 0x0 0x0 0xff + } + +CONSTANT: endian-bytes-f0 B{ + 0xff 0x0 + 0xff 0x0 + 0xff 0x0 + 0xff 0x0 + + 0xff 0x0 0x0 0x0 + 0xff 0x0 0x0 0x0 + 0xff 0x0 0x0 0x0 + 0xff 0x0 0x0 0x0 + + 0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0 + 0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0 + 0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0 + 0xff 0x0 0x0 0x0 0x0 0x0 0x0 0x0 + } + +: endian-test-struct-0f ( -- obj ) + endian-bytes-0f endian-struct memory>struct ; + +: endian-test-struct-f0 ( -- obj ) + endian-bytes-f0 endian-struct memory>struct ; + +[ 0xff00 ] [ endian-test-struct-0f a>> ] unit-test +[ -256 ] [ endian-test-struct-0f b>> ] unit-test +[ 0x00ff ] [ endian-test-struct-0f c>> ] unit-test +[ 0x00ff ] [ endian-test-struct-0f d>> ] unit-test + +[ 0xff000000 ] [ endian-test-struct-0f e>> ] unit-test +[ -16777216 ] [ endian-test-struct-0f f>> ] unit-test +[ 0x000000ff ] [ endian-test-struct-0f g>> ] unit-test +[ 0x000000ff ] [ endian-test-struct-0f h>> ] unit-test + +[ 0xff00000000000000 ] [ endian-test-struct-0f i>> ] unit-test +[ -72057594037927936 ] [ endian-test-struct-0f j>> ] unit-test +[ 0x00000000000000ff ] [ endian-test-struct-0f k>> ] unit-test +[ 0x00000000000000ff ] [ endian-test-struct-0f l>> ] unit-test + + +[ 0xff00 ] [ endian-test-struct-f0 c>> ] unit-test +[ -256 ] [ endian-test-struct-f0 d>> ] unit-test +[ 0x00ff ] [ endian-test-struct-f0 a>> ] unit-test +[ 0x00ff ] [ endian-test-struct-f0 b>> ] unit-test + +[ 0xff000000 ] [ endian-test-struct-f0 g>> ] unit-test +[ -16777216 ] [ endian-test-struct-f0 h>> ] unit-test +[ 0x000000ff ] [ endian-test-struct-f0 e>> ] unit-test +[ 0x000000ff ] [ endian-test-struct-f0 f>> ] unit-test + +[ 0xff00000000000000 ] [ endian-test-struct-f0 k>> ] unit-test +[ -72057594037927936 ] [ endian-test-struct-f0 l>> ] unit-test +[ 0x00000000000000ff ] [ endian-test-struct-f0 i>> ] unit-test +[ 0x00000000000000ff ] [ endian-test-struct-f0 j>> ] unit-test + +[ t ] +[ endian-test-struct-0f binary [ write ] with-byte-writer endian-bytes-0f = ] unit-test + +[ t ] +[ endian-test-struct-f0 binary [ write ] with-byte-writer endian-bytes-f0 = ] unit-test + +LE-STRUCT: le-endian-struct + { a ule16 } + { b le16 } + { c ube16 } + { d be16 } + { e ule32 } + { f le32 } + { g ube32 } + { h be32 } + { i ule64 } + { j le64 } + { k ube64 } + { l be64 } ; + +[ t ] +[ + endian-bytes-0f le-endian-struct memory>struct + binary [ write ] with-byte-writer endian-bytes-0f = +] unit-test + +[ t ] +[ + endian-bytes-f0 le-endian-struct memory>struct + binary [ write ] with-byte-writer endian-bytes-f0 = +] unit-test + + +BE-STRUCT: be-endian-struct + { a ule16 } + { b le16 } + { c ube16 } + { d be16 } + { e ule32 } + { f le32 } + { g ube32 } + { h be32 } + { i ule64 } + { j le64 } + { k ube64 } + { l be64 } ; + +[ t ] +[ + endian-bytes-0f be-endian-struct memory>struct + binary [ write ] with-byte-writer endian-bytes-0f = +] unit-test + +[ t ] +[ + endian-bytes-f0 be-endian-struct memory>struct + binary [ write ] with-byte-writer endian-bytes-f0 = +] unit-test + +LE-STRUCT: le-override-struct + { a ushort } + { b short } + { c ube16 } + { d be16 } + { e uint } + { f int } + { g ube32 } + { h be32 } + { i ulonglong } + { j longlong } + { k ube64 } + { l be64 } ; + +[ t ] +[ + endian-bytes-0f le-override-struct memory>struct + binary [ write ] with-byte-writer endian-bytes-0f = +] unit-test + +[ t ] +[ + endian-bytes-f0 le-override-struct memory>struct + binary [ write ] with-byte-writer endian-bytes-f0 = +] unit-test + +BE-STRUCT: be-override-struct + { a ule16 } + { b le16 } + { c ushort } + { d short } + { e ule32 } + { f le32 } + { g uint } + { h int } + { i ule64 } + { j le64 } + { k ulonglong } + { l longlong } ; + +[ t ] +[ + endian-bytes-0f be-override-struct memory>struct + binary [ write ] with-byte-writer endian-bytes-0f = +] unit-test + +[ t ] +[ + endian-bytes-f0 be-override-struct memory>struct + binary [ write ] with-byte-writer endian-bytes-f0 = +] unit-test + + +LE-PACKED-STRUCT: le-packed-struct + { a char[7] } + { b int } ; + +[ t ] +[ + B{ 0 0 0 0 0 0 0 3 0 0 0 } [ + le-packed-struct memory>struct + binary [ write ] with-byte-writer + ] keep = +] unit-test + +[ 3 ] +[ + B{ 0 0 0 0 0 0 0 3 0 0 0 } le-packed-struct memory>struct + b>> +] unit-test + + +BE-PACKED-STRUCT: be-packed-struct + { a char[7] } + { b int } ; + +[ t ] +[ + B{ 0 0 0 0 0 0 0 0 0 0 3 } [ + be-packed-struct memory>struct + binary [ write ] with-byte-writer + ] keep = +] unit-test + +[ 3 ] +[ + B{ 0 0 0 0 0 0 0 0 0 0 3 } be-packed-struct memory>struct + b>> +] unit-test + diff --git a/basis/alien/endian/endian.factor b/basis/alien/endian/endian.factor new file mode 100644 index 0000000000..f7cc0b0f97 --- /dev/null +++ b/basis/alien/endian/endian.factor @@ -0,0 +1,163 @@ +! Copyright (C) 2011 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.accessors alien.c-types alien.data +classes.struct.private combinators compiler.units endian fry +generalizations kernel macros math namespaces sequences words +arrays slots math.bitwise ; +QUALIFIED-WITH: alien.c-types ac +IN: alien.endian + +ERROR: invalid-signed-conversion n ; + +: convert-signed-quot ( n -- quot ) + { + { 1 [ [ char char deref ] ] } + { 2 [ [ ac:short ac:short deref ] ] } + { 4 [ [ int int deref ] ] } + { 8 [ [ longlong longlong deref ] ] } + [ invalid-signed-conversion ] + } case ; inline + +MACRO: byte-reverse ( n signed? -- quot ) + [ + drop + [ + dup iota [ + [ 1 + - -8 * ] [ nip 8 * ] 2bi + '[ _ shift 0xff bitand _ shift ] + ] with map + ] [ 1 - [ bitor ] n*quot ] bi + ] [ + [ convert-signed-quot ] [ drop [ ] ] if + ] 2bi + '[ _ cleave @ @ ] ; + +SYMBOLS: le8 be8 ule8 ube8 +ule16 ule32 ule64 ube16 ube32 ube64 +le16 le32 le64 be16 be32 be64 ; + +: endian-c-type? ( symbol -- ? ) + { + le8 be8 ule8 ube8 ule16 ule32 ule64 + ube16 ube32 ube64 le16 le32 le64 be16 be32 be64 + } member? ; + +ERROR: unknown-endian-c-type symbol ; + +: endian-c-type>c-type-symbol ( symbol -- symbol' ) + { + { [ dup { ule16 ube16 } member? ] [ drop ushort ] } + { [ dup { le16 be16 } member? ] [ drop ac:short ] } + { [ dup { ule32 ube32 } member? ] [ drop uint ] } + { [ dup { le32 be32 } member? ] [ drop int ] } + { [ dup { ule64 ube64 } member? ] [ drop ulonglong ] } + { [ dup { le64 be64 } member? ] [ drop longlong ] } + [ unknown-endian-c-type ] + } cond ; + +: change-c-type-accessors ( n ? c-type -- c-type' ) + endian-c-type>c-type-symbol "c-type" word-prop clone + -rot over 8 = [ + [ + nip + [ + [ + [ alien-unsigned-4 4 f byte-reverse 32 shift ] + [ 4 + alien-unsigned-4 4 f byte-reverse ] 2bi bitor + ] + ] dip [ [ 64 >signed ] compose ] when + >>getter drop + ] + [ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi + ] [ + [ '[ [ _ _ byte-reverse ] compose ] change-getter drop ] + [ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi + ] if ; + +: typedef-endian ( n ? c-type endian -- ) + native-endianness get = [ + 2nip [ endian-c-type>c-type-symbol ] keep typedef + ] [ + [ change-c-type-accessors ] keep typedef + ] if ; + +: typedef-le ( n ? c-type -- ) little-endian typedef-endian ; +: typedef-be ( n ? c-type -- ) big-endian typedef-endian ; + +[ + \ char \ le8 typedef + \ char \ be8 typedef + \ uchar \ ule8 typedef + \ uchar \ ube8 typedef + 2 f \ ule16 typedef-le + 2 f \ ube16 typedef-be + 2 t \ le16 typedef-le + 2 t \ be16 typedef-be + 4 f \ ule32 typedef-le + 4 f \ ube32 typedef-be + 4 t \ le32 typedef-le + 4 t \ be32 typedef-be + 8 f \ ule64 typedef-le + 8 f \ ube64 typedef-be + 8 t \ le64 typedef-le + 8 t \ be64 typedef-be +] with-compilation-unit + +! pair: { le be } +: pair>c-type ( pair -- c-type ) + [ native-endianness get big-endian = ] dip first2 ? ; + +! endian is desired endian type. if we match endianness, return the c type +! otherwise return the opposite of our endianness +: endian-slot ( endian c-type pair -- endian-slot ) + [ native-endianness get = ] 2dip rot [ drop ] [ nip pair>c-type ] if ; + +ERROR: unsupported-endian-type endian slot ; + +: slot>endian-slot ( endian slot -- endian-slot ) + dup array? [ + first2 [ slot>endian-slot ] dip 2array + ] [ + { + { [ dup char = ] [ 2drop char ] } + { [ dup uchar = ] [ 2drop uchar ] } + { [ dup ac:short = ] [ { le16 be16 } endian-slot ] } + { [ dup ushort = ] [ { ule16 ube16 } endian-slot ] } + { [ dup int = ] [ { le32 be32 } endian-slot ] } + { [ dup uint = ] [ { ule32 ube32 } endian-slot ] } + { [ dup longlong = ] [ { le64 be64 } endian-slot ] } + { [ dup ulonglong = ] [ { ule64 ube64 } endian-slot ] } + { [ dup endian-c-type? ] [ nip ] } + [ unsupported-endian-type ] + } cond + ] if ; + +: set-endian-slots ( endian slots -- slot-specs ) + [ [ slot>endian-slot ] change-type ] with map ; + +: define-endian-struct-class ( class slots endian -- ) + swap make-slots set-endian-slots + [ compute-struct-offsets ] [ struct-alignment ] + (define-struct-class) ; + +: define-endian-packed-struct-class ( class slots endian -- ) + swap make-packed-slots set-endian-slots + [ compute-struct-offsets ] [ drop 1 ] + (define-struct-class) ; + +SYNTAX: LE-STRUCT: + parse-struct-definition + little-endian define-endian-struct-class ; + +SYNTAX: BE-STRUCT: + parse-struct-definition + big-endian define-endian-struct-class ; + +SYNTAX: LE-PACKED-STRUCT: + parse-struct-definition + little-endian define-endian-packed-struct-class ; + +SYNTAX: BE-PACKED-STRUCT: + parse-struct-definition + big-endian define-endian-packed-struct-class ; + diff --git a/basis/alien/enums/enums-docs.factor b/basis/alien/enums/enums-docs.factor index cc23a40df3..0625b07799 100644 --- a/basis/alien/enums/enums-docs.factor +++ b/basis/alien/enums/enums-docs.factor @@ -23,14 +23,6 @@ HELP: number>enum } { $description "Convert a number to an enum." } ; -ARTICLE: "alien.enums" "Enumeration types" -"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum symbols and integers." -$nl -"Defining enums at run-time:" -{ $subsection define-enum } -"Conversions between enums and integers:" -{ $subsections enum>number number>enum } ; - { POSTPONE: ENUM: define-enum enum>number number>enum } related-words ABOUT: "alien.enums" diff --git a/basis/alien/enums/enums-tests.factor b/basis/alien/enums/enums-tests.factor index f0c665830d..a7fd665e13 100644 --- a/basis/alien/enums/enums-tests.factor +++ b/basis/alien/enums/enums-tests.factor @@ -33,3 +33,19 @@ ENUM: instrument_t < ushort trombone trumpet ; { V{ { red 0 } { green 3 } { blue 4 } } } [ color_t "c-type" word-prop members>> ] unit-test + +ENUM: colores { rojo red } { verde green } { azul blue } { colorado rojo } ; + +[ { 0 3 4 0 } ] [ { rojo verde azul colorado } [ enum>number ] map ] unit-test + +SYMBOLS: couleurs rouge vert bleu jaune azure ; + +<< \ couleurs int { + { rouge red } + { vert green } + { bleu blue } + { jaune 14 } + { azure bleu } +} define-enum >> + +[ { 0 3 4 14 4 } ] [ { rouge vert bleu jaune azure } [ enum>number ] map ] unit-test diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor index 18000105e7..cd4225c4ab 100644 --- a/basis/alien/enums/enums.factor +++ b/basis/alien/enums/enums.factor @@ -1,6 +1,7 @@ ! (c)2010 Joe Groff, Erik Charlebois bsd license USING: accessors alien.c-types arrays combinators delegate fry -generic.parser kernel macros math parser sequences words words.symbol ; +generic.parser kernel macros math parser sequences words words.symbol +classes.singleton assocs ; IN: alien.enums GENERIC: enum>number ( enum -- number ) foldable M: integer enum>number ; -M: symbol enum>number "enum-value" word-prop ; +M: word enum>number "enum-value" word-prop ; number "enum-value" word-prop ; PRIVATE> MACRO: number>enum ( enum-c-type -- ) - c-type members>> enum-boxer ; + lookup-c-type members>> enum-boxer ; M: enum-c-type c-type-boxed-class drop object ; M: enum-c-type c-type-boxer-quot members>> enum-boxer ; @@ -29,27 +30,28 @@ M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ; M: enum-c-type c-type-setter [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ; +: define-enum-value ( class value -- ) + enum>number "enum-value" set-word-prop ; + > "<" ">" surround create-in ] keep - [ number>enum ] curry (( number -- enum )) define-inline ; + [ number>enum ] curry ( number -- enum ) define-inline ; PRIVATE> -: define-enum ( word base-type members -- ) +: (define-enum) ( word base-type members -- ) [ dup define-enum-constructor ] 2dip - dup define-enum-members - swap typedef ; + [ define-enum-members ] + [ swap typedef ] bi ; + +: define-enum ( word base-type members -- ) + [ (define-enum) ] + [ [ define-enum-value ] assoc-each ] bi ; PREDICATE: enum-c-type-word < c-type-word "c-type" word-prop enum-c-type? ; diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor index 8676ac8c58..f9828e2835 100644 --- a/basis/alien/libraries/libraries-docs.factor +++ b/basis/alien/libraries/libraries-docs.factor @@ -24,17 +24,17 @@ HELP: library } } ; -HELP: dlopen ( path -- dll ) +HELP: dlopen { $values { "path" "a pathname string" } { "dll" "a DLL handle" } } { $description "Opens a native library and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } "." } { $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } { $notes "This is the low-level facility used to implement " { $link load-library } ". Use the latter instead." } ; -HELP: dlsym ( name dll -- alien ) +HELP: dlsym { $values { "name" "a C symbol name" } { "dll" "a DLL handle" } { "alien" { $maybe alien } } } { $description "Looks up a symbol in a native library. If " { $snippet "dll" } " is " { $link f } " looks for the symbol in the runtime executable. If the symbol was not found, outputs " { $link f } "." } ; -HELP: dlclose ( dll -- ) +HELP: dlclose { $values { "dll" "a DLL handle" } } { $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ; diff --git a/basis/alien/libraries/libraries-tests.factor b/basis/alien/libraries/libraries-tests.factor old mode 100644 new mode 100755 index f1dc228d83..2721ce48c0 --- a/basis/alien/libraries/libraries-tests.factor +++ b/basis/alien/libraries/libraries-tests.factor @@ -1,4 +1,4 @@ -USING: alien.libraries alien.syntax tools.test kernel ; +USING: alien alien.libraries alien.syntax tools.test kernel ; IN: alien.libraries.tests [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test @@ -8,3 +8,21 @@ IN: alien.libraries.tests [ ] [ "doesnotexist" dlopen dlclose ] unit-test [ "fdasfsf" dll-valid? drop ] must-fail + +[ t ] [ + "test-library" "blah" cdecl add-library + "test-library" "BLAH" cdecl add-library? + "blah" remove-library +] unit-test + +[ t ] [ + "test-library" "blah" cdecl add-library + "test-library" "blah" stdcall add-library? + "blah" remove-library +] unit-test + +[ f ] [ + "test-library" "blah" cdecl add-library + "test-library" "blah" cdecl add-library? + "blah" remove-library +] unit-test diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor index a3f52df098..a046e3b9f5 100755 --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -2,28 +2,37 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.strings assocs io.backend kernel namespaces destructors sequences strings -system io.pathnames ; +system io.pathnames fry combinators vocabs ; IN: alien.libraries : dlopen ( path -- dll ) native-string>alien (dlopen) ; : dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ; +: dlsym-raw ( name dll -- alien ) [ string>symbol ] dip (dlsym-raw) ; + +HOOK: dlerror os ( -- message/f ) + SYMBOL: libraries libraries [ H{ } clone ] initialize -TUPLE: library { path string } { abi abi initial: cdecl } dll ; +TUPLE: library { path string } { abi abi initial: cdecl } dll dlerror ; ERROR: no-library name ; : library ( name -- library ) libraries get at ; : ( path abi -- library ) - over dup [ dlopen ] when \ library boa ; + over dup + [ dlopen dup dll-valid? [ f ] [ dlerror ] if ] [ f ] if + \ library boa ; + +: library-dll ( library -- dll ) + dup [ dll>> ] when ; : load-library ( name -- dll ) - library dup [ dll>> ] when ; + library library-dll ; M: dll dispose dlclose ; @@ -32,9 +41,15 @@ M: library dispose dll>> [ dispose ] when* ; : remove-library ( name -- ) libraries get delete-at* [ dispose ] [ drop ] if ; +: add-library? ( name path abi -- ? ) + [ library ] 2dip + '[ [ path>> _ = ] [ abi>> _ = ] bi and not ] [ t ] if* ; + : add-library ( name path abi -- ) - [ 2drop remove-library ] - [ swap libraries get set-at ] 3bi ; + 3dup add-library? [ + [ 2drop remove-library ] + [ swap libraries get set-at ] 3bi + ] [ 3drop ] if ; : library-abi ( library -- abi ) library [ abi>> ] [ cdecl ] if* ; @@ -42,7 +57,7 @@ M: library dispose dll>> [ dispose ] when* ; ERROR: no-such-symbol name library ; : address-of ( name library -- value ) - 2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ; + 2dup load-library dlsym-raw [ 2nip ] [ no-such-symbol ] if* ; SYMBOL: deploy-libraries @@ -53,17 +68,9 @@ deploy-libraries [ V{ } clone ] initialize [ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ] [ no-library ] if ; -deployed-library-path os ( path -- path' ) -M: windows >deployed-library-path - file-name ; - -M: unix >deployed-library-path - file-name "$ORIGIN" prepend-path ; - -M: macosx >deployed-library-path - file-name "@executable_path/../Frameworks" prepend-path ; - -PRIVATE> +<< { + { [ os windows? ] [ "alien.libraries.windows" ] } + { [ os unix? ] [ "alien.libraries.unix" ] } +} cond require >> diff --git a/extra/io/serial/unix/platforms.txt b/basis/alien/libraries/unix/platforms.txt similarity index 100% rename from extra/io/serial/unix/platforms.txt rename to basis/alien/libraries/unix/platforms.txt diff --git a/basis/alien/libraries/unix/unix.factor b/basis/alien/libraries/unix/unix.factor new file mode 100644 index 0000000000..612c656c07 --- /dev/null +++ b/basis/alien/libraries/unix/unix.factor @@ -0,0 +1,15 @@ +USING: alien.c-types alien.libraries alien io.encodings.utf8 +io.pathnames system ; +IN: alien.libraries.unix + +: (dlerror) ( -- string ) + \ c-string f "dlerror" { } alien-invoke ; inline + +M: unix dlerror (dlerror) ; + +M: unix >deployed-library-path + file-name "$ORIGIN" prepend-path ; + +M: macosx >deployed-library-path + file-name "@executable_path/../Frameworks" prepend-path ; + diff --git a/basis/io/backend/windows/privileges/platforms.txt b/basis/alien/libraries/windows/platforms.txt similarity index 100% rename from basis/io/backend/windows/privileges/platforms.txt rename to basis/alien/libraries/windows/platforms.txt diff --git a/basis/alien/libraries/windows/windows.factor b/basis/alien/libraries/windows/windows.factor new file mode 100644 index 0000000000..249bcff57a --- /dev/null +++ b/basis/alien/libraries/windows/windows.factor @@ -0,0 +1,8 @@ +USING: alien.libraries io.pathnames system windows.errors ; +IN: alien.libraries.windows + +M: windows >deployed-library-path + file-name ; + +M: windows dlerror ( -- message ) + win32-error-string ; diff --git a/basis/alien/parser/parser-tests.factor b/basis/alien/parser/parser-tests.factor index 17f417b48d..2333eb3725 100644 --- a/basis/alien/parser/parser-tests.factor +++ b/basis/alien/parser/parser-tests.factor @@ -38,7 +38,7 @@ CONSTANT: eleven 11 FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ; -[ (( arg1 arg2 -- void* )) ] [ +[ ( arg1 arg2 -- void* ) ] [ \ alien-parser-function-effect-test "declared-effect" word-prop ] unit-test @@ -46,7 +46,7 @@ FUNCTION: void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ; FUNCTION-ALIAS: (alien-parser-function-effect-test) void* alien-parser-function-effect-test ( int *arg1 float arg2 ) ; -[ (( arg1 arg2 -- void* )) ] [ +[ ( arg1 arg2 -- void* ) ] [ \ (alien-parser-function-effect-test) "declared-effect" word-prop ] unit-test @@ -54,7 +54,7 @@ FUNCTION-ALIAS: (alien-parser-function-effect-test) void* alien-parser-function- CALLBACK: void* alien-parser-callback-effect-test ( int *arg1 float arg2 ) ; -[ (( arg1 arg2 -- void* )) ] [ +[ ( arg1 arg2 -- void* ) ] [ \ alien-parser-callback-effect-test "callback-effect" word-prop ] unit-test diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 84db07c5ed..e3c33a3ba0 100755 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -4,21 +4,18 @@ USING: accessors alien alien.c-types alien.libraries arrays assocs classes combinators combinators.short-circuit compiler.units effects grouping kernel parser sequences splitting words fry locals lexer namespaces summary math -vocabs.parser words.constant ; +vocabs.parser words.constant classes.parser alien.enums ; IN: alien.parser SYMBOL: current-library -: parse-c-type-name ( name -- word ) - dup search [ ] [ no-word ] ?if ; - DEFER: (parse-c-type) ERROR: bad-array-type ; : parse-array-type ( name -- c-type ) "[" split unclip - [ [ "]" ?tail [ bad-array-type ] unless parse-word ] map ] + [ [ "]" ?tail [ bad-array-type ] unless parse-datum ] map ] [ (parse-c-type) ] bi* prefix ; @@ -26,8 +23,8 @@ ERROR: bad-array-type ; { { [ "*" ?tail ] [ (parse-c-type) ] } { [ CHAR: ] over member? ] [ parse-array-type ] } - { [ dup search ] [ parse-c-type-name ] } - [ dup search [ ] [ no-word ] ?if ] + { [ dup search ] [ parse-word ] } + [ parse-word ] } cond ; : c-array? ( c-type -- ? ) @@ -70,7 +67,7 @@ ERROR: *-in-c-type-name name ; } cleave ; : CREATE-C-TYPE ( -- word ) - scan (CREATE-C-TYPE) ; + scan-token (CREATE-C-TYPE) ; > return-type-name CHAR: * suffix ; [ [ ] dip parse-pointers ] when ; : next-enum-member ( members name value -- members value' ) - [ 2array suffix! ] [ 1 + ] bi ; + [ define-enum-value ] + [ [ 2array suffix! ] [ enum>number 1 + ] bi ] 2bi ; : parse-enum-name ( -- name ) - scan (CREATE-C-TYPE) dup save-location ; + CREATE-C-TYPE dup save-location ; : parse-enum-base-type ( -- base-type token ) - scan dup "<" = - [ drop scan-object scan ] + scan-token dup "<" = + [ drop scan-object scan-token ] [ [ int ] dip ] if ; : parse-enum-member ( members name value -- members value' ) over "{" = - [ 2drop scan create-in scan-object next-enum-member "}" expect ] - [ [ create-in ] dip next-enum-member ] if ; + [ 2drop scan-token create-class-in scan-object next-enum-member "}" expect ] + [ [ create-class-in ] dip next-enum-member ] if ; : parse-enum-members ( members counter token -- members ) dup ";" = not - [ swap parse-enum-member scan parse-enum-members ] [ 2drop ] if ; + [ swap parse-enum-member scan-token parse-enum-members ] [ 2drop ] if ; PRIVATE> @@ -111,14 +109,14 @@ PRIVATE> [ V{ } clone 0 ] dip parse-enum-members ; : scan-function-name ( -- return function ) - scan-c-type scan parse-pointers ; + scan-c-type scan-token parse-pointers ; :: (scan-c-args) ( end-marker types names -- ) - scan :> type-str + scan-token :> type-str type-str end-marker = [ type-str { "(" ")" } member? [ type-str parse-c-type :> type - scan "," ?tail drop :> name + scan-token "," ?tail drop :> name type name parse-pointers :> ( type' name' ) type' types push name' names push ] unless @@ -157,7 +155,7 @@ PRIVATE> void* type-word typedef type-word names return function-effect "callback-effect" set-word-prop type-word lib "callback-library" set-word-prop - type-word return types lib library-abi callback-quot (( quot -- alien )) ; + type-word return types lib library-abi callback-quot ( quot -- alien ) ; : (CALLBACK:) ( -- word quot effect ) current-library get @@ -173,11 +171,22 @@ PREDICATE: alien-function-word < alien-function-alias-word [ def>> third ] [ name>> ] bi = ; PREDICATE: alien-callback-type-word < typedef-word - "callback-effect" word-prop ; + "callback-effect" word-prop >boolean ; : global-quot ( type word -- quot ) swap [ name>> current-library get ] dip '[ _ _ address-of 0 _ alien-value ] ; +: set-global-quot ( type word -- quot ) + swap [ name>> current-library get ] dip + '[ _ _ address-of 0 _ set-alien-value ] ; + +: define-global-getter ( type word -- ) + [ nip ] [ global-quot ] 2bi ( -- value ) define-declared ; + +: define-global-setter ( type word -- ) + [ nip name>> "set-" prepend create-in ] + [ set-global-quot ] 2bi ( obj -- ) define-declared ; + : define-global ( type word -- ) - [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ; + [ define-global-getter ] [ define-global-setter ] 2bi ; diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index 2cf90e938d..f86944e0ed 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/basis/alien/prettyprint/prettyprint.factor @@ -124,7 +124,7 @@ M: enum-c-type-word synopsis* [ seeing-word ] [ definer. ] [ pprint-word ] - [ c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ] + [ lookup-c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ] } cleave ; M: enum-c-type-word definition - c-type members>> ; + lookup-c-type members>> ; diff --git a/basis/alien/remote-control/remote-control-tests.factor b/basis/alien/remote-control/remote-control-tests.factor index 8b6c5e9b22..87a015a59f 100644 --- a/basis/alien/remote-control/remote-control-tests.factor +++ b/basis/alien/remote-control/remote-control-tests.factor @@ -11,7 +11,7 @@ IN: alien.remote-control.tests try-process ; : run-test ( -- line ) - os windows? "temp/a.exe" "temp/a.out" ? + os windows? "a.exe" "a.out" ? ascii [ readln ] with-process-reader ; :: test-embedding ( code -- line ) @@ -36,9 +36,9 @@ int main(int argc, char **argv) } ]I ] with-string-writer - "resource:temp" [ compile-file ] with-directory - "resource:" [ run-test ] with-directory ; + [ compile-file ] with-temp-directory + [ run-test ] with-temp-directory ; ! [ "Done." ] [ "" test-embedding ] unit-test -! [ "Done." ] [ "factor_yield();" test-embedding ] unit-test \ No newline at end of file +! [ "Done." ] [ "factor_yield();" test-embedding ] unit-test diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 5090280945..13b7610648 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -19,8 +19,8 @@ IN: alien.remote-control dup optimized? [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) - \ eval-callback ?callback 16 set-special-object - \ yield-callback ?callback 17 set-special-object - \ sleep-callback ?callback 18 set-special-object ; + \ eval-callback ?callback OBJ-EVAL-CALLBACK set-special-object + \ yield-callback ?callback OBJ-YIELD-CALLBACK set-special-object + \ sleep-callback ?callback OBJ-SLEEP-CALLBACK set-special-object ; MAIN: init-remote-control diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index c7ff228ab2..514d1c7faf 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -83,7 +83,7 @@ HELP: ENUM: HELP: C-TYPE: { $syntax "C-TYPE: type" } { $values { "type" "a new C type" } } -{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a " { $link pointer } "." +{ $description "Defines a new, opaque C type. Since it is opaque, " { $snippet "type" } " will not be directly usable as a parameter or return type of a " { $link POSTPONE: FUNCTION: } " or as a slot of a " { $link POSTPONE: STRUCT: } ". However, it can be used as the type of a " { $link pointer } "." $nl { $snippet "C-TYPE:" } " can also be used to forward declare C types, allowing circular dependencies to occur between types. For example:" { $code """C-TYPE: forward STRUCT: backward { x forward* } ; @@ -122,4 +122,14 @@ HELP: typedef HELP: C-GLOBAL: { $syntax "C-GLOBAL: type name" } { $values { "type" "a C type" } { "name" "a C global variable name" } } -{ $description "Defines a new word named " { $snippet "name" } " which accesses a global variable in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ; +{ $description "Defines a getter " { $snippet "name" } " and setter " { $snippet "set-name" } " for the global value in the current library, set with " { $link POSTPONE: LIBRARY: } "." } ; + +ARTICLE: "alien.enums" "Enumeration types" +"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum singletons and integers. It is possible to dispatch off of members of an enum." +$nl +"Defining enums:" +{ $subsection POSTPONE: ENUM: } +"Defining enums at run-time:" +{ $subsection define-enum } +"Conversions between enums and integers:" +{ $subsections enum>number number>enum } ; diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 259f99a833..3630933899 100755 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -13,7 +13,7 @@ SYNTAX: ALIEN: 16 scan-base suffix! ; SYNTAX: BAD-ALIEN suffix! ; -SYNTAX: LIBRARY: scan current-library set ; +SYNTAX: LIBRARY: scan-token current-library set ; SYNTAX: FUNCTION: (FUNCTION:) make-function define-inline ; @@ -29,15 +29,15 @@ SYNTAX: TYPEDEF: scan-c-type CREATE-C-TYPE dup save-location typedef ; SYNTAX: ENUM: - parse-enum define-enum ; + parse-enum (define-enum) ; SYNTAX: C-TYPE: void CREATE-C-TYPE typedef ; SYNTAX: &: - scan current-library get '[ _ _ address-of ] append! ; + scan-token current-library get '[ _ _ address-of ] append! ; -SYNTAX: C-GLOBAL: scan-c-type CREATE-WORD define-global ; +SYNTAX: C-GLOBAL: scan-c-type scan-new-word define-global ; SYNTAX: pointer: scan-c-type suffix! ; diff --git a/basis/ascii/ascii.factor b/basis/ascii/ascii.factor index bd1b86b279..6f89dea6d9 100644 --- a/basis/ascii/ascii.factor +++ b/basis/ascii/ascii.factor @@ -10,13 +10,13 @@ IN: ascii : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline : digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline : printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline -: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline +: control? ( ch -- ? ) { [ 0 0x1F between? ] [ 0x7F = ] } 1|| ; inline : quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline : Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline : alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline -: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ; inline +: ch>lower ( ch -- lower ) dup LETTER? [ 0x20 + ] when ; inline : >lower ( str -- lower ) [ ch>lower ] map ; -: ch>upper ( ch -- upper ) dup letter? [ HEX: 20 - ] when ; inline +: ch>upper ( ch -- upper ) dup letter? [ 0x20 - ] when ; inline : >upper ( str -- upper ) [ ch>upper ] map ; HINTS: >lower string ; diff --git a/basis/atk/Atk-1.0.gir b/basis/atk/Atk-1.0.gir new file mode 100644 index 0000000000..f14914edd0 --- /dev/null +++ b/basis/atk/Atk-1.0.gir @@ -0,0 +1,9798 @@ + + + + + + + + + This is a singly-linked list (a #GSList) of #AtkAttribute. It is +used by atk_text_get_run_attributes(), atk_text_get_default_attributes() +and atk_editable_text_set_run_attributes() + + + + + + + + Perform the specified action on the object. + + %TRUE if success, %FALSE otherwise + + + + + the action index corresponding to the action to be performed + + + + + + Returns a description of the specified action of the object. +Returns a description string, or %NULL +if @action does not implement this interface. + + + + + + the action index corresponding to the action to be performed + + + + + + Returns a keybinding associated with this action, if one exists. +The returned string is in the format "<a>;<b>;<c>" +(i.e. semicolon-delimited), where <a> is the keybinding which +activates the object if it is presently enabled onscreen, +<b> corresponds to the keybinding or sequence of keys +which invokes the action even if the relevant element is not +currently posted on screen (for instance, for a menu item it +posts the parent menus before invoking). The last token in the +above string, if non-empty, represents a keyboard shortcut which +invokes the same action without posting the component or its +enclosing menus or dialogs. +Returns a string representing the available keybindings, or %NULL +if there is no keybinding for this action. + + + + + + the action index corresponding to the action to be performed + + + + + + Returns the localized name of the specified action of the object. +Returns a name string, or %NULL +if @action does not implement this interface. + + + + + + the action index corresponding to the action to be performed + + + + + + Gets the number of accessible actions available on the object. +If there are more than one, the first one is considered the +"default" action of the object. +implement this interface. + + a the number of actions, or 0 if @action does not + + + + + Returns a non-localized string naming the specified action of the +object. This name is generally not descriptive of the end result +of the action, but instead names the 'interaction type' which the +object supports. By convention, the above strings should be used to +represent the actions which correspond to the common point-and-click +"click", "press", "release", "drag", "drop", "popup", etc. +The "popup" action should be used to pop up a context menu for the +object, if one exists. +For technical reasons, some toolkits cannot guarantee that the +reported action is actually 'bound' to a nontrivial user event; +i.e. the result of some actions via atk_action_do_action() may be +NIL. +Returns a name string, or %NULL +if @action does not implement this interface. + + + + + + the action index corresponding to the action to be performed + + + + + + Sets a description of the specified action of the object. + + a gboolean representing if the description was successfully set; + + + + + the action index corresponding to the action to be performed + + + + the description to be assigned to this action + + + + + + Perform the specified action on the object. + + %TRUE if success, %FALSE otherwise + + + + + the action index corresponding to the action to be performed + + + + + + Returns a description of the specified action of the object. +Returns a description string, or %NULL +if @action does not implement this interface. + + + + + + the action index corresponding to the action to be performed + + + + + + Returns a keybinding associated with this action, if one exists. +The returned string is in the format "<a>;<b>;<c>" +(i.e. semicolon-delimited), where <a> is the keybinding which +activates the object if it is presently enabled onscreen, +<b> corresponds to the keybinding or sequence of keys +which invokes the action even if the relevant element is not +currently posted on screen (for instance, for a menu item it +posts the parent menus before invoking). The last token in the +above string, if non-empty, represents a keyboard shortcut which +invokes the same action without posting the component or its +enclosing menus or dialogs. +Returns a string representing the available keybindings, or %NULL +if there is no keybinding for this action. + + + + + + the action index corresponding to the action to be performed + + + + + + Returns the localized name of the specified action of the object. +Returns a name string, or %NULL +if @action does not implement this interface. + + + + + + the action index corresponding to the action to be performed + + + + + + Gets the number of accessible actions available on the object. +If there are more than one, the first one is considered the +"default" action of the object. +implement this interface. + + a the number of actions, or 0 if @action does not + + + + + Returns a non-localized string naming the specified action of the +object. This name is generally not descriptive of the end result +of the action, but instead names the 'interaction type' which the +object supports. By convention, the above strings should be used to +represent the actions which correspond to the common point-and-click +"click", "press", "release", "drag", "drop", "popup", etc. +The "popup" action should be used to pop up a context menu for the +object, if one exists. +For technical reasons, some toolkits cannot guarantee that the +reported action is actually 'bound' to a nontrivial user event; +i.e. the result of some actions via atk_action_do_action() may be +NIL. +Returns a name string, or %NULL +if @action does not implement this interface. + + + + + + the action index corresponding to the action to be performed + + + + + + Sets a description of the specified action of the object. + + a gboolean representing if the description was successfully set; + + + + + the action index corresponding to the action to be performed + + + + the description to be assigned to this action + + + + + + + + + + + + + %TRUE if success, %FALSE otherwise + + + + + + + + the action index corresponding to the action to be performed + + + + + + + + + a the number of actions, or 0 if @action does not + + + + + + + + + + + + + + + + + + + + the action index corresponding to the action to be performed + + + + + + + + + + + + + + + + the action index corresponding to the action to be performed + + + + + + + + + + + + + + + + the action index corresponding to the action to be performed + + + + + + + + + a gboolean representing if the description was successfully set; + + + + + + + + the action index corresponding to the action to be performed + + + + the description to be assigned to this action + + + + + + + + + + + + + + + + the action index corresponding to the action to be performed + + + + + + + + + + + A string name/value pair representing a text attribute. + + + + + + + + + + Add the specified handler to the set of functions to be called +when this object receives focus events (in or out). If the handler is +already added it is not added again +or zero if the handler was already added. + + a handler id which can be used in atk_component_remove_focus_handler + + + + + The #AtkFocusHandler to be attached to @component + + + + + + Checks whether the specified point is within the extent of the @component. +the extent of the @component or not + + %TRUE or %FALSE indicating whether the specified point is within + + + + + x coordinate + + + + y coordinate + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Returns the alpha value (i.e. the opacity) for this +(fully opaque). + + An alpha value from 0 to 1.0, inclusive. + + + + + Gets the rectangle which gives the extent of the @component. + + + + + + address of #gint to put x coordinate + + + + address of #gint to put y coordinate + + + + address of #gint to put width + + + + address of #gint to put height + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Gets the layer of the component. + + an #AtkLayer which is the layer of the component + + + + + Gets the zorder of the component. The value G_MININT will be returned +if the layer of the component is not ATK_LAYER_MDI or ATK_LAYER_WINDOW. +which the component is shown in relation to other components in the same +container. + + a gint which is the zorder of the component, i.e. the depth at + + + + + Gets the position of @component in the form of +a point specifying @component's top-left corner. + + + + + + address of #gint to put x coordinate position + + + + address of #gint to put y coordinate position + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Gets the size of the @component in terms of width and height. + + + + + + address of #gint to put width of @component + + + + address of #gint to put height of @component + + + + + + Grabs focus for this @component. + + %TRUE if successful, %FALSE otherwise. + + + + + Gets a reference to the accessible child, if one exists, at the +coordinate point specified by @x and @y. + + a reference to the accessible child, if one exists + + + + + x coordinate + + + + y coordinate + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Remove the handler specified by @handler_id from the list of +functions to be executed when this object receives focus events +(in or out). + + + + + + the handler id of the focus handler to be removed from @component + + + + + + Sets the extents of @component. + + %TRUE or %FALSE whether the extents were set or not + + + + + x coordinate + + + + y coordinate + + + + width to set for @component + + + + height to set for @component + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Sets the postition of @component. + + %TRUE or %FALSE whether or not the position was set or not + + + + + x coordinate + + + + y coordinate + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Set the size of the @component in terms of width and height. + + %TRUE or %FALSE whether the size was set or not + + + + + width to set for @component + + + + height to set for @component + + + + + + Add the specified handler to the set of functions to be called +when this object receives focus events (in or out). If the handler is +already added it is not added again +or zero if the handler was already added. + + a handler id which can be used in atk_component_remove_focus_handler + + + + + The #AtkFocusHandler to be attached to @component + + + + + + Checks whether the specified point is within the extent of the @component. +the extent of the @component or not + + %TRUE or %FALSE indicating whether the specified point is within + + + + + x coordinate + + + + y coordinate + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Returns the alpha value (i.e. the opacity) for this +(fully opaque). + + An alpha value from 0 to 1.0, inclusive. + + + + + Gets the rectangle which gives the extent of the @component. + + + + + + address of #gint to put x coordinate + + + + address of #gint to put y coordinate + + + + address of #gint to put width + + + + address of #gint to put height + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Gets the layer of the component. + + an #AtkLayer which is the layer of the component + + + + + Gets the zorder of the component. The value G_MININT will be returned +if the layer of the component is not ATK_LAYER_MDI or ATK_LAYER_WINDOW. +which the component is shown in relation to other components in the same +container. + + a gint which is the zorder of the component, i.e. the depth at + + + + + Gets the position of @component in the form of +a point specifying @component's top-left corner. + + + + + + address of #gint to put x coordinate position + + + + address of #gint to put y coordinate position + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Gets the size of the @component in terms of width and height. + + + + + + address of #gint to put width of @component + + + + address of #gint to put height of @component + + + + + + Grabs focus for this @component. + + %TRUE if successful, %FALSE otherwise. + + + + + Gets a reference to the accessible child, if one exists, at the +coordinate point specified by @x and @y. + + a reference to the accessible child, if one exists + + + + + x coordinate + + + + y coordinate + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Remove the handler specified by @handler_id from the list of +functions to be executed when this object receives focus events +(in or out). + + + + + + the handler id of the focus handler to be removed from @component + + + + + + Sets the extents of @component. + + %TRUE or %FALSE whether the extents were set or not + + + + + x coordinate + + + + y coordinate + + + + width to set for @component + + + + height to set for @component + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Sets the postition of @component. + + %TRUE or %FALSE whether or not the position was set or not + + + + + x coordinate + + + + y coordinate + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Set the size of the @component in terms of width and height. + + %TRUE or %FALSE whether the size was set or not + + + + + width to set for @component + + + + height to set for @component + + + + + + + + + + + + + + + + + + + + + + + a handler id which can be used in atk_component_remove_focus_handler + + + + + + + + The #AtkFocusHandler to be attached to @component + + + + + + + + + %TRUE or %FALSE indicating whether the specified point is within + + + + + + + + x coordinate + + + + y coordinate + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + + + + a reference to the accessible child, if one exists + + + + + + + + x coordinate + + + + y coordinate + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + + + + + + + + + + + address of #gint to put x coordinate + + + + address of #gint to put y coordinate + + + + address of #gint to put width + + + + address of #gint to put height + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + + + + + + + + + + + address of #gint to put x coordinate position + + + + address of #gint to put y coordinate position + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + + + + + + + + + + + address of #gint to put width of @component + + + + address of #gint to put height of @component + + + + + + + + + %TRUE if successful, %FALSE otherwise. + + + + + + + + + + + + + + + + + + + + the handler id of the focus handler to be removed from @component + + + + + + + + + %TRUE or %FALSE whether the extents were set or not + + + + + + + + x coordinate + + + + y coordinate + + + + width to set for @component + + + + height to set for @component + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + + + + %TRUE or %FALSE whether or not the position was set or not + + + + + + + + x coordinate + + + + y coordinate + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + + + + %TRUE or %FALSE whether the size was set or not + + + + + + + + width to set for @component + + + + height to set for @component + + + + + + + + + an #AtkLayer which is the layer of the component + + + + + + + + + + + + + a gint which is the zorder of the component, i.e. the depth at + + + + + + + + + + + + + + + + + + + + + + + + + + + + An alpha value from 0 to 1.0, inclusive. + + + + + + + + + + + + + + + + + Gets a %gpointer that points to an instance of the DOM. It is +up to the caller to check atk_document_get_type to determine +how to cast this pointer. + + a %gpointer that points to an instance of the DOM. + + + + + + + + + + + + + + + + + + + + + + + + + Gets a string indicating the document type. + + a string indicating the document type + + + + + + + + + + + + + + + + + + document, or NULL if a value for #attribute_name has not been specified +for this document. + + a string value associated with the named attribute for this + + + + + a character string representing the name of the attribute whose value is being queried. + + + + + + Gets an AtkAttributeSet which describes document-wide +attributes as name-value pairs. +set name-value-pair attributes associated with this document +as a whole. + + An AtkAttributeSet containing the explicitly + + + + + Gets a %gpointer that points to an instance of the DOM. It is +up to the caller to check atk_document_get_type to determine +how to cast this pointer. + + a %gpointer that points to an instance of the DOM. + + + + + Gets a string indicating the document type. + + a string indicating the document type + + + + + Gets a UTF-8 string indicating the POSIX-style LC_MESSAGES locale +of the content of this document instance. Individual +text substrings or images within this document may have +a different locale, see atk_text_get_attributes and +atk_image_get_image_locale. +locale of the document content as a whole, or NULL if +the document content does not specify a locale. + + a UTF-8 string indicating the POSIX-style LC_MESSAGES + + + + + for this document, FALSE otherwise (e.g. if the document does not +allow the attribute to be modified). + + TRUE if #value is successfully associated with #attribute_name + + + + + a character string representing the name of the attribute whose value is being set. + + + + a string value to be associated with #attribute_name. + + + + + + + + + + + + + + + + + + + + + + + + + + + + a string indicating the document type + + + + + + + + + + + + + a %gpointer that points to an instance of the DOM. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Copy text from @start_pos up to, but not including @end_pos +to the clipboard. + + + + + + start position + + + + end position + + + + + + Copy text from @start_pos up to, but not including @end_pos +to the clipboard and then delete from the widget. + + + + + + start position + + + + end position + + + + + + Delete text @start_pos up to, but not including @end_pos. + + + + + + start position + + + + end position + + + + + + Insert text at a given position. + + + + + + the text to insert + + + + the length of text to insert, in bytes + + + + The caller initializes this to the position at which to insert the text. After the call it points at the position after the newly inserted text. + + + + + + Paste text from clipboard to specified @position. + + + + + + position to paste + + + + + + + + + + + + + + + + + + + + + + Set text contents of @text. + + + + + + string to set for text contents of @text + + + + + + Copy text from @start_pos up to, but not including @end_pos +to the clipboard. + + + + + + start position + + + + end position + + + + + + Copy text from @start_pos up to, but not including @end_pos +to the clipboard and then delete from the widget. + + + + + + start position + + + + end position + + + + + + Delete text @start_pos up to, but not including @end_pos. + + + + + + start position + + + + end position + + + + + + Insert text at a given position. + + + + + + the text to insert + + + + the length of text to insert, in bytes + + + + The caller initializes this to the position at which to insert the text. After the call it points at the position after the newly inserted text. + + + + + + Paste text from clipboard to specified @position. + + + + + + position to paste + + + + + + + + + + + + + + + + + + + + + + Set text contents of @text. + + + + + + string to set for text contents of @text + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + string to set for text contents of @text + + + + + + + + + + + + + + + + the text to insert + + + + the length of text to insert, in bytes + + + + The caller initializes this to the position at which to insert the text. After the call it points at the position after the newly inserted text. + + + + + + + + + + + + + + + + start position + + + + end position + + + + + + + + + + + + + + + + start position + + + + end position + + + + + + + + + + + + + + + + start position + + + + end position + + + + + + + + + + + + + + + + position to paste + + + + + + + + + + + + + + A function which is called when an object emits a matching event, +as used in #atk_add_focus_tracker. +Currently the only events for which object-specific handlers are +supported are events of type "focus:". Most clients of ATK will prefer to +attach signal handlers for the various ATK signals instead. + + + + + + An #AtkObject instance for whom the callback will be called when the specified event (e.g. 'focus:') takes place. + + + + + + An #AtkEventListenerInit function is a special function that is +called in order to initialize the per-object event registration system +used by #AtkEventListener, if any preparation is required. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Gets the accessible object for the specified @obj. + + a #AtkObject which is the accessible object for the @obj + + + + + a #GObject + + + + + + Gets the GObject for which @obj is the accessible object. + + a #GObject which is the object for which @obj is the accessible object + + + + + + + + + + + + + + + + + + + + + + Gets the index with the hypertext document at which this link ends. + + the index with the hypertext document at which this link ends + + + + + Gets the number of anchors associated with this hyperlink. + + the number of anchors associated with this hyperlink + + + + + Returns the item associated with this hyperlinks nth anchor. +For instance, the returned #AtkObject will implement #AtkText +if @link_ is a text hyperlink, #AtkImage if @link_ is an image +hyperlink etc. +Multiple anchors are primarily used by client-side image maps. + + an #AtkObject associated with this hyperlinks i-th anchor + + + + + a (zero-index) integer specifying the desired anchor + + + + + + Gets the index with the hypertext document at which this link begins. + + the index with the hypertext document at which this link begins + + + + + Get a the URI associated with the anchor specified +by @i of @link_. +Multiple anchors are primarily used by client-side image maps. + + a string specifying the URI + + + + + a (zero-index) integer specifying the desired anchor + + + + + + + + + + + Since the document that a link is associated with may have changed +this method returns %TRUE if the link is still valid (with +respect to the document it references) and %FALSE otherwise. + + whether or not this link is still valid + + + + + + + + + + Gets the index with the hypertext document at which this link ends. + + the index with the hypertext document at which this link ends + + + + + Gets the number of anchors associated with this hyperlink. + + the number of anchors associated with this hyperlink + + + + + Returns the item associated with this hyperlinks nth anchor. +For instance, the returned #AtkObject will implement #AtkText +if @link_ is a text hyperlink, #AtkImage if @link_ is an image +hyperlink etc. +Multiple anchors are primarily used by client-side image maps. + + an #AtkObject associated with this hyperlinks i-th anchor + + + + + a (zero-index) integer specifying the desired anchor + + + + + + Gets the index with the hypertext document at which this link begins. + + the index with the hypertext document at which this link begins + + + + + Get a the URI associated with the anchor specified +by @i of @link_. +Multiple anchors are primarily used by client-side image maps. + + a string specifying the URI + + + + + a (zero-index) integer specifying the desired anchor + + + + + + Indicates whether the link currently displays some or all of its +content inline. Ordinary HTML links will usually return +%FALSE, but an inline &lt;src&gt; HTML element will return +%TRUE. + + whether or not this link displays its content inline. + + + + + Since the document that a link is associated with may have changed +this method returns %TRUE if the link is still valid (with +respect to the document it references) and %FALSE otherwise. + + whether or not this link is still valid + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + a string specifying the URI + + + + + + + + a (zero-index) integer specifying the desired anchor + + + + + + + + + an #AtkObject associated with this hyperlinks i-th anchor + + + + + + + + a (zero-index) integer specifying the desired anchor + + + + + + + + + the index with the hypertext document at which this link ends + + + + + + + + + + + + + the index with the hypertext document at which this link begins + + + + + + + + + + + + + whether or not this link is still valid + + + + + + + + + + + + + the number of anchors associated with this hyperlink + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Gets the hyperlink associated with this object. +Returns an AtkHyperlink object which points to this implementing AtkObject. + + + + + + Gets the hyperlink associated with this object. +Returns an AtkHyperlink object which points to this implementing AtkObject. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Gets the link in this hypertext document at index +index @link_index + + the link in this hypertext document at + + + + + an integer specifying the desired link + + + + + + Gets the index into the array of hyperlinks that is associated with +the character specified by @char_index. +or -1 if there is no hyperlink associated with this character. + + an index into the array of hyperlinks in @hypertext, + + + + + a character index + + + + + + Gets the number of links within this hypertext document. + + the number of links within this hypertext document + + + + + Gets the link in this hypertext document at index +index @link_index + + the link in this hypertext document at + + + + + an integer specifying the desired link + + + + + + Gets the index into the array of hyperlinks that is associated with +the character specified by @char_index. +or -1 if there is no hyperlink associated with this character. + + an index into the array of hyperlinks in @hypertext, + + + + + a character index + + + + + + Gets the number of links within this hypertext document. + + the number of links within this hypertext document + + + + + + + + + + + + + + + + + + + + + + the link in this hypertext document at + + + + + + + + an integer specifying the desired link + + + + + + + + + the number of links within this hypertext document + + + + + + + + + + + + + an index into the array of hyperlinks in @hypertext, + + + + + + + + a character index + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Get a textual description of this image. + + a string representing the image description + + + + + Since ATK 1.12 +Returns a string corresponding to the POSIX LC_MESSAGES locale used by the image description, or NULL if the image does not specify a locale. + + + + + + Gets the position of the image in the form of a point specifying the +images top-left corner. + + + + + + address of #gint to put x coordinate position; otherwise, -1 if value cannot be obtained. + + + + address of #gint to put y coordinate position; otherwise, -1 if value cannot be obtained. + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Get the width and height in pixels for the specified image. +The values of @width and @height are returned as -1 if the +values cannot be obtained (for instance, if the object is not onscreen). + + + + + + filled with the image width, or -1 if the value cannot be obtained. + + + + filled with the image height, or -1 if the value cannot be obtained. + + + + + + Sets the textual description for this image. +not be completed. + + boolean TRUE, or FALSE if operation could + + + + + a string description to set for @image + + + + + + Get a textual description of this image. + + a string representing the image description + + + + + Since ATK 1.12 +Returns a string corresponding to the POSIX LC_MESSAGES locale used by the image description, or NULL if the image does not specify a locale. + + + + + + Gets the position of the image in the form of a point specifying the +images top-left corner. + + + + + + address of #gint to put x coordinate position; otherwise, -1 if value cannot be obtained. + + + + address of #gint to put y coordinate position; otherwise, -1 if value cannot be obtained. + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + Get the width and height in pixels for the specified image. +The values of @width and @height are returned as -1 if the +values cannot be obtained (for instance, if the object is not onscreen). + + + + + + filled with the image width, or -1 if the value cannot be obtained. + + + + filled with the image height, or -1 if the value cannot be obtained. + + + + + + Sets the textual description for this image. +not be completed. + + boolean TRUE, or FALSE if operation could + + + + + a string description to set for @image + + + + + + + + + + + + + + + + + + + + address of #gint to put x coordinate position; otherwise, -1 if value cannot be obtained. + + + + address of #gint to put y coordinate position; otherwise, -1 if value cannot be obtained. + + + + specifies whether the coordinates are relative to the screen or to the components top level window + + + + + + + + + a string representing the image description + + + + + + + + + + + + + + + + + + + + filled with the image width, or -1 if the value cannot be obtained. + + + + filled with the image height, or -1 if the value cannot be obtained. + + + + + + + + + boolean TRUE, or FALSE if operation could + + + + + + + + a string description to set for @image + + + + + + + + + + + + + + + + + + + + + + + + Gets a reference to an object's #AtkObject implementation, if +the object implements #AtkObjectIface + + a reference to an object's #AtkObject implementation + + + + + + + + Encapsulates information about a key event. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + An #AtkKeySnoopFunc is a type of callback which is called whenever a key event occurs, +if registered via atk_add_key_event_listener. It allows for pre-emptive +interception of key events via the return code as described below. +discarded without being passed to the normal GUI recipient; FALSE (zero) if the +event dispatch to the client application should proceed as normal. + + TRUE (nonzero) if the event emission should be stopped and the event + + + + + an AtkKeyEventStruct containing information about the key event for which notification is being given. + + + + a block of data which will be passed to the event listener, on notification. + + + + + + + + + + + + + + + + + Obtain the singleton instance of AtkMisc for this application. + + The singleton instance of AtkMisc for this application. + + + + + Take the thread mutex for the GUI toolkit, +if one exists. +(This method is implemented by the toolkit ATK implementation layer; +for instance, for GTK+, GAIL implements this via GDK_THREADS_ENTER). + + + + + + Release the thread mutex for the GUI toolkit, +if one exists. This method, and atk_misc_threads_enter, +are needed in some situations by threaded application code which +services ATK requests, since fulfilling ATK requests often +requires calling into the GUI toolkit. If a long-running or +potentially blocking call takes place inside such a block, it should +be bracketed by atk_misc_threads_leave/atk_misc_threads_enter calls. +(This method is implemented by the toolkit ATK implementation layer; +for instance, for GTK+, GAIL implements this via GDK_THREADS_LEAVE). + + + + + + Take the thread mutex for the GUI toolkit, +if one exists. +(This method is implemented by the toolkit ATK implementation layer; +for instance, for GTK+, GAIL implements this via GDK_THREADS_ENTER). + + + + + + Release the thread mutex for the GUI toolkit, +if one exists. This method, and atk_misc_threads_enter, +are needed in some situations by threaded application code which +services ATK requests, since fulfilling ATK requests often +requires calling into the GUI toolkit. If a long-running or +potentially blocking call takes place inside such a block, it should +be bracketed by atk_misc_threads_leave/atk_misc_threads_enter calls. +(This method is implemented by the toolkit ATK implementation layer; +for instance, for GTK+, GAIL implements this via GDK_THREADS_LEAVE). + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Provides a default (non-functioning stub) #AtkObject. +Application maintainers should not use this method. + + a default (non-functioning stub) #AtkObject + + + + + a #GObject + + + + + + + + + + + + + + + + Creates an instance of an #AtkObjectFactory which generates primitive +(non-functioning) #AtkObjects. + + an instance of an #AtkObjectFactory + + + + + + + + + + + + + + + Specifies a function to be called when a property changes value. +atk_object_remove_property_change_handler() + + a #guint which is the handler id used in + + + + + + + + + + Get a list of properties applied to this object as a whole, as an #AtkAttributeSet consisting of +name-value pairs. As such these attributes may be considered weakly-typed properties or annotations, +as distinct from strongly-typed object data available via other get/set methods. +Not all objects have explicit "name-value pair" #AtkAttributeSet properties. +the object, or an empty set if the object has no name-value pair attributes assigned to it. + + an #AtkAttributeSet consisting of all explicit properties/annotations applied to + + + + + Gets the accessible description of the accessible. +of the accessible. + + a character string representing the accessible description + + + + + Gets the 0-based index of this accessible in its parent; returns -1 if the +accessible does not have an accessible parent. + + an integer which is the index of the accessible in its parent + + + + + + + + + + + + + + + + + + + + Gets the accessible name of the accessible. + + a character string representing the accessible name of the object. + + + + + Gets the accessible parent of the accessible. + + a #AtkObject representing the accessible parent of the accessible + + + + + Gets the role of the accessible. + + an #AtkRole which is the role of the accessible + + + + + This function is called when implementing subclasses of #AtkObject. +It does initialization required for the new object. It is intended +that this function should called only in the ..._new() functions used +to create an instance of a subclass of #AtkObject + + + + + + a #gpointer which identifies the object for which the AtkObject was created. + + + + + + + + + + + + + + + + Gets the #AtkRelationSet associated with the object. + + an #AtkRelationSet representing the relation set of the object. + + + + + Gets a reference to the state set of the accessible; the caller must +unreference it when it is no longer needed. +set of the accessible + + a reference to an #AtkStateSet which is the state + + + + + Removes a property change handler. + + + + + + + + + + + Sets the accessible description of the accessible. + + + + + + + + + + + Sets the accessible name of the accessible. + + + + + + a character string to be set as the accessible name + + + + + + Sets the accessible parent of the accessible. + + + + + + + + + + + Sets the role of the accessible. + + + + + + + + + + + Adds a relationship of the specified type with the specified target. +Returns TRUE if the relationship is added. + + + + + + The #AtkRelationType of the relation + + + + The #AtkObject which is to be the target of the relation. + + + + + + Specifies a function to be called when a property changes value. +atk_object_remove_property_change_handler() + + a #guint which is the handler id used in + + + + + + + + + + Get a list of properties applied to this object as a whole, as an #AtkAttributeSet consisting of +name-value pairs. As such these attributes may be considered weakly-typed properties or annotations, +as distinct from strongly-typed object data available via other get/set methods. +Not all objects have explicit "name-value pair" #AtkAttributeSet properties. +the object, or an empty set if the object has no name-value pair attributes assigned to it. + + an #AtkAttributeSet consisting of all explicit properties/annotations applied to + + + + + Gets the accessible description of the accessible. +of the accessible. + + a character string representing the accessible description + + + + + Gets the 0-based index of this accessible in its parent; returns -1 if the +accessible does not have an accessible parent. + + an integer which is the index of the accessible in its parent + + + + + Gets the number of accessible children of the accessible. +of the accessible. + + an integer representing the number of accessible children + + + + + Gets the accessible name of the accessible. + + a character string representing the accessible name of the object. + + + + + Gets the accessible parent of the accessible. + + a #AtkObject representing the accessible parent of the accessible + + + + + Gets the role of the accessible. + + an #AtkRole which is the role of the accessible + + + + + This function is called when implementing subclasses of #AtkObject. +It does initialization required for the new object. It is intended +that this function should called only in the ..._new() functions used +to create an instance of a subclass of #AtkObject + + + + + + a #gpointer which identifies the object for which the AtkObject was created. + + + + + + Emits a state-change signal for the specified state. + + + + + + an #AtkState whose state is changed + + + + + + + + + Gets a reference to the specified accessible child of the object. +The accessible children are 0-based so the first accessible child is +at index 0, the second at index 1 and so on. +of the accessible. + + an #AtkObject representing the specified accessible child + + + + + a gint representing the position of the child, starting from 0 + + + + + + Gets the #AtkRelationSet associated with the object. + + an #AtkRelationSet representing the relation set of the object. + + + + + Gets a reference to the state set of the accessible; the caller must +unreference it when it is no longer needed. +set of the accessible + + a reference to an #AtkStateSet which is the state + + + + + Removes a property change handler. + + + + + + + + + + + Removes a relationship of the specified type with the specified target. +Returns TRUE if the relationship is removed. + + + + + + The #AtkRelationType of the relation + + + + The #AtkObject which is the target of the relation to be removed. + + + + + + Sets the accessible description of the accessible. + + + + + + + + + + + Sets the accessible name of the accessible. + + + + + + a character string to be set as the accessible name + + + + + + Sets the accessible parent of the accessible. + + + + + + + + + + + Sets the role of the accessible. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + a character string representing the accessible name of the object. + + + + + + + + + + + + + a character string representing the accessible description + + + + + + + + + + + + + a #AtkObject representing the accessible parent of the accessible + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + an integer which is the index of the accessible in its parent + + + + + + + + + + + + + an #AtkRelationSet representing the relation set of the object. + + + + + + + + + + + + + an #AtkRole which is the role of the accessible + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + a reference to an #AtkStateSet which is the state + + + + + + + + + + + + + + + + + + + + a character string to be set as the accessible name + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + a #guint which is the handler id used in + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + a #gpointer which identifies the object for which the AtkObject was created. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + an #AtkAttributeSet consisting of all explicit properties/annotations applied to + + + + + + + + + + + + + + + + + + + Inform @factory that it is no longer being used to create +accessibles. When called, @factory may need to inform +#AtkObjects which it has created that they need to be re-instantiated. +in object registries. + + + + + + Provides an #AtkObject that implements an accessibility interface +on behalf of @obj +on behalf of @obj + + an #AtkObject that implements an accessibility interface + + + + + a #GObject + + + + + + Gets the GType of the accessible which is created by the factory. +The value G_TYPE_INVALID is returned if no type if found. + + the type of the accessible which is created by the @factory. + + + + + Inform @factory that it is no longer being used to create +accessibles. When called, @factory may need to inform +#AtkObjects which it has created that they need to be re-instantiated. +in object registries. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Gets an #AtkObjectFactory appropriate for creating #AtkObjects +appropriate for @type. +appropriate for @type. + + an #AtkObjectFactory appropriate for creating #AtkObjects + + + + + a #GType with which to look up the associated #AtkObjectFactory + + + + + + Provides a #GType indicating the #AtkObjectFactory subclass +associated with @type. + + a #GType associated with type @type + + + + + a #GType with which to look up the associated #AtkObjectFactory subclass + + + + + + Associate an #AtkObjectFactory subclass with a #GType. Note: +The associated @factory_type will thereafter be responsible for +the creation of new #AtkObject implementations for instances +appropriate for @type. + + + + + + an #AtkObject type + + + + an #AtkObjectFactory type to associate with @type. Must implement AtkObject appropriate for @type. + + + + + + + + Create a new relation for the specified key and the specified list +of targets. See also atk_object_add_relationship(). + + a pointer to a new #AtkRelation + + + + + an array of pointers to #AtkObjects + + + + number of #AtkObjects pointed to by @targets + + + + an #AtkRelationType with which to create the new #AtkRelation + + + + + + Adds the specified AtkObject to the target for the relation, if it is +not already present. See also atk_object_add_relationship(). + + + + + + an #AtkObject + + + + + + Gets the type of @relation + + the type of @relation + + + + + Gets the target list of @relation + + the target list of @relation + + + + + + + Remove the specified AtkObject from the target for the relation. +Returns TRUE if the removal is successful. + + + + + + an #AtkObject + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Creates a new empty relation set. + + a new #AtkRelationSet + + + + + Add a new relation to the current relation set if it is not already +present. +This function ref's the AtkRelation so the caller of this function +should unref it to ensure that it will be destroyed when the AtkRelationSet +is destroyed. + + + + + + an #AtkRelation + + + + + + Add a new relation of the specified type with the specified target to +the current relation set if the relation set does not contain a relation +of that type. If it is does contain a relation of that typea the target +is added to the relation. + + + + + + an #AtkRelationType + + + + an #AtkObject + + + + + + Determines whether the relation set contains a relation that matches the +specified type. +in @set, %FALSE otherwise + + %TRUE if @relationship is the relationship type of a relation + + + + + an #AtkRelationType + + + + + + Determines the number of relations in a relation set. + + an integer representing the number of relations in the set. + + + + + + + + + + + + + + + Finds a relation that matches the specified type. + + an #AtkRelation, which is a relation matching the specified type. + + + + + an #AtkRelationType + + + + + + Removes a relation from the relation set. +This function unref's the #AtkRelation so it will be deleted unless there +is another reference to it. + + + + + + an #AtkRelation + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Adds the specified accessible child of the object to the +object's selection. + + TRUE if success, FALSE otherwise. + + + + + a #gint specifying the child index. + + + + + + Clears the selection in the object so that no children in the object +are selected. + + TRUE if success, FALSE otherwise. + + + + + Gets the number of accessible children currently selected. +indication of whether AtkSelectionIface is implemented, they should +use type checking/interface checking macros or the +atk_get_accessible_value() convenience method. +if @selection does not implement this interface. + + a gint representing the number of items selected, or 0 + + + + + Determines if the current child of this object is selected +indication of whether AtkSelectionIface is implemented, they should +use type checking/interface checking macros or the +atk_get_accessible_value() convenience method. +if @selection does not implement this interface. + + a gboolean representing the specified child is selected, or 0 + + + + + a #gint specifying the child index. + + + + + + Gets a reference to the accessible object representing the specified +selected child of the object. +indication of whether AtkSelectionIface is implemented, they should +use type checking/interface checking macros or the +atk_get_accessible_value() convenience method. +if @selection does not implement this interface. + + an #AtkObject representing the selected accessible , or %NULL + + + + + a #gint specifying the index in the selection set. (e.g. the ith selection as opposed to the ith child). + + + + + + Removes the specified child of the object from the object's selection. + + TRUE if success, FALSE otherwise. + + + + + a #gint specifying the index in the selection set. (e.g. the ith selection as opposed to the ith child). + + + + + + Causes every child of the object to be selected if the object +supports multiple selections. + + TRUE if success, FALSE otherwise. + + + + + Adds the specified accessible child of the object to the +object's selection. + + TRUE if success, FALSE otherwise. + + + + + a #gint specifying the child index. + + + + + + Clears the selection in the object so that no children in the object +are selected. + + TRUE if success, FALSE otherwise. + + + + + Gets the number of accessible children currently selected. +indication of whether AtkSelectionIface is implemented, they should +use type checking/interface checking macros or the +atk_get_accessible_value() convenience method. +if @selection does not implement this interface. + + a gint representing the number of items selected, or 0 + + + + + Determines if the current child of this object is selected +indication of whether AtkSelectionIface is implemented, they should +use type checking/interface checking macros or the +atk_get_accessible_value() convenience method. +if @selection does not implement this interface. + + a gboolean representing the specified child is selected, or 0 + + + + + a #gint specifying the child index. + + + + + + Gets a reference to the accessible object representing the specified +selected child of the object. +indication of whether AtkSelectionIface is implemented, they should +use type checking/interface checking macros or the +atk_get_accessible_value() convenience method. +if @selection does not implement this interface. + + an #AtkObject representing the selected accessible , or %NULL + + + + + a #gint specifying the index in the selection set. (e.g. the ith selection as opposed to the ith child). + + + + + + Removes the specified child of the object from the object's selection. + + TRUE if success, FALSE otherwise. + + + + + a #gint specifying the index in the selection set. (e.g. the ith selection as opposed to the ith child). + + + + + + Causes every child of the object to be selected if the object +supports multiple selections. + + TRUE if success, FALSE otherwise. + + + + + + + + + + + + + + + + + TRUE if success, FALSE otherwise. + + + + + + + + a #gint specifying the child index. + + + + + + + + + TRUE if success, FALSE otherwise. + + + + + + + + + + + + + an #AtkObject representing the selected accessible , or %NULL + + + + + + + + a #gint specifying the index in the selection set. (e.g. the ith selection as opposed to the ith child). + + + + + + + + + a gint representing the number of items selected, or 0 + + + + + + + + + + + + + a gboolean representing the specified child is selected, or 0 + + + + + + + + a #gint specifying the child index. + + + + + + + + + TRUE if success, FALSE otherwise. + + + + + + + + a #gint specifying the index in the selection set. (e.g. the ith selection as opposed to the ith child). + + + + + + + + + TRUE if success, FALSE otherwise. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Embeds the children of an #AtkPlug as the children of the #AtkSocket. The +plug may be in the same process or in a different process. + + + + + + the ID of an #AtkPlug + + + + + + Embeds the children of an #AtkPlug as the children of the #AtkSocket. The +plug may be in the same process or in a different process. + + + + + + the ID of an #AtkPlug + + + + + + Determines whether or not the socket has an embedded plug. + + TRUE if a plug is embedded in the socket + + + + + + + + + + + + + + + + + + + + + + + + + the ID of an #AtkPlug + + + + + + + + + Creates a new empty state set. + + a new #AtkStateSet + + + + + Add a new state for the specified type to the current state set if +it is not already present. + + %TRUE if the state for @type is not already in @set. + + + + + an #AtkStateType + + + + + + Add the states for the specified types to the current state set. + + + + + + an array of #AtkStateType + + + + The number of elements in the array + + + + + + Constructs the intersection of the two sets, returning %NULL if the +intersection is empty. + + a new #AtkStateSet which is the intersection of the two sets. + + + + + another #AtkStateSet + + + + + + Removes all states from the state set. + + + + + + Checks whether the state for the specified type is in the specified set. + + %TRUE if @type is the state type is in @set. + + + + + an #AtkStateType + + + + + + Checks whether the states for all the specified types are in the +specified set. + + %TRUE if all the states for @type are in @set. + + + + + an array of #AtkStateType + + + + The number of elements in the array + + + + + + Checks whether the state set is empty, i.e. has no states set. + + %TRUE if @set has no states set, otherwise %FALSE + + + + + Constructs the union of the two sets. +returning %NULL is empty. + + a new #AtkStateSet which is the union of the two sets, + + + + + another #AtkStateSet + + + + + + Removes the state for the specified type from the state set. + + %TRUE if @type was the state type is in @set. + + + + + an #AtkType + + + + + + Constructs the exclusive-or of the two sets, returning %NULL is empty. +The set returned by this operation contains the states in exactly +one of the two sets. +in exactly one of the two sets. + + a new #AtkStateSet which contains the states which are + + + + + another #AtkStateSet + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Gets the character string of the specified mime type. The first mime +type is at position 0, the second at position 1, and so on. +should not free the character string. + + + + + + a gint representing the position of the mime type starting from 0 + + + + + + Gets the number of mime types supported by this object. + + a gint which is the number of mime types supported by the object. + + + + + Gets the content in the specified mime type. +type. + + A #GIOChannel which contains the content in the specified mime + + + + + a gchar* representing the mime type + + + + + + Get a string representing a URI in IETF standard format +(see http://www.ietf.org/rfc/rfc2396.txt) from which the object's content +may be streamed in the specified mime-type, if one is available. +If mime_type is NULL, the URI for the default (and possibly only) mime-type is +returned. +Note that it is possible for get_uri to return NULL but for +get_stream to work nonetheless, since not all GIOChannels connect to URIs. +can be constructed. + + Returns a string representing a URI, or NULL if no corresponding URI + + + + + a gchar* representing the mime type, or NULL to request a URI for the default mime type. + + + + + + Gets the character string of the specified mime type. The first mime +type is at position 0, the second at position 1, and so on. +should not free the character string. + + + + + + a gint representing the position of the mime type starting from 0 + + + + + + Gets the number of mime types supported by this object. + + a gint which is the number of mime types supported by the object. + + + + + Gets the content in the specified mime type. +type. + + A #GIOChannel which contains the content in the specified mime + + + + + a gchar* representing the mime type + + + + + + Get a string representing a URI in IETF standard format +(see http://www.ietf.org/rfc/rfc2396.txt) from which the object's content +may be streamed in the specified mime-type, if one is available. +If mime_type is NULL, the URI for the default (and possibly only) mime-type is +returned. +Note that it is possible for get_uri to return NULL but for +get_stream to work nonetheless, since not all GIOChannels connect to URIs. +can be constructed. + + Returns a string representing a URI, or NULL if no corresponding URI + + + + + a gchar* representing the mime type, or NULL to request a URI for the default mime type. + + + + + + + + + + + + + a gint which is the number of mime types supported by the object. + + + + + + + + + + + + + + + + + + + + a gint representing the position of the mime type starting from 0 + + + + + + + + + A #GIOChannel which contains the content in the specified mime + + + + + + + + a gchar* representing the mime type + + + + + + + + + Returns a string representing a URI, or NULL if no corresponding URI + + + + + + + + a gchar* representing the mime type, or NULL to request a URI for the default mime type. + + + + + + + + + + + + + + + + + + Adds the specified @column to the selection. +the selection, or 0 if value does not implement this interface. + + a gboolean representing if the column was successfully added to + + + + + a #gint representing a column in @table + + + + + + Adds the specified @row to the selection. +or 0 if value does not implement this interface. + + a gboolean representing if row was successfully added to selection, + + + + + a #gint representing a row in @table + + + + + + Gets the caption for the @table. +if value does not implement this interface. + + a AtkObject* representing the table caption, or %NULL + + + + + Gets a #gint representing the column at the specified @index_. +or -1 if the table does not implement this interface + + a gint representing the column at the specified index, + + + + + a #gint representing an index in @table + + + + + + Gets the description text of the specified @column in the table +if value does not implement this interface. + + a gchar* representing the column description, or %NULL + + + + + a #gint representing a column in @table + + + + + + Gets the number of columns occupied by the accessible object +at the specified @row and @column in the @table. +if value does not implement this interface. + + a gint representing the column extent at specified position, or 0 + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Gets the column header of a specified column in an accessible table. +%NULL if value does not implement this interface. + + a AtkObject* representing the specified column header, or + + + + + a #gint representing a column in the table + + + + + + Gets a #gint representing the index at the specified @row and @column. +The value -1 is returned if the object at row,column is not a child +of table or table does not implement this interface. + + a #gint representing the index at specified position. + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Gets the number of columns in the table. +if value does not implement this interface. + + a gint representing the number of columns, or 0 + + + + + Gets the number of rows in the table. +if value does not implement this interface. + + a gint representing the number of rows, or 0 + + + + + Gets a #gint representing the row at the specified @index_. +or -1 if the table does not implement this interface + + a gint representing the row at the specified index, + + + + + a #gint representing an index in @table + + + + + + Gets the description text of the specified row in the table +if value does not implement this interface. + + a gchar* representing the row description, or %NULL + + + + + a #gint representing a row in @table + + + + + + Gets the number of rows occupied by the accessible object +at a specified @row and @column in the @table. +if value does not implement this interface. + + a gint representing the row extent at specified position, or 0 + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Gets the row header of a specified row in an accessible table. +%NULL if value does not implement this interface. + + a AtkObject* representing the specified row header, or + + + + + a #gint representing a row in the table + + + + + + Gets the selected columns of the table by initializing **selected with +the selected column numbers. This array should be freed by the caller. +or %0 if value does not implement this interface. + + a gint representing the number of selected columns, + + + + + a #gint** that is to contain the selected columns numbers + + + + + + Gets the selected rows of the table by initializing **selected with +the selected row numbers. This array should be freed by the caller. +or zero if value does not implement this interface. + + a gint representing the number of selected rows, + + + + + a #gint** that is to contain the selected row numbers + + + + + + Gets the summary description of the table. +or zero if value does not implement this interface. + + a AtkObject* representing a summary description of the table, + + + + + Gets a boolean value indicating whether the specified @column +is selected +if value does not implement this interface. + + a gboolean representing if the column is selected, or 0 + + + + + a #gint representing a column in @table + + + + + + Gets a boolean value indicating whether the specified @row +is selected +if value does not implement this interface. + + a gboolean representing if the row is selected, or 0 + + + + + a #gint representing a row in @table + + + + + + Gets a boolean value indicating whether the accessible object +at the specified @row and @column is selected +if value does not implement this interface. + + a gboolean representing if the cell is selected, or 0 + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Get a reference to the table cell at @row, @column. + + a AtkObject* representing the referred to accessible + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Adds the specified @column to the selection. +the selection, or 0 if value does not implement this interface. + + a gboolean representing if the column was successfully removed from + + + + + a #gint representing a column in @table + + + + + + Removes the specified @row from the selection. +the selection, or 0 if value does not implement this interface. + + a gboolean representing if the row was successfully removed from + + + + + a #gint representing a row in @table + + + + + + Sets the caption for the table. + + + + + + a #AtkObject representing the caption to set for @table + + + + + + Sets the description text for the specified @column of the @table. + + + + + + a #gint representing a column in @table + + + + a #gchar representing the description text to set for the specified @column of the @table + + + + + + Sets the specified column header to @header. + + + + + + a #gint representing a column in @table + + + + an #AtkTable + + + + + + Sets the description text for the specified @row of @table. + + + + + + a #gint representing a row in @table + + + + a #gchar representing the description text to set for the specified @row of @table + + + + + + Sets the specified row header to @header. + + + + + + a #gint representing a row in @table + + + + an #AtkTable + + + + + + Sets the summary description of the table. + + + + + + an #AtkObject representing the summary description to set for @table + + + + + + Adds the specified @column to the selection. +the selection, or 0 if value does not implement this interface. + + a gboolean representing if the column was successfully added to + + + + + a #gint representing a column in @table + + + + + + Adds the specified @row to the selection. +or 0 if value does not implement this interface. + + a gboolean representing if row was successfully added to selection, + + + + + a #gint representing a row in @table + + + + + + Gets the caption for the @table. +if value does not implement this interface. + + a AtkObject* representing the table caption, or %NULL + + + + + Gets a #gint representing the column at the specified @index_. +or -1 if the table does not implement this interface + + a gint representing the column at the specified index, + + + + + a #gint representing an index in @table + + + + + + Gets the description text of the specified @column in the table +if value does not implement this interface. + + a gchar* representing the column description, or %NULL + + + + + a #gint representing a column in @table + + + + + + Gets the number of columns occupied by the accessible object +at the specified @row and @column in the @table. +if value does not implement this interface. + + a gint representing the column extent at specified position, or 0 + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Gets the column header of a specified column in an accessible table. +%NULL if value does not implement this interface. + + a AtkObject* representing the specified column header, or + + + + + a #gint representing a column in the table + + + + + + Gets a #gint representing the index at the specified @row and @column. +The value -1 is returned if the object at row,column is not a child +of table or table does not implement this interface. + + a #gint representing the index at specified position. + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Gets the number of columns in the table. +if value does not implement this interface. + + a gint representing the number of columns, or 0 + + + + + Gets the number of rows in the table. +if value does not implement this interface. + + a gint representing the number of rows, or 0 + + + + + Gets a #gint representing the row at the specified @index_. +or -1 if the table does not implement this interface + + a gint representing the row at the specified index, + + + + + a #gint representing an index in @table + + + + + + Gets the description text of the specified row in the table +if value does not implement this interface. + + a gchar* representing the row description, or %NULL + + + + + a #gint representing a row in @table + + + + + + Gets the number of rows occupied by the accessible object +at a specified @row and @column in the @table. +if value does not implement this interface. + + a gint representing the row extent at specified position, or 0 + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Gets the row header of a specified row in an accessible table. +%NULL if value does not implement this interface. + + a AtkObject* representing the specified row header, or + + + + + a #gint representing a row in the table + + + + + + Gets the selected columns of the table by initializing **selected with +the selected column numbers. This array should be freed by the caller. +or %0 if value does not implement this interface. + + a gint representing the number of selected columns, + + + + + a #gint** that is to contain the selected columns numbers + + + + + + Gets the selected rows of the table by initializing **selected with +the selected row numbers. This array should be freed by the caller. +or zero if value does not implement this interface. + + a gint representing the number of selected rows, + + + + + a #gint** that is to contain the selected row numbers + + + + + + Gets the summary description of the table. +or zero if value does not implement this interface. + + a AtkObject* representing a summary description of the table, + + + + + Gets a boolean value indicating whether the specified @column +is selected +if value does not implement this interface. + + a gboolean representing if the column is selected, or 0 + + + + + a #gint representing a column in @table + + + + + + Gets a boolean value indicating whether the specified @row +is selected +if value does not implement this interface. + + a gboolean representing if the row is selected, or 0 + + + + + a #gint representing a row in @table + + + + + + Gets a boolean value indicating whether the accessible object +at the specified @row and @column is selected +if value does not implement this interface. + + a gboolean representing if the cell is selected, or 0 + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Get a reference to the table cell at @row, @column. + + a AtkObject* representing the referred to accessible + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + Adds the specified @column to the selection. +the selection, or 0 if value does not implement this interface. + + a gboolean representing if the column was successfully removed from + + + + + a #gint representing a column in @table + + + + + + Removes the specified @row from the selection. +the selection, or 0 if value does not implement this interface. + + a gboolean representing if the row was successfully removed from + + + + + a #gint representing a row in @table + + + + + + Sets the caption for the table. + + + + + + a #AtkObject representing the caption to set for @table + + + + + + Sets the description text for the specified @column of the @table. + + + + + + a #gint representing a column in @table + + + + a #gchar representing the description text to set for the specified @column of the @table + + + + + + Sets the specified column header to @header. + + + + + + a #gint representing a column in @table + + + + an #AtkTable + + + + + + Sets the description text for the specified @row of @table. + + + + + + a #gint representing a row in @table + + + + a #gchar representing the description text to set for the specified @row of @table + + + + + + Sets the specified row header to @header. + + + + + + a #gint representing a row in @table + + + + an #AtkTable + + + + + + Sets the summary description of the table. + + + + + + an #AtkObject representing the summary description to set for @table + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + a AtkObject* representing the referred to accessible + + + + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + + + + a #gint representing the index at specified position. + + + + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + + + + a gint representing the column at the specified index, + + + + + + + + a #gint representing an index in @table + + + + + + + + + a gint representing the row at the specified index, + + + + + + + + a #gint representing an index in @table + + + + + + + + + a gint representing the number of columns, or 0 + + + + + + + + + + + + + a gint representing the number of rows, or 0 + + + + + + + + + + + + + a gint representing the column extent at specified position, or 0 + + + + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + + + + a gint representing the row extent at specified position, or 0 + + + + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + + + + a AtkObject* representing the table caption, or %NULL + + + + + + + + + + + + + a gchar* representing the column description, or %NULL + + + + + + + + a #gint representing a column in @table + + + + + + + + + a AtkObject* representing the specified column header, or + + + + + + + + a #gint representing a column in the table + + + + + + + + + a gchar* representing the row description, or %NULL + + + + + + + + a #gint representing a row in @table + + + + + + + + + a AtkObject* representing the specified row header, or + + + + + + + + a #gint representing a row in the table + + + + + + + + + a AtkObject* representing a summary description of the table, + + + + + + + + + + + + + + + + + + + + a #AtkObject representing the caption to set for @table + + + + + + + + + + + + + + + + a #gint representing a column in @table + + + + a #gchar representing the description text to set for the specified @column of the @table + + + + + + + + + + + + + + + + a #gint representing a column in @table + + + + an #AtkTable + + + + + + + + + + + + + + + + a #gint representing a row in @table + + + + a #gchar representing the description text to set for the specified @row of @table + + + + + + + + + + + + + + + + a #gint representing a row in @table + + + + an #AtkTable + + + + + + + + + + + + + + + + an #AtkObject representing the summary description to set for @table + + + + + + + + + a gint representing the number of selected columns, + + + + + + + + a #gint** that is to contain the selected columns numbers + + + + + + + + + a gint representing the number of selected rows, + + + + + + + + a #gint** that is to contain the selected row numbers + + + + + + + + + a gboolean representing if the column is selected, or 0 + + + + + + + + a #gint representing a column in @table + + + + + + + + + a gboolean representing if the row is selected, or 0 + + + + + + + + a #gint representing a row in @table + + + + + + + + + a gboolean representing if the cell is selected, or 0 + + + + + + + + a #gint representing a row in @table + + + + a #gint representing a column in @table + + + + + + + + + a gboolean representing if row was successfully added to selection, + + + + + + + + a #gint representing a row in @table + + + + + + + + + a gboolean representing if the row was successfully removed from + + + + + + + + a #gint representing a row in @table + + + + + + + + + a gboolean representing if the column was successfully added to + + + + + + + + a #gint representing a column in @table + + + + + + + + + a gboolean representing if the column was successfully removed from + + + + + + + + a #gint representing a column in @table + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Adds a selection bounded by the specified offsets. + + %TRUE if success, %FALSE otherwise + + + + + the start position of the selected region + + + + the offset of the first character after the selected region. + + + + + + Get the ranges of text in the specified bounding box. +by this function will be NULL. + + Array of AtkTextRange. The last element of the array returned + + + + + An AtkTextRectagle giving the dimensions of the bounding box. + + + + Specify whether coordinates are relative to the screen or widget window. + + + + Specify the horizontal clip type. + + + + Specify the vertical clip type. + + + + + + Gets the offset position of the caret (cursor). + + the offset position of the caret (cursor). + + + + + Gets the specified text. + + the character at @offset. + + + + + position + + + + + + Gets the character count. + + the number of characters. + + + + + Get the bounding box containing the glyph representing the character at +a particular text offset. + + + + + + The offset of the text character for which bounding information is required. + + + + Pointer for the x cordinate of the bounding box + + + + Pointer for the y cordinate of the bounding box + + + + Pointer for the width of the bounding box + + + + Pointer for the height of the bounding box + + + + specify whether coordinates are relative to the screen or widget window + + + + + + + + + + + Gets the number of selected regions. +occurred. + + The number of selected regions, or -1 if a failure + + + + + Gets the offset of the character located at coordinates @x and @y. @x and @y +are interpreted as being relative to the screen or this widget's window +depending on @coords. +the specified @x and @y coordinates. + + the offset to the character which is located at + + + + + screen x-position of character + + + + screen y-position of character + + + + specify whether coordinates are relative to the screen or widget window + + + + + + Get the bounding box for text within the specified range. + + + + + + The offset of the first text character for which boundary information is required. + + + + The offset of the text character after the last character for which boundary information is required. + + + + Specify whether coordinates are relative to the screen or widget window. + + + + A pointer to a AtkTextRectangle which is filled in by this function. + + + + + + + + + + + + + + + + + + + + + + Gets the text from the specified selection. + + the selected text. + + + + + The selection number. The selected regions are assigned numbers that correspond to how far the region is from the start of the text. The selected region closest to the beginning of the text region is assigned the number 0, etc. Note that adding, moving or deleting a selected region can change the numbering. + + + + passes back the start position of the selected region + + + + passes back the end position of (e.g. offset immediately past) the selected region + + + + + + Gets the specified text. + + the text from @start_offset up to, but not including @end_offset. + + + + + start position + + + + end position + + + + + + Gets the specified text. +If the boundary_type if ATK_TEXT_BOUNDARY_CHAR the character after the +offset is returned. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_START the returned string +is from the word start after the offset to the next word start. +The returned string will contain the word after the offset if the offset +is inside a word or if the offset is not inside a word. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_END the returned string +is from the word end at or after the offset to the next work end. +The returned string will contain the word after the offset if the offset +is inside a word and will contain the word after the word after the offset +if the offset is not inside a word. +If the boundary type is ATK_TEXT_BOUNDARY_SENTENCE_START the returned +string is from the sentence start after the offset to the next sentence +start. +The returned string will contain the sentence after the offset if the offset +is inside a sentence or if the offset is not inside a sentence. +If the boundary_type is ATK_TEXT_BOUNDARY_SENTENCE_END the returned string +is from the sentence end at or after the offset to the next sentence end. +The returned string will contain the sentence after the offset if the offset +is inside a sentence and will contain the sentence after the sentence +after the offset if the offset is not inside a sentence. +If the boundary type is ATK_TEXT_BOUNDARY_LINE_START the returned +string is from the line start after the offset to the next line start. +If the boundary_type is ATK_TEXT_BOUNDARY_LINE_END the returned string +is from the line end at or after the offset to the next line start. + + the text after @offset bounded by the specified @boundary_type. + + + + + position + + + + An #AtkTextBoundary + + + + the start offset of the returned string + + + + the offset of the first character after the returned substring + + + + + + Gets the specified text. +If the boundary_type if ATK_TEXT_BOUNDARY_CHAR the character at the +offset is returned. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_START the returned string +is from the word start at or before the offset to the word start after +the offset. +The returned string will contain the word at the offset if the offset +is inside a word and will contain the word before the offset if the +offset is not inside a word. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_END the returned string +is from the word end before the offset to the word end at or after the +offset. +The returned string will contain the word at the offset if the offset +is inside a word and will contain the word after to the offset if the +offset is not inside a word. +If the boundary type is ATK_TEXT_BOUNDARY_SENTENCE_START the returned +string is from the sentence start at or before the offset to the sentence +start after the offset. +The returned string will contain the sentence at the offset if the offset +is inside a sentence and will contain the sentence before the offset +if the offset is not inside a sentence. +If the boundary_type is ATK_TEXT_BOUNDARY_SENTENCE_END the returned string +is from the sentence end before the offset to the sentence end at or +after the offset. +The returned string will contain the sentence at the offset if the offset +is inside a sentence and will contain the sentence after the offset +if the offset is not inside a sentence. +If the boundary type is ATK_TEXT_BOUNDARY_LINE_START the returned +string is from the line start at or before the offset to the line +start after the offset. +If the boundary_type is ATK_TEXT_BOUNDARY_LINE_END the returned string +is from the line end before the offset to the line end at or after +the offset. + + the text at @offset bounded by the specified @boundary_type. + + + + + position + + + + An #AtkTextBoundary + + + + the start offset of the returned string + + + + the offset of the first character after the returned substring + + + + + + Gets the specified text. +If the boundary_type if ATK_TEXT_BOUNDARY_CHAR the character before the +offset is returned. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_START the returned string +is from the word start before the word start before the offset to +the word start before the offset. +The returned string will contain the word before the offset if the offset +is inside a word and will contain the word before the word before the +offset if the offset is not inside a word. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_END the returned string +is from the word end before the word end at or before the offset to the +word end at or before the offset. +The returned string will contain the word before the offset if the offset +is inside a word or if the offset is not inside a word. +If the boundary type is ATK_TEXT_BOUNDARY_SENTENCE_START the returned +string is from the sentence start before the sentence start before +the offset to the sentence start before the offset. +The returned string will contain the sentence before the offset if the +offset is inside a sentence and will contain the sentence before the +sentence before the offset if the offset is not inside a sentence. +If the boundary_type is ATK_TEXT_BOUNDARY_SENTENCE_END the returned string +is from the sentence end before the sentence end at or before the offset to +the sentence end at or before the offset. +The returned string will contain the sentence before the offset if the +offset is inside a sentence or if the offset is not inside a sentence. +If the boundary type is ATK_TEXT_BOUNDARY_LINE_START the returned +string is from the line start before the line start ar or before the offset +to the line start ar or before the offset. +If the boundary_type is ATK_TEXT_BOUNDARY_LINE_END the returned string +is from the line end before the line end before the offset to the +line end before the offset. + + the text before @offset bounded by the specified @boundary_type. + + + + + position + + + + An #AtkTextBoundary + + + + the start offset of the returned string + + + + the offset of the first character after the returned substring + + + + + + Removes the specified selection. + + %TRUE if success, %FALSE otherwise + + + + + The selection number. The selected regions are assigned numbers that correspond to how far the region is from the start of the text. The selected region closest to the beginning of the text region is assigned the number 0, etc. Note that adding, moving or deleting a selected region can change the numbering. + + + + + + Sets the caret (cursor) position to the specified @offset. + + %TRUE if success, %FALSE otherwise. + + + + + position + + + + + + Changes the start and end offset of the specified selection. + + %TRUE if success, %FALSE otherwise + + + + + The selection number. The selected regions are assigned numbers that correspond to how far the region is from the start of the text. The selected region closest to the beginning of the text region is assigned the number 0, etc. Note that adding, moving or deleting a selected region can change the numbering. + + + + the new start position of the selection + + + + the new end position of (e.g. offset immediately past) the selection + + + + + + Adds a selection bounded by the specified offsets. + + %TRUE if success, %FALSE otherwise + + + + + the start position of the selected region + + + + the offset of the first character after the selected region. + + + + + + Get the ranges of text in the specified bounding box. +by this function will be NULL. + + Array of AtkTextRange. The last element of the array returned + + + + + An AtkTextRectagle giving the dimensions of the bounding box. + + + + Specify whether coordinates are relative to the screen or widget window. + + + + Specify the horizontal clip type. + + + + Specify the vertical clip type. + + + + + + Gets the offset position of the caret (cursor). + + the offset position of the caret (cursor). + + + + + Gets the specified text. + + the character at @offset. + + + + + position + + + + + + Gets the character count. + + the number of characters. + + + + + Get the bounding box containing the glyph representing the character at +a particular text offset. + + + + + + The offset of the text character for which bounding information is required. + + + + Pointer for the x cordinate of the bounding box + + + + Pointer for the y cordinate of the bounding box + + + + Pointer for the width of the bounding box + + + + Pointer for the height of the bounding box + + + + specify whether coordinates are relative to the screen or widget window + + + + + + + + + + + Gets the number of selected regions. +occurred. + + The number of selected regions, or -1 if a failure + + + + + Gets the offset of the character located at coordinates @x and @y. @x and @y +are interpreted as being relative to the screen or this widget's window +depending on @coords. +the specified @x and @y coordinates. + + the offset to the character which is located at + + + + + screen x-position of character + + + + screen y-position of character + + + + specify whether coordinates are relative to the screen or widget window + + + + + + Get the bounding box for text within the specified range. + + + + + + The offset of the first text character for which boundary information is required. + + + + The offset of the text character after the last character for which boundary information is required. + + + + Specify whether coordinates are relative to the screen or widget window. + + + + A pointer to a AtkTextRectangle which is filled in by this function. + + + + + + + + + + + + + + + + + + + + + + Gets the text from the specified selection. + + the selected text. + + + + + The selection number. The selected regions are assigned numbers that correspond to how far the region is from the start of the text. The selected region closest to the beginning of the text region is assigned the number 0, etc. Note that adding, moving or deleting a selected region can change the numbering. + + + + passes back the start position of the selected region + + + + passes back the end position of (e.g. offset immediately past) the selected region + + + + + + Gets the specified text. + + the text from @start_offset up to, but not including @end_offset. + + + + + start position + + + + end position + + + + + + Gets the specified text. +If the boundary_type if ATK_TEXT_BOUNDARY_CHAR the character after the +offset is returned. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_START the returned string +is from the word start after the offset to the next word start. +The returned string will contain the word after the offset if the offset +is inside a word or if the offset is not inside a word. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_END the returned string +is from the word end at or after the offset to the next work end. +The returned string will contain the word after the offset if the offset +is inside a word and will contain the word after the word after the offset +if the offset is not inside a word. +If the boundary type is ATK_TEXT_BOUNDARY_SENTENCE_START the returned +string is from the sentence start after the offset to the next sentence +start. +The returned string will contain the sentence after the offset if the offset +is inside a sentence or if the offset is not inside a sentence. +If the boundary_type is ATK_TEXT_BOUNDARY_SENTENCE_END the returned string +is from the sentence end at or after the offset to the next sentence end. +The returned string will contain the sentence after the offset if the offset +is inside a sentence and will contain the sentence after the sentence +after the offset if the offset is not inside a sentence. +If the boundary type is ATK_TEXT_BOUNDARY_LINE_START the returned +string is from the line start after the offset to the next line start. +If the boundary_type is ATK_TEXT_BOUNDARY_LINE_END the returned string +is from the line end at or after the offset to the next line start. + + the text after @offset bounded by the specified @boundary_type. + + + + + position + + + + An #AtkTextBoundary + + + + the start offset of the returned string + + + + the offset of the first character after the returned substring + + + + + + Gets the specified text. +If the boundary_type if ATK_TEXT_BOUNDARY_CHAR the character at the +offset is returned. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_START the returned string +is from the word start at or before the offset to the word start after +the offset. +The returned string will contain the word at the offset if the offset +is inside a word and will contain the word before the offset if the +offset is not inside a word. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_END the returned string +is from the word end before the offset to the word end at or after the +offset. +The returned string will contain the word at the offset if the offset +is inside a word and will contain the word after to the offset if the +offset is not inside a word. +If the boundary type is ATK_TEXT_BOUNDARY_SENTENCE_START the returned +string is from the sentence start at or before the offset to the sentence +start after the offset. +The returned string will contain the sentence at the offset if the offset +is inside a sentence and will contain the sentence before the offset +if the offset is not inside a sentence. +If the boundary_type is ATK_TEXT_BOUNDARY_SENTENCE_END the returned string +is from the sentence end before the offset to the sentence end at or +after the offset. +The returned string will contain the sentence at the offset if the offset +is inside a sentence and will contain the sentence after the offset +if the offset is not inside a sentence. +If the boundary type is ATK_TEXT_BOUNDARY_LINE_START the returned +string is from the line start at or before the offset to the line +start after the offset. +If the boundary_type is ATK_TEXT_BOUNDARY_LINE_END the returned string +is from the line end before the offset to the line end at or after +the offset. + + the text at @offset bounded by the specified @boundary_type. + + + + + position + + + + An #AtkTextBoundary + + + + the start offset of the returned string + + + + the offset of the first character after the returned substring + + + + + + Gets the specified text. +If the boundary_type if ATK_TEXT_BOUNDARY_CHAR the character before the +offset is returned. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_START the returned string +is from the word start before the word start before the offset to +the word start before the offset. +The returned string will contain the word before the offset if the offset +is inside a word and will contain the word before the word before the +offset if the offset is not inside a word. +If the boundary_type is ATK_TEXT_BOUNDARY_WORD_END the returned string +is from the word end before the word end at or before the offset to the +word end at or before the offset. +The returned string will contain the word before the offset if the offset +is inside a word or if the offset is not inside a word. +If the boundary type is ATK_TEXT_BOUNDARY_SENTENCE_START the returned +string is from the sentence start before the sentence start before +the offset to the sentence start before the offset. +The returned string will contain the sentence before the offset if the +offset is inside a sentence and will contain the sentence before the +sentence before the offset if the offset is not inside a sentence. +If the boundary_type is ATK_TEXT_BOUNDARY_SENTENCE_END the returned string +is from the sentence end before the sentence end at or before the offset to +the sentence end at or before the offset. +The returned string will contain the sentence before the offset if the +offset is inside a sentence or if the offset is not inside a sentence. +If the boundary type is ATK_TEXT_BOUNDARY_LINE_START the returned +string is from the line start before the line start ar or before the offset +to the line start ar or before the offset. +If the boundary_type is ATK_TEXT_BOUNDARY_LINE_END the returned string +is from the line end before the line end before the offset to the +line end before the offset. + + the text before @offset bounded by the specified @boundary_type. + + + + + position + + + + An #AtkTextBoundary + + + + the start offset of the returned string + + + + the offset of the first character after the returned substring + + + + + + Removes the specified selection. + + %TRUE if success, %FALSE otherwise + + + + + The selection number. The selected regions are assigned numbers that correspond to how far the region is from the start of the text. The selected region closest to the beginning of the text region is assigned the number 0, etc. Note that adding, moving or deleting a selected region can change the numbering. + + + + + + Sets the caret (cursor) position to the specified @offset. + + %TRUE if success, %FALSE otherwise. + + + + + position + + + + + + Changes the start and end offset of the specified selection. + + %TRUE if success, %FALSE otherwise + + + + + The selection number. The selected regions are assigned numbers that correspond to how far the region is from the start of the text. The selected region closest to the beginning of the text region is assigned the number 0, etc. Note that adding, moving or deleting a selected region can change the numbering. + + + + the new start position of the selection + + + + the new end position of (e.g. offset immediately past) the selection + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + the text from @start_offset up to, but not including @end_offset. + + + + + + + + start position + + + + end position + + + + + + + + + the text after @offset bounded by the specified @boundary_type. + + + + + + + + position + + + + An #AtkTextBoundary + + + + the start offset of the returned string + + + + the offset of the first character after the returned substring + + + + + + + + + the text at @offset bounded by the specified @boundary_type. + + + + + + + + position + + + + An #AtkTextBoundary + + + + the start offset of the returned string + + + + the offset of the first character after the returned substring + + + + + + + + + the character at @offset. + + + + + + + + position + + + + + + + + + the text before @offset bounded by the specified @boundary_type. + + + + + + + + position + + + + An #AtkTextBoundary + + + + the start offset of the returned string + + + + the offset of the first character after the returned substring + + + + + + + + + the offset position of the caret (cursor). + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + The offset of the text character for which bounding information is required. + + + + Pointer for the x cordinate of the bounding box + + + + Pointer for the y cordinate of the bounding box + + + + Pointer for the width of the bounding box + + + + Pointer for the height of the bounding box + + + + specify whether coordinates are relative to the screen or widget window + + + + + + + + + the number of characters. + + + + + + + + + + + + + the offset to the character which is located at + + + + + + + + screen x-position of character + + + + screen y-position of character + + + + specify whether coordinates are relative to the screen or widget window + + + + + + + + + The number of selected regions, or -1 if a failure + + + + + + + + + + + + + the selected text. + + + + + + + + The selection number. The selected regions are assigned numbers that correspond to how far the region is from the start of the text. The selected region closest to the beginning of the text region is assigned the number 0, etc. Note that adding, moving or deleting a selected region can change the numbering. + + + + passes back the start position of the selected region + + + + passes back the end position of (e.g. offset immediately past) the selected region + + + + + + + + + %TRUE if success, %FALSE otherwise + + + + + + + + the start position of the selected region + + + + the offset of the first character after the selected region. + + + + + + + + + %TRUE if success, %FALSE otherwise + + + + + + + + The selection number. The selected regions are assigned numbers that correspond to how far the region is from the start of the text. The selected region closest to the beginning of the text region is assigned the number 0, etc. Note that adding, moving or deleting a selected region can change the numbering. + + + + + + + + + %TRUE if success, %FALSE otherwise + + + + + + + + The selection number. The selected regions are assigned numbers that correspond to how far the region is from the start of the text. The selected region closest to the beginning of the text region is assigned the number 0, etc. Note that adding, moving or deleting a selected region can change the numbering. + + + + the new start position of the selection + + + + the new end position of (e.g. offset immediately past) the selection + + + + + + + + + %TRUE if success, %FALSE otherwise. + + + + + + + + position + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + The offset of the first text character for which boundary information is required. + + + + The offset of the text character after the last character for which boundary information is required. + + + + Specify whether coordinates are relative to the screen or widget window. + + + + A pointer to a AtkTextRectangle which is filled in by this function. + + + + + + + + + Array of AtkTextRange. The last element of the array returned + + + + + + + + An AtkTextRectagle giving the dimensions of the bounding box. + + + + Specify whether coordinates are relative to the screen or widget window. + + + + Specify the horizontal clip type. + + + + Specify the vertical clip type. + + + + + + + + + + + A structure used to describe a text range. + + + + + + + + + + + + + + + A structure used to store a rectangle used by AtkText. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Gets the value of this object. + + + + + + a #GValue representing the current accessible value + + + + + + Gets the maximum value of this object. + + + + + + a #GValue representing the maximum accessible value + + + + + + Gets the minimum increment by which the value of this object may be changed. If zero, +the minimum increment is undefined, which may mean that it is limited only by the +floating point precision of the platform. + + + + + + a #GValue representing the minimum increment by which the accessible value may be changed + + + + + + Gets the minimum value of this object. + + + + + + a #GValue representing the minimum accessible value + + + + + + Sets the value of this object. + + %TRUE if new value is successfully set, %FALSE otherwise. + + + + + a #GValue which is the desired new accessible value. + + + + + + Gets the value of this object. + + + + + + a #GValue representing the current accessible value + + + + + + Gets the maximum value of this object. + + + + + + a #GValue representing the maximum accessible value + + + + + + Gets the minimum increment by which the value of this object may be changed. If zero, +the minimum increment is undefined, which may mean that it is limited only by the +floating point precision of the platform. + + + + + + a #GValue representing the minimum increment by which the accessible value may be changed + + + + + + Gets the minimum value of this object. + + + + + + a #GValue representing the minimum accessible value + + + + + + Sets the value of this object. + + %TRUE if new value is successfully set, %FALSE otherwise. + + + + + a #GValue which is the desired new accessible value. + + + + + + + + + + + + + + + + + + + + a #GValue representing the current accessible value + + + + + + + + + + + + + + + + a #GValue representing the maximum accessible value + + + + + + + + + + + + + + + + a #GValue representing the minimum accessible value + + + + + + + + + %TRUE if new value is successfully set, %FALSE otherwise. + + + + + + + + a #GValue which is the desired new accessible value. + + + + + + + + + + + + + + + + a #GValue representing the minimum increment by which the accessible value may be changed + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Adds the specified function to the list of functions to be called +when an object receives focus. + + added focus tracker id, or 0 on failure. + + + + + Function to be added to the list of functions to be called when an object receives focus. + + + + + + Adds the specified function to the list of functions to be called +when an event of type event_type occurs. + + added event listener id, or 0 on failure. + + + + + the listener to notify + + + + the type of event for which notification is requested + + + + + + Adds the specified function to the list of functions to be called +when a key event occurs. The @data element will be passed to the +#AtkKeySnoopFunc (@listener) as the @func_data param, on notification. + + added event listener id, or 0 on failure. + + + + + the listener to notify + + + + a #gpointer that points to a block of data that should be sent to the registered listeners, along with the event notification, when it occurs. + + + + + + Frees the memory used by an #AtkAttributeSet, including all its +#AtkAttributes. + + + + + + The #AtkAttributeSet to free + + + + + + Specifies the function to be called for focus tracker initialization. +This function should be called by an implementation of the +ATK interface if any specific work needs to be done to enable +focus tracking. + + + + + + Function to be called for focus tracker initialization + + + + + + Cause the focus tracker functions which have been specified to be +executed for the object. + + + + + + an #AtkObject + + + + + + + + + + + Gets the currently focused object. + + the currently focused object for the current application + + + + + Gets the root accessible container for the current application. + + the root accessible container for the current application + + + + + Gets name string for the GUI toolkit implementing ATK for this application. + + name string for the GUI toolkit implementing ATK for this application + + + + + Gets version string for the GUI toolkit implementing ATK for this application. + + version string for the GUI toolkit implementing ATK for this application + + + + + Gets the current version for ATK. + + version string for ATK + + + + + Get the #AtkRelationType type corresponding to a relation name. +or #ATK_RELATION_NULL if no matching relation type is found. + + the #AtkRelationType enumerated type corresponding to the specified name, + + + + + a string which is the (non-localized) name of an ATK relation type. + + + + + + Gets the description string describing the #AtkRelationType @type. + + the string describing the AtkRelationType + + + + + The #AtkRelationType whose name is required + + + + + + Associate @name with a new #AtkRelationType + + an #AtkRelationType associated with @name + + + + + a name string + + + + + + Removes the specified focus tracker from the list of functions +to be called when any object receives focus. + + + + + + the id of the focus tracker to remove + + + + + + Removes the specified event listener + + + + + + the id of the event listener to remove + + + + + + Removes the specified event listener + + + + + + the id of the event listener to remove + + + + + + Get the #AtkRole type corresponding to a rolew name. +or #ATK_ROLE_INVALID if no matching role is found. + + the #AtkRole enumerated type corresponding to the specified + + + + + a string which is the (non-localized) name of an ATK role. + + + + + + Gets the localized description string describing the #AtkRole @role. + + the localized string describing the AtkRole + + + + + The #AtkRole whose localized name is required + + + + + + Gets the description string describing the #AtkRole @role. + + the string describing the AtkRole + + + + + The #AtkRole whose name is required + + + + + + Registers the role specified by @name. + + an #AtkRole for the new role. + + + + + a character string describing the new role. + + + + + + Gets the #AtkStateType corresponding to the description string @name. + + an #AtkStateType corresponding to @name + + + + + a character string state name + + + + + + Gets the description string describing the #AtkStateType @type. + + the string describing the AtkStateType + + + + + The #AtkStateType whose name is required + + + + + + Register a new object state. + + an #AtkState value for the new state. + + + + + a character string describing the new state. + + + + + + Get the #AtkTextAttribute type corresponding to a text attribute name. +or #ATK_TEXT_ATTRIBUTE_INVALID if no matching text attribute is found. + + the #AtkTextAttribute enumerated type corresponding to the specified + + + + + a string which is the (non-localized) name of an ATK text attribute. + + + + + + Gets the name corresponding to the #AtkTextAttribute + + a string containing the name; this string should not be freed + + + + + The #AtkTextAttribute whose name is required + + + + + + Gets the value for the index of the #AtkTextAttribute +NULL is returned if there are no values maintained for the attr value. + + a string containing the value; this string should not be freed; + + + + + The #AtkTextAttribute for which a value is required + + + + The index of the required value + + + + + + Associate @name with a new #AtkTextAttribute + + an #AtkTextAttribute associated with @name + + + + + a name string + + + + + + Frees the memory associated with an array of AtkTextRange. It is assumed +that the array was returned by the function atk_text_get_bounded_ranges +and is NULL terminated. + + + + + + A pointer to an array of #AtkTextRange which is to be freed. + + + + + + diff --git a/basis/atk/atk.factor b/basis/atk/atk.factor new file mode 100644 index 0000000000..a27f470902 --- /dev/null +++ b/basis/atk/atk.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2009 Anton Gorenko. +! See http://factorcode.org/license.txt for BSD license. +USING: atk.ffi ; +IN: atk + diff --git a/basis/atk/authors.txt b/basis/atk/authors.txt new file mode 100644 index 0000000000..ce9bcc8313 --- /dev/null +++ b/basis/atk/authors.txt @@ -0,0 +1 @@ +Anton Gorenko \ No newline at end of file diff --git a/basis/atk/ffi/ffi.factor b/basis/atk/ffi/ffi.factor new file mode 100644 index 0000000000..8a7be511c6 --- /dev/null +++ b/basis/atk/ffi/ffi.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2010 Anton Gorenko. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.libraries alien.syntax combinators +gobject-introspection kernel system vocabs ; +IN: atk.ffi + +<< +"gobject.ffi" require +>> + +LIBRARY: atk + +<< +"atk" { + { [ os windows? ] [ "libatk-1.0-0.dll" cdecl add-library ] } + { [ os unix? ] [ drop ] } +} cond +>> + +GIR: vocab:atk/Atk-1.0.gir diff --git a/basis/atk/summary.txt b/basis/atk/summary.txt new file mode 100644 index 0000000000..951074f75c --- /dev/null +++ b/basis/atk/summary.txt @@ -0,0 +1 @@ +Atk binding diff --git a/basis/pango/fonts/tags.txt b/basis/atk/tags.txt old mode 100644 new mode 100755 similarity index 100% rename from basis/pango/fonts/tags.txt rename to basis/atk/tags.txt diff --git a/basis/base64/base64-docs.factor b/basis/base64/base64-docs.factor index da2f33c5f9..6d3928efe6 100644 --- a/basis/base64/base64-docs.factor +++ b/basis/base64/base64-docs.factor @@ -3,16 +3,16 @@ IN: base64 HELP: >base64 { $values { "seq" sequence } { "base64" "a string of base64 characters" } } -{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits." } +{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits." } { $examples { $example "USING: prettyprint base64 strings ;" "\"The monorail is a free service.\" >base64 >string ." "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\"" } } -{ $see-also base64> >base64-lines } ; +{ $see-also >base64-lines base64> } ; HELP: >base64-lines { $values { "seq" sequence } { "base64" "a string of base64 characters" } } -{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits. A crlf is inserted for every 76 characters of output." } -{ $see-also base64> >base64-lines } ; +{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits. A crlf is inserted for every 76 characters of output." } +{ $see-also >base64 base64> } ; HELP: base64> diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index 9a57740936..dd1af56def 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -44,7 +44,7 @@ SYMBOL: column : encode3 ( seq -- ) be> 4 iota [ - -6 * shift HEX: 3f bitand ch>base64 write1-lines + -6 * shift 0x3f bitand ch>base64 write1-lines ] with each ; inline : encode-pad ( seq n -- ) diff --git a/basis/biassocs/biassocs-docs.factor b/basis/biassocs/biassocs-docs.factor index 5588920f2e..ac5f4324a4 100644 --- a/basis/biassocs/biassocs-docs.factor +++ b/basis/biassocs/biassocs-docs.factor @@ -18,10 +18,10 @@ HELP: once-at HELP: >biassoc { $values { "assoc" assoc } { "biassoc" biassoc } } -{ $description "Costructs a new biassoc with the same key/value pairs as the given assoc." } ; +{ $description "Constructs a new biassoc with the same key/value pairs as the given assoc." } ; ARTICLE: "biassocs" "Bidirectional assocs" -"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." +"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc operations (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." $nl "Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." $nl diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor index db40408d5e..412e7e0c16 100644 --- a/basis/binary-search/binary-search.factor +++ b/basis/binary-search/binary-search.factor @@ -14,9 +14,9 @@ IN: binary-search midpoint@ midpoint ] [ midpoint quot call { - { +eq+ [ midpoint@ midpoint ] } { +lt+ [ seq from midpoint@ quot (search) ] } { +gt+ [ seq midpoint@ to quot (search) ] } + { +eq+ [ midpoint@ midpoint ] } } case ] if ; inline recursive diff --git a/basis/bit-arrays/bit-arrays-docs.factor b/basis/bit-arrays/bit-arrays-docs.factor index 76b636c3f3..df81771ae0 100644 --- a/basis/bit-arrays/bit-arrays-docs.factor +++ b/basis/bit-arrays/bit-arrays-docs.factor @@ -43,7 +43,7 @@ HELP: ?{ HELP: bit-array { $description "The class of fixed-length bit arrays." } ; -HELP: ( n -- bit-array ) +HELP: { $values { "n" "a non-negative integer" } { "bit-array" "a new " { $link bit-array } } } { $description "Creates a new bit array with the given length and all elements initially set to " { $link f } "." } ; diff --git a/basis/bit-arrays/bit-arrays-tests.factor b/basis/bit-arrays/bit-arrays-tests.factor index 46089e3f7b..79f4844f49 100644 --- a/basis/bit-arrays/bit-arrays-tests.factor +++ b/basis/bit-arrays/bit-arrays-tests.factor @@ -2,6 +2,8 @@ USING: alien sequences sequences.private arrays bit-arrays kernel tools.test math random ; IN: bit-arrays.tests +[ -1 ] [ T{ bad-array-length f -1 } = ] must-fail-with + [ 100 ] [ 100 length ] unit-test [ @@ -65,12 +67,12 @@ IN: bit-arrays.tests t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t } ] [ - HEX: ffffffffffffffffffffffffffffffff integer>bit-array + 0xffffffffffffffffffffffffffffffff integer>bit-array ] unit-test [ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test [ 0 ] [ ?{ } bit-array>integer ] unit-test -[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{ +[ 0xffffffffffffffffffffffffffffffff ] [ ?{ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t @@ -81,6 +83,6 @@ IN: bit-arrays.tests [ 1 ] [ ?{ f t f t } byte-length ] unit-test -[ HEX: a ] [ ?{ f t f t } bit-array>integer ] unit-test +[ 0xa ] [ ?{ f t f t } bit-array>integer ] unit-test -[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test +[ 0x100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index ade7d8ddac..70935ebfa7 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2007, 2010 Slava Pestov. +! Copyright (C) 2007, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.data accessors io.binary math math.bitwise alien.accessors kernel kernel.private sequences sequences.private byte-arrays parser prettyprint.custom fry locals ; +FROM: sequences.private => change-nth-unsafe ; IN: bit-arrays TUPLE: bit-array @@ -41,8 +42,12 @@ TUPLE: bit-array PRIVATE> +ERROR: bad-array-length n ; + : ( n -- bit-array ) - dup bits>bytes bit-array boa ; inline + dup 0 < [ bad-array-length ] when + dup bits>bytes + bit-array boa ; inline M: bit-array length length>> ; inline diff --git a/basis/bit-sets/bit-sets-tests.factor b/basis/bit-sets/bit-sets-tests.factor index 0d4543f8f2..379dc1befc 100644 --- a/basis/bit-sets/bit-sets-tests.factor +++ b/basis/bit-sets/bit-sets-tests.factor @@ -64,3 +64,8 @@ IN: bit-sets.tests [ T{ bit-set f ?{ f } } T{ bit-set f ?{ t } } ] [ 1 dup clone 0 over adjoin ] unit-test + +[ 0 ] [ T{ bit-set f ?{ } } cardinality ] unit-test +[ 0 ] [ T{ bit-set f ?{ f f f f } } cardinality ] unit-test +[ 1 ] [ T{ bit-set f ?{ f t f f } } cardinality ] unit-test +[ 2 ] [ T{ bit-set f ?{ f t f t } } cardinality ] unit-test diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor index aa74c2b9fb..f0d366e7ed 100644 --- a/basis/bit-sets/bit-sets.factor +++ b/basis/bit-sets/bit-sets.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences byte-arrays bit-arrays math hints sets ; +USING: kernel accessors sequences byte-arrays bit-arrays math +math.bitwise hints sets ; IN: bit-sets TUPLE: bit-set { table bit-array read-only } ; @@ -14,19 +15,21 @@ M: bit-set in? over integer? [ table>> ?nth ] [ 2drop f ] if ; inline M: bit-set adjoin - ! This is allowed to crash when the elt couldn't go in the set + ! This is allowed to throw an error when the elt couldn't + ! go in the set [ t ] 2dip table>> set-nth ; M: bit-set delete - ! This isn't allowed to crash if the elt wasn't in the set + ! This isn't allowed to throw an error if the elt wasn't + ! in the set over integer? [ table>> 2dup bounds-check? [ [ f ] 2dip set-nth ] [ 2drop ] if ] [ 2drop ] if ; -! If you do binary set operations with a bitset, it's expected -! that the other thing can also be represented as a bitset +! If you do binary set operations with a bit-set, it's expected +! that the other thing can also be represented as a bit-set ! of the same length. > length ] bi@ = ] [ f ] if + ! Throws an error if there are keys that can't be put + ! in the bit set + over bit-set? [ 2dup [ table>> length ] same? ] [ f ] if [ drop ] [ [ members ] dip table>> length [ [ adjoin ] curry each ] keep @@ -84,3 +88,6 @@ M: bit-set set-like M: bit-set clone table>> clone bit-set boa ; + +M: bit-set cardinality + table>> bit-count ; diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 794faa6055..19961825de 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -5,44 +5,44 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary io.streams.byte-array ; IN: bitstreams.tests -[ BIN: 1111111111 ] +[ 0b1111111111 ] [ - B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + B{ 0x0f 0xff 0xff 0xff } 2 >>byte-pos 6 >>bit-pos 10 swap peek ] unit-test -[ BIN: 111111111 ] +[ 0b111111111 ] [ - B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + B{ 0x0f 0xff 0xff 0xff } 2 >>byte-pos 6 >>bit-pos 9 swap peek ] unit-test -[ BIN: 11111111 ] +[ 0b11111111 ] [ - B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + B{ 0x0f 0xff 0xff 0xff } 2 >>byte-pos 6 >>bit-pos 8 swap peek ] unit-test -[ BIN: 1111111 ] +[ 0b1111111 ] [ - B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + B{ 0x0f 0xff 0xff 0xff } 2 >>byte-pos 6 >>bit-pos 7 swap peek ] unit-test -[ BIN: 111111 ] +[ 0b111111 ] [ - B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + B{ 0x0f 0xff 0xff 0xff } 2 >>byte-pos 6 >>bit-pos 6 swap peek ] unit-test -[ BIN: 11111 ] +[ 0b11111 ] [ - B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + B{ 0x0f 0xff 0xff 0xff } 2 >>byte-pos 6 >>bit-pos 5 swap peek ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 5581e47056..040b95e0d6 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -49,7 +49,7 @@ TUPLE: lsb0-bit-writer < bit-writer ; : new-bit-writer ( class -- bs ) new BV{ } clone >>bytes - 0 0 >>widthed ; inline + zero-widthed >>widthed ; inline : ( -- bs ) msb0-bit-writer new-bit-writer ; @@ -170,7 +170,7 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ; ] unless writer bytes>> ; -:: byte-array-n>seq ( byte-array n -- seq ) +:: byte-array-n>sequence ( byte-array n -- seq ) byte-array length 8 * n / iota byte-array '[ drop n _ read diff --git a/basis/bootstrap/bootstrap-error.factor b/basis/bootstrap/bootstrap-error.factor index 7cae86b186..2530393614 100644 --- a/basis/bootstrap/bootstrap-error.factor +++ b/basis/bootstrap/bootstrap-error.factor @@ -3,7 +3,7 @@ USING: continuations kernel io debugger vocabs words system namespaces ; :c :error -"listener" vocab +"listener" lookup-vocab [ restarts. vocab-main execute ] [ error get die ] if* 1 exit diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 9c753ce08f..e3df913371 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors cpu.architecture vocabs.loader system +USING: accessors cpu.architecture vocabs system sequences namespaces parser kernel kernel.private classes classes.private arrays hashtables vectors classes.tuple sbufs hashtables.private sequences.private math classes.tuple.private -growable namespaces.private assocs words command-line vocabs io +growable namespaces.private assocs words command-line io io.encodings.string libc splitting math.parser memory compiler.units -math.order quotations quotations.private assocs.private ; +math.order quotations quotations.private assocs.private vocabs.loader ; FROM: compiler => enable-optimizer ; IN: bootstrap.compiler @@ -42,7 +42,7 @@ gc ! Compile a set of words ahead of the full compile. ! This set of words was determined semi-empirically ! using the profiler. It improves bootstrap time - ! significantly, because frequenly called words + ! significantly, because frequently called words ! which are also quick to compile are replaced by ! compiled definitions as soon as possible. { @@ -94,7 +94,7 @@ gc { member-eq? split harvest sift cut cut-slice start index clone - set-at reverse push-all class number>string string>number + set-at reverse push-all class-of number>string string>number like clone-like } compile-unoptimized @@ -107,6 +107,17 @@ gc "." write flush + os windows? [ + "GetLastError" "windows.kernel32" lookup-word + "FormatMessageW" "windows.kernel32" lookup-word + 2array compile-unoptimized + ] when + + os unix? [ + "(dlerror)" "alien.libraries.unix" lookup-word + 1array compile-unoptimized + ] when + { malloc calloc free memcpy } compile-unoptimized @@ -118,7 +129,6 @@ gc " done" print flush "alien.syntax" require - "alien.complex" require "io.streams.byte-array.fast" require ] unless diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor index 387903d1e9..3f583599a0 100644 --- a/basis/bootstrap/finish-bootstrap.factor +++ b/basis/bootstrap/finish-bootstrap.factor @@ -1,22 +1,12 @@ -USING: init command-line debugger system continuations -namespaces eval kernel vocabs.loader io ; +USING: init io command-line.startup debugger system +continuations parser.notes namespaces ; [ + ! Set parser-quiet? to match parser.notes top-level form + t parser-quiet? set-global + boot - do-startup-hooks - [ - (command-line) parse-command-line - load-vocab-roots - run-user-init - - "e" get script get or [ - "e" get [ eval( -- ) ] when* - script get [ run-script ] when* - ] [ - "run" get run - ] if - - output-stream get [ stream-flush ] when* - 0 exit - ] [ print-error 1 exit ] recover + [ do-startup-hooks command-line-startup ] + [ print-error :c flush 1 exit ] + recover ] set-startup-quot diff --git a/basis/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor index f77829ae86..98f2557502 100644 --- a/basis/bootstrap/help/help.factor +++ b/basis/bootstrap/help/help.factor @@ -1,6 +1,6 @@ USING: help help.topics help.syntax help.crossref -help.definitions io io.files kernel namespaces vocabs sequences -parser vocabs.loader vocabs.loader.private accessors assocs ; +help.definitions io io.files kernel namespaces sequences +parser vocabs vocabs.loader vocabs.loader.private accessors assocs ; IN: bootstrap.help : load-help ( -- ) @@ -9,7 +9,7 @@ IN: bootstrap.help t load-help? set-global - [ dup vocab [ ] [ no-vocab ] ?if ] load-vocab-hook [ + [ dup lookup-vocab [ drop ] [ no-vocab ] if ] require-hook [ dictionary get values [ docs-loaded?>> not ] filter [ load-docs ] each diff --git a/basis/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor index eeaccd9347..15a0e679c5 100644 --- a/basis/bootstrap/image/download/download.factor +++ b/basis/bootstrap/image/download/download.factor @@ -4,7 +4,7 @@ USING: http.client checksums checksums.md5 splitting assocs kernel io.files bootstrap.image sequences io urls ; IN: bootstrap.image.download -CONSTANT: url URL" http://factorcode.org/images/latest/" +CONSTANT: url URL" http://downloads.factorcode.org/images/latest/" : download-checksums ( -- alist ) url "checksums.txt" >url derive-url http-get nip diff --git a/basis/bootstrap/image/image-docs.factor b/basis/bootstrap/image/image-docs.factor index 2d29274556..616496ae86 100644 --- a/basis/bootstrap/image/image-docs.factor +++ b/basis/bootstrap/image/image-docs.factor @@ -16,5 +16,5 @@ ABOUT: "bootstrap.image" HELP: make-image { $values { "arch" string } } { $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:" -{ $code "x86.32" "unix-x86.64" "winnt-x86.64" "macosx-ppc" "linux-ppc" } +{ $code "x86.32" "unix-x86.64" "windows-x86.64" "linux-ppc" } "The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ; diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 623b169853..f648e691be 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,24 +1,27 @@ -! Copyright (C) 2004, 2010 Slava Pestov. +! Copyright (C) 2004, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.strings arrays byte-arrays generic hashtables hashtables.private io io.binary io.files io.encodings.binary io.pathnames kernel kernel.private math namespaces make parser -prettyprint sequences sequences.generalizations strings sbufs -vectors words quotations assocs system layouts splitting -grouping growable classes classes.private classes.builtin -classes.tuple classes.tuple.private vocabs vocabs.loader -source-files definitions debugger quotations.private combinators +prettyprint sequences combinators.smart strings sbufs vectors +words quotations assocs system layouts splitting grouping +growable classes classes.private classes.builtin classes.tuple +classes.tuple.private vocabs vocabs.loader source-files +definitions debugger quotations.private combinators combinators.short-circuit math.order math.private accessors slots.private generic.single.private compiler.units -compiler.constants fry locals bootstrap.image.syntax -generalizations ; +compiler.constants compiler.codegen.relocation fry locals +bootstrap.image.syntax parser.notes namespaces.private ; IN: bootstrap.image : arch ( os cpu -- arch ) - [ "winnt" = "winnt" "unix" ? ] dip "-" glue ; + 2dup [ windows? ] [ ppc? ] bi* or [ + [ drop unix ] dip + ] unless + [ name>> ] [ name>> ] bi* "-" glue ; : my-arch ( -- arch ) - os name>> cpu name>> arch ; + os cpu arch ; : boot-image-name ( arch -- string ) "boot." ".image" surround ; @@ -28,8 +31,8 @@ IN: bootstrap.image : images ( -- seq ) { - "winnt-x86.32" "unix-x86.32" - "winnt-x86.64" "unix-x86.64" + "windows-x86.32" "unix-x86.32" + "windows-x86.64" "unix-x86.64" } ; > hashcode* ; GENERIC: (eql?) ( obj1 obj2 -- ? ) : eql? ( obj1 obj2 -- ? ) - { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ; + { [ [ class-of ] same? ] [ (eql?) ] } 2&& ; M: fixnum (eql?) eq? ; @@ -53,7 +56,7 @@ M: bignum (eql?) = ; M: float (eql?) fp-bitwise= ; -M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ; +M: sequence (eql?) 2dup [ length ] same? [ [ eql? ] 2all? ] [ 2drop f ] if ; M: object (eql?) = ; @@ -84,12 +87,12 @@ SYMBOL: objects ! Constants -CONSTANT: image-magic HEX: 0f0e0d0c +CONSTANT: image-magic 0x0f0e0d0c CONSTANT: image-version 4 CONSTANT: data-base 1024 -CONSTANT: special-objects-size 70 +CONSTANT: special-objects-size 80 CONSTANT: header-size 10 @@ -101,62 +104,40 @@ CONSTANT: -1-offset 9 SYMBOL: sub-primitives -SYMBOL: jit-relocations - -SYMBOL: jit-offset - -: compute-offset ( -- offset ) - building get length jit-offset get + ; - -: jit-rel ( rc rt -- ) - compute-offset 3array jit-relocations get push-all ; - -SYMBOL: jit-parameters - -: jit-parameter ( parameter -- ) - jit-parameters get push ; - -SYMBOL: jit-literals - -: jit-literal ( literal -- ) - jit-literals get push ; - -: jit-vm ( offset rc -- ) - [ jit-parameter ] dip rt-vm jit-rel ; - -: jit-dlsym ( name rc -- ) - rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ; - :: jit-conditional ( test-quot false-quot -- ) [ 0 test-quot call ] B{ } make length :> len - building get length jit-offset get + len + - [ jit-offset set false-quot call ] B{ } make + building get length extra-offset get + len + + [ extra-offset set false-quot call ] B{ } make [ length test-quot call ] [ % ] bi ; inline -: make-jit ( quot -- jit-parameters jit-literals jit-code ) +: make-jit ( quot -- parameters literals code ) + #! code is a { relocation insns } pair [ - 0 jit-offset set - V{ } clone jit-parameters set - V{ } clone jit-literals set - V{ } clone jit-relocations set + 0 extra-offset set + init-relocation call( -- ) - jit-parameters get >array - jit-literals get >array - jit-relocations get >array - ] B{ } make prefix ; + parameter-table get >array + literal-table get >array + relocation-table get >byte-array + ] B{ } make 2array ; + +: make-jit-no-params ( quot -- code ) + make-jit 2nip ; : jit-define ( quot name -- ) - [ make-jit 2nip ] dip set ; + [ make-jit-no-params ] dip set ; : define-sub-primitive ( quot word -- ) [ make-jit 3array ] dip sub-primitives get set-at ; : define-combinator-primitive ( quot non-tail-quot tail-quot word -- ) [ - [ make-jit ] - [ make-jit 2nip ] - [ make-jit 2nip ] - tri* 5 narray + [ + [ make-jit ] + [ make-jit-no-params ] + [ make-jit-no-params ] + tri* + ] output>array ] dip sub-primitives get set-at ; @@ -185,44 +166,49 @@ SPECIAL-OBJECT: jit-word-jump 26 SPECIAL-OBJECT: jit-word-call 27 SPECIAL-OBJECT: jit-if-word 28 SPECIAL-OBJECT: jit-if 29 -SPECIAL-OBJECT: jit-epilog 30 -SPECIAL-OBJECT: jit-return 31 -SPECIAL-OBJECT: jit-profiling 32 -SPECIAL-OBJECT: jit-push 33 -SPECIAL-OBJECT: jit-dip-word 34 -SPECIAL-OBJECT: jit-dip 35 -SPECIAL-OBJECT: jit-2dip-word 36 -SPECIAL-OBJECT: jit-2dip 37 -SPECIAL-OBJECT: jit-3dip-word 38 -SPECIAL-OBJECT: jit-3dip 39 -SPECIAL-OBJECT: jit-execute 40 -SPECIAL-OBJECT: jit-declare-word 41 +SPECIAL-OBJECT: jit-safepoint 30 +SPECIAL-OBJECT: jit-epilog 31 +SPECIAL-OBJECT: jit-return 32 +SPECIAL-OBJECT: jit-profiling 33 +SPECIAL-OBJECT: jit-push 34 +SPECIAL-OBJECT: jit-dip-word 35 +SPECIAL-OBJECT: jit-dip 36 +SPECIAL-OBJECT: jit-2dip-word 37 +SPECIAL-OBJECT: jit-2dip 38 +SPECIAL-OBJECT: jit-3dip-word 39 +SPECIAL-OBJECT: jit-3dip 40 +SPECIAL-OBJECT: jit-execute 41 +SPECIAL-OBJECT: jit-declare-word 42 -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: c-to-factor-word 43 +SPECIAL-OBJECT: lazy-jit-compile-word 44 +SPECIAL-OBJECT: unwind-native-frames-word 45 +SPECIAL-OBJECT: fpu-state-word 46 +SPECIAL-OBJECT: set-fpu-state-word 47 +SPECIAL-OBJECT: signal-handler-word 48 +SPECIAL-OBJECT: leaf-signal-handler-word 49 +SPECIAL-OBJECT: ffi-signal-handler-word 50 +SPECIAL-OBJECT: ffi-leaf-signal-handler-word 51 -SPECIAL-OBJECT: callback-stub 48 +SPECIAL-OBJECT: callback-stub 53 ! PIC stubs -SPECIAL-OBJECT: pic-load 49 -SPECIAL-OBJECT: pic-tag 50 -SPECIAL-OBJECT: pic-tuple 51 -SPECIAL-OBJECT: pic-check-tag 52 -SPECIAL-OBJECT: pic-check-tuple 53 -SPECIAL-OBJECT: pic-hit 54 -SPECIAL-OBJECT: pic-miss-word 55 -SPECIAL-OBJECT: pic-miss-tail-word 56 +SPECIAL-OBJECT: pic-load 54 +SPECIAL-OBJECT: pic-tag 55 +SPECIAL-OBJECT: pic-tuple 56 +SPECIAL-OBJECT: pic-check-tag 57 +SPECIAL-OBJECT: pic-check-tuple 58 +SPECIAL-OBJECT: pic-hit 59 +SPECIAL-OBJECT: pic-miss-word 60 +SPECIAL-OBJECT: pic-miss-tail-word 61 ! Megamorphic dispatch -SPECIAL-OBJECT: mega-lookup 57 -SPECIAL-OBJECT: mega-lookup-word 58 -SPECIAL-OBJECT: mega-miss-word 59 +SPECIAL-OBJECT: mega-lookup 62 +SPECIAL-OBJECT: mega-lookup-word 63 +SPECIAL-OBJECT: mega-miss-word 64 ! Default definition for undefined words -SPECIAL-OBJECT: undefined-quot 60 +SPECIAL-OBJECT: undefined-quot 65 : special-object-offset ( symbol -- n ) special-objects get at header-size + ; @@ -291,14 +277,14 @@ GENERIC: ' ( obj -- ptr ) : bignum-radix ( -- n ) bignum-bits 2^ 1 - ; -: bignum>seq ( n -- seq ) +: bignum>sequence ( n -- seq ) #! n is positive or zero. [ dup 0 > ] [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ] produce nip ; : emit-bignum ( n -- ) - dup dup 0 < [ neg ] when bignum>seq + dup dup 0 < [ neg ] when bignum>sequence [ nip length 1 + emit-fixnum ] [ drop 0 < 1 0 ? emit ] [ nip emit-seq ] @@ -349,7 +335,7 @@ M: f ' drop \ f type-number ; ! Words : word-sub-primitive ( word -- obj ) - global [ target-word ] bind sub-primitives get at ; + [ target-word ] with-global sub-primitives get at ; : emit-word ( word -- ) [ @@ -364,11 +350,8 @@ M: f ' drop \ f type-number ; [ props>> , ] [ pic-def>> , ] [ pic-tail-def>> , ] - [ drop 0 , ] ! count [ word-sub-primitive , ] - [ drop 0 , ] ! xt - [ drop 0 , ] ! code - [ drop 0 , ] ! profiling + [ drop 0 , ] ! entry point } cleave ] { } make [ ' ] map ] bi @@ -459,11 +442,11 @@ ERROR: tuple-removed class ; : (emit-tuple) ( tuple -- pointer ) [ tuple-slots ] - [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map + [ class-of transfer-word require-tuple-layout ] bi prefix [ ' ] map tuple [ emit-seq ] emit-object ; : emit-tuple ( tuple -- pointer ) - dup class name>> "tombstone" = + dup class-of name>> "tombstone" = [ [ (emit-tuple) ] cache-eql-object ] [ [ (emit-tuple) ] cache-eq-object ] if ; @@ -472,7 +455,7 @@ M: tuple ' emit-tuple ; M: tombstone ' state>> "((tombstone))" "((empty))" ? - "hashtables.private" lookup def>> first + "hashtables.private" lookup-word def>> first [ emit-tuple ] cache-eql-object ; ! Arrays @@ -507,8 +490,7 @@ M: quotation ' emit ! array f ' emit ! cached-effect f ' emit ! cache-counter - 0 emit ! xt - 0 emit ! code + 0 emit ! entry point ] emit-object ] cache-eql-object ; @@ -521,11 +503,12 @@ M: quotation ' { dictionary source-files builtins update-map implementors-map - } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc + } [ [ bootstrap-word ] [ get global-box boa ] bi ] H{ } map>assoc { class<=-cache class-not-cache classes-intersect-cache class-and-cache class-or-cache next-method-quot-cache - } [ H{ } clone ] H{ } map>assoc assoc-union + } [ H{ } clone global-box boa ] H{ } map>assoc assoc-union + global-hashtable boa bootstrap-global set ; : emit-jit-data ( -- ) @@ -544,6 +527,10 @@ M: quotation ' \ unwind-native-frames unwind-native-frames-word set \ fpu-state fpu-state-word set \ set-fpu-state set-fpu-state-word set + \ signal-handler signal-handler-word set + \ leaf-signal-handler leaf-signal-handler-word set + \ ffi-signal-handler ffi-signal-handler-word set + \ ffi-leaf-signal-handler ffi-leaf-signal-handler-word set undefined-def undefined-quot set ; : emit-special-objects ( -- ) @@ -598,12 +585,14 @@ M: quotation ' PRIVATE> : make-image ( arch -- ) - [ - architecture set + architecture associate H{ + { parser-quiet? f } + { auto-use? f } + } assoc-union! [ "resource:/core/bootstrap/stage1.factor" run-file build-image write-image - ] with-scope ; + ] with-variables ; : make-images ( -- ) images [ make-image ] each ; diff --git a/basis/bootstrap/image/syntax/syntax.factor b/basis/bootstrap/image/syntax/syntax.factor index 7025cd61e1..c8f91e224f 100644 --- a/basis/bootstrap/image/syntax/syntax.factor +++ b/basis/bootstrap/image/syntax/syntax.factor @@ -8,7 +8,7 @@ SYMBOL: special-objects SYNTAX: RESET H{ } clone special-objects set-global ; SYNTAX: SPECIAL-OBJECT: - CREATE-WORD scan-word + scan-new-word scan-number [ swap special-objects get set-at ] [ drop define-symbol ] - 2bi ; \ No newline at end of file + 2bi ; diff --git a/basis/bootstrap/image/upload/upload.factor b/basis/bootstrap/image/upload/upload.factor index 7f25ce9c01..8d29cfb5ad 100644 --- a/basis/bootstrap/image/upload/upload.factor +++ b/basis/bootstrap/image/upload/upload.factor @@ -10,7 +10,7 @@ SYMBOL: upload-images-destination : destination ( -- dest ) upload-images-destination get - "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" + "slava_pestov@downloads.factorcode.org:downloads.factorcode.org/images/latest/" or ; : checksums ( -- temp ) "checksums.txt" temp-file ; @@ -30,7 +30,7 @@ SYMBOL: upload-images-destination [ "scp" , boot-image-names % - "temp/checksums.txt" , destination , + checksums , destination , ] { } make try-process ; : new-images ( -- ) diff --git a/basis/bootstrap/io/io.factor b/basis/bootstrap/io/io.factor index b9a49b48b8..789bb1556b 100644 --- a/basis/bootstrap/io/io.factor +++ b/basis/bootstrap/io/io.factor @@ -2,10 +2,11 @@ USING: system vocabs vocabs.loader kernel combinators namespaces sequences io.backend accessors ; IN: bootstrap.io -"bootstrap.compiler" vocab [ - "io.backend." { - { [ "io-backend" get ] [ "io-backend" get ] } - { [ os unix? ] [ "unix." os name>> append ] } - { [ os winnt? ] [ "windows.nt" ] } - } cond append require -] when +"bootstrap.compiler" require +"bootstrap.threads" require + +"io.backend." { + { [ "io-backend" get ] [ "io-backend" get ] } + { [ os unix? ] [ "unix." os name>> append ] } + { [ os windows? ] [ "windows" ] } +} cond append require diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index e3e8b5ddbc..15872ce499 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors init namespaces words words.symbol io -kernel.private math memory continuations kernel io.files -io.pathnames io.backend system parser vocabs sequences -vocabs.loader combinators splitting source-files strings -definitions assocs compiler.units math.parser -generic sets command-line ; +USING: command-line compiler.units continuations definitions io +io.pathnames kernel math math.parser memory namespaces parser +parser.notes sequences sets splitting system +vocabs vocabs.loader ; IN: bootstrap.stage2 SYMBOL: core-bootstrap-time @@ -62,6 +60,10 @@ SYMBOL: bootstrap-time ! We time bootstrap nano-count + ! parser.notes sets this to t in the global namespace. + ! We have to change it back in finish-bootstrap.factor + f parser-quiet? set-global + default-image-name "output-image" set-global "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global @@ -72,8 +74,7 @@ SYMBOL: bootstrap-time (command-line) parse-command-line ! Set dll paths - os wince? [ "windows.ce" require ] when - os winnt? [ "windows.nt" require ] when + os windows? [ "windows" require ] when "staging" get "deploy-vocab" get or [ "stage2: deployment mode" print diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor index 2bc8d612b6..f0b93695dc 100644 --- a/basis/bootstrap/threads/threads.factor +++ b/basis/bootstrap/threads/threads.factor @@ -1,9 +1,6 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: vocabs.loader kernel io.thread threads -compiler.utilities namespaces ; -IN: bootstrap.threads +USE: vocabs -{ "bootstrap.threads" "debugger" } "debugger.threads" require-when - -[ yield ] yield-hook set-global +"threads" require +"io.thread" require diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index c76d4f7898..b1ecbfe8dc 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -1,4 +1,4 @@ -USING: vocabs.loader sequences system combinators ; +USING: vocabs sequences system combinators ; IN: bootstrap.tools { @@ -14,7 +14,7 @@ IN: bootstrap.tools "tools.disassembler" "tools.dispatch" "tools.memory" - "tools.profiler" + "tools.profiler.sampling" "tools.test" "tools.time" "tools.threads" diff --git a/basis/bootstrap/ui/tools/tools.factor b/basis/bootstrap/ui/tools/tools.factor index 3efd156983..2de9be377a 100644 --- a/basis/bootstrap/ui/tools/tools.factor +++ b/basis/bootstrap/ui/tools/tools.factor @@ -1,7 +1,7 @@ -USING: kernel vocabs vocabs.loader sequences system ; +USING: kernel vocabs sequences system vocabs.loader ; { "ui" "help" "tools" } -[ "bootstrap." prepend vocab ] all? [ +[ "bootstrap." prepend lookup-vocab ] all? [ "ui.tools" require { "ui.backend.cocoa" } "ui.backend.cocoa.tools" require-when diff --git a/basis/bootstrap/ui/ui.factor b/basis/bootstrap/ui/ui.factor index 271a99c223..4197980449 100644 --- a/basis/bootstrap/ui/ui.factor +++ b/basis/bootstrap/ui/ui.factor @@ -1,13 +1,15 @@ USING: alien namespaces system combinators kernel sequences -vocabs vocabs.loader ; +vocabs ; IN: bootstrap.ui -"bootstrap.compiler" vocab [ - "ui-backend" get [ - { - { [ os macosx? ] [ "cocoa" ] } - { [ os windows? ] [ "windows" ] } - { [ os unix? ] [ "x11" ] } - } cond - ] unless* "ui.backend." prepend require -] when +"bootstrap.math" require +"bootstrap.compiler" require +"bootstrap.threads" require + +"ui-backend" get [ + { + { [ os macosx? ] [ "cocoa" ] } + { [ os windows? ] [ "windows" ] } + { [ os unix? ] [ "gtk" ] } + } cond +] unless* "ui.backend." prepend require diff --git a/basis/byte-arrays/hex/hex-docs.factor b/basis/byte-arrays/hex/hex-docs.factor index 8a2b842fc9..c2cac8d584 100644 --- a/basis/byte-arrays/hex/hex-docs.factor +++ b/basis/byte-arrays/hex/hex-docs.factor @@ -5,4 +5,4 @@ USING: byte-arrays help.markup help.syntax ; HELP: HEX{ { $syntax "HEX{ 0123 45 67 89abcdef }" } -{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ; +{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored. There must be an even number of hex digits or an error is thrown." } ; diff --git a/basis/byte-arrays/hex/hex-tests.factor b/basis/byte-arrays/hex/hex-tests.factor new file mode 100644 index 0000000000..25f15405e9 --- /dev/null +++ b/basis/byte-arrays/hex/hex-tests.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2011 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test byte-arrays.hex eval ; +IN: byte-arrays.hex.tests + +[ B{ 16 0 8 0 } ] [ HEX{ 10 00 08 00 } ] unit-test +[ B{ 255 255 15 255 255 255 } ] [ HEX{ ffff 0fff ffff } ] unit-test + +[ "HEX{ ffff fff ffff }" parse-string ] must-fail +[ "HEX{ 10 00 08 0 }" parse-string ] must-fail +[ "HEX{ 1 00 00 80 }" parse-string ] must-fail diff --git a/basis/byte-arrays/hex/hex.factor b/basis/byte-arrays/hex/hex.factor index ae9b9c8ba2..4912b0b98b 100644 --- a/basis/byte-arrays/hex/hex.factor +++ b/basis/byte-arrays/hex/hex.factor @@ -1,10 +1,14 @@ -! Copyright (C) 2009 Maxim Savchenko, Slava Pestov. +! Copyright (C) 2009,2011 Maxim Savchenko, Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: grouping lexer ascii parser sequences kernel math.parser ; +USING: ascii grouping kernel math.parser sequences +strings.parser lexer math ; IN: byte-arrays.hex +ERROR: odd-length-hex-string string ; + SYNTAX: HEX{ "}" parse-tokens "" join [ blank? not ] filter + dup length even? [ odd-length-hex-string ] unless 2 group [ hex> ] B{ } map-as suffix! ; diff --git a/basis/cache/cache-tests.factor b/basis/cache/cache-tests.factor new file mode 100755 index 0000000000..ea1c22b2cf --- /dev/null +++ b/basis/cache/cache-tests.factor @@ -0,0 +1,50 @@ +USING: cache tools.test accessors destructors kernel assocs +namespaces ; +IN: cache.tests + +TUPLE: mock-disposable < disposable n ; + +: ( n -- mock-disposable ) + mock-disposable new-disposable swap >>n ; + +M: mock-disposable dispose* drop ; + +[ ] [ "cache" set ] unit-test + +[ 0 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get 2 >>max-age drop ] unit-test + +[ ] [ 1 dup "a" set 2 "cache" get set-at ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ ] [ 2 3 "cache" get set-at ] unit-test + +[ 2 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ ] [ 3 dup "b" set 4 "cache" get set-at ] unit-test + +[ 2 ] [ "cache" get assoc-size ] unit-test + +[ ] [ "cache" get purge-cache ] unit-test + +[ 1 ] [ "cache" get assoc-size ] unit-test + +[ f ] [ 2 "cache" get key? ] unit-test + +[ 3 ] [ 4 "cache" get at n>> ] unit-test + +[ t ] [ "a" get disposed>> ] unit-test + +[ f ] [ "b" get disposed>> ] unit-test + +[ ] [ "cache" get clear-assoc ] unit-test + +[ t ] [ "b" get disposed>> ] unit-test diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor old mode 100644 new mode 100755 index a226500c63..1247774bee --- a/basis/cache/cache.factor +++ b/basis/cache/cache.factor @@ -25,19 +25,21 @@ M: cache-assoc set-at [ ] 2dip assoc>> set-at ; -M: cache-assoc clear-assoc assoc>> clear-assoc ; +M: cache-assoc clear-assoc + [ assoc>> values dispose-each ] + [ assoc>> clear-assoc ] + bi ; M: cache-assoc >alist assoc>> [ value>> ] { } assoc-map-as ; INSTANCE: cache-assoc assoc -M: cache-assoc dispose* - [ values dispose-each ] [ clear-assoc ] bi ; +M: cache-assoc dispose* clear-assoc ; PRIVATE> : purge-cache ( cache -- ) dup max-age>> '[ - [ nip [ 1 + ] change-age age>> _ >= ] assoc-partition - [ values dispose-each ] dip + [ nip [ 1 + ] change-age age>> _ < ] assoc-partition + values dispose-each ] change-assoc drop ; diff --git a/basis/cairo/cairo.factor b/basis/cairo/cairo.factor index 38398ae228..d3edd9022a 100644 --- a/basis/cairo/cairo.factor +++ b/basis/cairo/cairo.factor @@ -6,11 +6,11 @@ sequences namespaces fry continuations destructors math images images.memory math.rectangles ; IN: cairo -ERROR: cairo-error message ; +ERROR: cairo-error n message ; : (check-cairo) ( cairo_status_t -- ) dup CAIRO_STATUS_SUCCESS = - [ drop ] [ cairo_status_to_string cairo-error ] if ; + [ drop ] [ [ ] [ cairo_status_to_string ] bi cairo-error ] if ; : check-cairo ( cairo -- ) cairo_status (check-cairo) ; diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index e364ee9a41..6f0001d5d8 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/basis/cairo/ffi/ffi.factor @@ -9,8 +9,8 @@ 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 ] } + { [ os windows? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] } + { [ os macosx? ] [ "cairo" "libcairo.dylib" cdecl add-library ] } { [ os unix? ] [ ] } } cond >> @@ -77,9 +77,9 @@ ENUM: cairo_status_t CAIRO_STATUS_INVALID_WEIGHT ; ENUM: cairo_content_t - { CAIRO_CONTENT_COLOR HEX: 1000 } - { CAIRO_CONTENT_ALPHA HEX: 2000 } - { CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 } ; + { CAIRO_CONTENT_COLOR 0x1000 } + { CAIRO_CONTENT_ALPHA 0x2000 } + { CAIRO_CONTENT_COLOR_ALPHA 0x3000 } ; CALLBACK: cairo_status_t cairo_write_func_t ( void* closure, uchar* data, uint length ) ; @@ -385,7 +385,7 @@ FUNCTION: void cairo_text_cluster_free ( cairo_text_cluster_t* clusters ) ; ENUM: cairo_text_cluster_flags_t - { CAIRO_TEXT_CLUSTER_FLAG_BACKWARD HEX: 00000001 } ; + { CAIRO_TEXT_CLUSTER_FLAG_BACKWARD 0x00000001 } ; STRUCT: cairo_text_extents_t { x_bearing double } diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index e76aace464..a2549d4438 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -5,10 +5,10 @@ math.order ; IN: calendar HELP: duration -{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ; +{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ; HELP: timestamp -{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ; +{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two durations with the " { $link <=> } " word." } ; { timestamp duration } related-words @@ -33,7 +33,7 @@ HELP: month-names HELP: month-name { $values { "obj" { $or integer timestamp } } { "string" string } } -{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ; +{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ; HELP: month-abbreviations { $values { "value" array } } @@ -42,7 +42,7 @@ HELP: month-abbreviations HELP: month-abbreviation { $values { "n" integer } { "string" string } } -{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ; +{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ; HELP: day-names @@ -55,7 +55,7 @@ HELP: day-name HELP: day-abbreviations2 { $values { "value" array } } -{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ; +{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ; HELP: day-abbreviation2 { $values { "n" integer } { "string" string } } @@ -63,7 +63,7 @@ HELP: day-abbreviation2 HELP: day-abbreviations3 { $values { "value" array } } -{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ; +{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ; HELP: day-abbreviation3 { $values { "n" integer } { "string" string } } @@ -101,7 +101,7 @@ HELP: seconds-per-year HELP: julian-day-number { $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } } -{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." } +{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." } { $warning "Not valid before year -4800 BCE." } ; HELP: julian-day-number>date @@ -323,7 +323,7 @@ HELP: >local-time { $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." } { $examples { $example "USING: accessors calendar kernel prettyprint ;" - "now gmt >local-time [ gmt-offset>> ] bi@ = ." + "now gmt >local-time [ gmt-offset>> ] same? ." "t" } } ; @@ -340,7 +340,7 @@ HELP: >gmt HELP: time* { $values { "obj1" object } { "obj2" object } { "obj3" object } } -{ $description "Multiplies each time slot of a timestamp or duration by a number and make a new duration from the result. Used in the implementation of " { $link before } "." } ; +{ $description "Multiplies each time slot of a timestamp or duration by a number and make a new duration from the result. Used in the implementation of " { $link before } "." } ; { time+ time- time* } related-words HELP: before @@ -355,7 +355,7 @@ HELP: before HELP: { $values { "timestamp" timestamp } } -{ $description "Returns a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ; +{ $description "Returns a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ; HELP: valid-timestamp? { $values { "timestamp" timestamp } { "?" "a boolean" } } @@ -419,7 +419,7 @@ HELP: zeller-congruence { $notes "User code should use the " { $link day-of-week } " word, which takes a " { $snippet "timestamp" } " instead of integers." } ; HELP: days-in-year -{ $values { "obj" "a timestamp or an integer" } { "n" integer } } +{ $values { "obj" "a timestamp or an integer" } { "n" integer } } { $description "Calculates the number of days in a given year." } { $examples { $example "USING: calendar prettyprint ;" @@ -490,11 +490,15 @@ HELP: saturday HELP: midnight { $values { "timestamp" timestamp } { "new-timestamp" timestamp } } -{ $description "Returns a new timestamp that represents today at midnight, or the beginning of the day." } ; +{ $description "Returns a new timestamp that represents the day at midnight, or the beginning of the day." } ; HELP: noon { $values { "timestamp" timestamp } { "new-timestamp" timestamp } } -{ $description "Returns a new timestamp that represents today at noon, or the middle of the day." } ; +{ $description "Returns a new timestamp that represents the day at noon, or the middle of the day." } ; + +HELP: today +{ $values { "timestamp" timestamp } } +{ $description "Returns a timestamp that represents today at midnight." } ; HELP: beginning-of-month { $values { "timestamp" timestamp } { "new-timestamp" timestamp } } @@ -519,7 +523,7 @@ HELP: since-1970 { $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ; ARTICLE: "calendar" "Calendar" -"The two data types used throughout the calendar library:" +"The " { $vocab-link "calendar" } " vocabulary defines two data types and a set of operations on them:" { $subsections timestamp duration @@ -533,13 +537,12 @@ ARTICLE: "calendar" "Calendar" now gmt } -"Converting between timestamps:" +"Time zones:" { $subsections >local-time >gmt + convert-timezone } -"Converting between timezones:" -{ $subsections convert-timezone } "Timestamps relative to each other:" { $subsections "relative-timestamps" } "Operations on units of time:" @@ -548,9 +551,10 @@ ARTICLE: "calendar" "Calendar" "months" "days" } +"Both " { $link timestamp } "s and " { $link duration } "s implement the " { $link "math.order" } "." +$nl "Meta-data about the calendar:" -{ $subsections "calendar-facts" } -; +{ $subsections "calendar-facts" } ; ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic" "Adding timestamps and durations, or durations and durations:" diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 4e6b35161f..45644b035c 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes.tuple combinators combinators.short-circuit kernel locals math math.functions -math.order sequences summary system threads vocabs.loader ; +math.order sequences summary system vocabs vocabs.loader ; IN: calendar HOOK: gmt-offset os ( -- hours minutes seconds ) @@ -33,19 +33,19 @@ TUPLE: timestamp C: timestamp : gmt-offset-duration ( -- duration ) - 0 0 0 gmt-offset ; + 0 0 0 gmt-offset ; inline : ( year month day -- timestamp ) - 0 0 0 gmt-offset-duration ; + 0 0 0 gmt-offset-duration ; inline : ( year month day -- timestamp ) - 0 0 0 instant ; + 0 0 0 instant ; inline : ( year -- timestamp ) - 1 1 ; + 1 1 ; inline : ( year -- timestamp ) - 1 1 ; + 1 1 ; inline ERROR: not-a-month ; M: not-a-month summary @@ -64,12 +64,6 @@ CONSTANT: month-names "July" "August" "September" "October" "November" "December" } - - GENERIC: month-name ( obj -- string ) M: integer month-name check-month 1 - month-names nth ; @@ -161,13 +155,13 @@ M: timestamp easter ( timestamp -- timestamp ) : >time< ( timestamp -- hour minute second ) [ hour>> ] [ minute>> ] [ second>> ] tri ; -: years ( x -- duration ) instant clone swap >>year ; -: months ( x -- duration ) instant clone swap >>month ; -: days ( x -- duration ) instant clone swap >>day ; +: years ( x -- duration ) instant swap >>year ; +: months ( x -- duration ) instant swap >>month ; +: days ( x -- duration ) instant swap >>day ; : weeks ( x -- duration ) 7 * days ; -: hours ( x -- duration ) instant clone swap >>hour ; -: minutes ( x -- duration ) instant clone swap >>minute ; -: seconds ( x -- duration ) instant clone swap >>second ; +: hours ( x -- duration ) instant swap >>hour ; +: minutes ( x -- duration ) instant swap >>minute ; +: seconds ( x -- duration ) instant swap >>second ; : milliseconds ( x -- duration ) 1000 / seconds ; : microseconds ( x -- duration ) 1000000 / seconds ; : nanoseconds ( x -- duration ) 1000000000 / seconds ; @@ -315,13 +309,21 @@ GENERIC: time- ( time1 time2 -- time3 ) gmt-offset-duration convert-timezone ; : >gmt ( timestamp -- timestamp' ) - instant convert-timezone ; + dup gmt-offset>> dup instant = + [ drop ] [ + [ neg +second 0 ] change-second + [ neg +minute 0 ] change-minute + [ neg +hour 0 ] change-hour + [ neg +day 0 ] change-day + [ neg +month 0 ] change-month + [ neg +year 0 ] change-year drop + ] if ; M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; : same-day? ( ts1 ts2 -- ? ) - [ >gmt >date< ] bi@ = ; + [ >gmt >date< ] same? ; : (time-) ( timestamp timestamp -- n ) [ >gmt ] bi@ @@ -348,33 +350,53 @@ M: timestamp time- : before ( duration -- -duration ) -1 time* ; + + M: duration time- - before time+ ; + over timestamp? [ + before time+ + ] [ + [ year>> ] -slots + [ month>> ] -slots + [ day>> ] -slots + [ hour>> ] -slots + [ minute>> ] -slots + [ second>> ] -slots + 2drop + ] if ; : ( -- timestamp ) - 0 0 0 0 0 0 instant ; + 0 0 0 ; inline : valid-timestamp? ( timestamp -- ? ) clone instant >>gmt-offset dup time- time+ = ; : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 instant ; + 1970 ; inline : millis>timestamp ( x -- timestamp ) - [ unix-1970 ] dip milliseconds time+ ; + [ unix-1970 ] dip 1000 / +second ; : timestamp>millis ( timestamp -- n ) unix-1970 (time-) 1000 * >integer ; : micros>timestamp ( x -- timestamp ) - [ unix-1970 ] dip microseconds time+ ; + [ unix-1970 ] dip 1000000 / +second ; : timestamp>micros ( timestamp -- n ) unix-1970 (time-) 1000000 * >integer ; -: now ( -- timestamp ) gmt >local-time ; +: now ( -- timestamp ) + gmt gmt-offset-duration (time+) >>gmt-offset ; + : hence ( duration -- timestamp ) now swap time+ ; + : ago ( duration -- timestamp ) now swap time- ; : zeller-congruence ( year month day -- n ) @@ -422,8 +444,11 @@ M: timestamp day-name day-of-week day-names nth ; : noon ( timestamp -- new-timestamp ) midnight 12 >>hour ; inline +: today ( -- timestamp ) + now midnight ; inline + : beginning-of-month ( timestamp -- new-timestamp ) - midnight 1 >>day ; + midnight 1 >>day ; inline : end-of-month ( timestamp -- new-timestamp ) [ midnight ] [ days-in-month ] bi >>day ; @@ -438,7 +463,7 @@ M: timestamp day-name day-of-week day-names nth ; :: nth-day-this-month ( timestamp n day -- new-timestamp ) timestamp beginning-of-month day day-this-week - dup timestamp [ month>> ] bi@ = [ 1 weeks time+ ] unless + dup timestamp [ month>> ] same? [ 1 weeks time+ ] unless n 1 - [ weeks time+ ] unless-zero ; : last-day-this-month ( timestamp day -- new-timestamp ) @@ -529,21 +554,20 @@ M: timestamp end-of-year 12 >>month 31 >>day ; M: integer end-of-year 12 31 ; : time-since-midnight ( timestamp -- duration ) - dup midnight time- ; + dup midnight time- ; inline : since-1970 ( duration -- timestamp ) - unix-1970 time+ ; + unix-1970 time+ ; inline : timestamp>unix-time ( timestamp -- seconds ) - unix-1970 time- second>> ; + unix-1970 (time-) ; inline : unix-time>timestamp ( seconds -- timestamp ) - seconds unix-1970 time+ ; - -M: duration sleep - duration>nanoseconds >integer nano-count + sleep-until ; + [ unix-1970 ] dip +second ; inline { { [ os unix? ] [ "calendar.unix" ] } { [ os windows? ] [ "calendar.windows" ] } } cond require + +{ "threads" "calendar" } "calendar.threads" require-when diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 35e364e6aa..2d85632585 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -205,7 +205,7 @@ ERROR: invalid-timestamp-format ; read-sp checked-number >>year ":" read-token checked-number >>hour ":" read-token checked-number >>minute - " " read-token checked-number >>second + read-sp checked-number >>second readln parse-rfc822-gmt-offset >>gmt-offset ; : rfc822>timestamp ( str -- timestamp ) @@ -224,7 +224,7 @@ ERROR: invalid-timestamp-format ; read-sp checked-number >>year ":" read-token checked-number >>hour ":" read-token checked-number >>minute - " " read-token checked-number >>second + read-sp checked-number >>second readln parse-rfc822-gmt-offset >>gmt-offset ; : cookie-string>timestamp-1 ( str -- timestamp ) @@ -237,7 +237,7 @@ ERROR: invalid-timestamp-format ; read-sp checked-number >>day ":" read-token checked-number >>hour ":" read-token checked-number >>minute - " " read-token checked-number >>second + read-sp checked-number >>second read-sp checked-number >>year readln parse-rfc822-gmt-offset >>gmt-offset ; @@ -264,7 +264,7 @@ ERROR: invalid-timestamp-format ; [ (hms>timestamp) ] with-string-reader ; : (ymd>timestamp) ( -- timestamp ) - read-ymd 0 0 0 instant ; + read-ymd ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; @@ -292,7 +292,7 @@ TYPED: timestamp>ymdhms ( timestamp: timestamp -- str ) { MONTH " " DD " " [ - dup now [ year>> ] bi@ = + dup now [ year>> ] same? [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if ] } formatted diff --git a/basis/calendar/threads/threads.factor b/basis/calendar/threads/threads.factor new file mode 100644 index 0000000000..efdbb6923d --- /dev/null +++ b/basis/calendar/threads/threads.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2011 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar math system threads ; +IN: calendar.threads + +M: duration sleep + duration>nanoseconds >integer nano-count + sleep-until ; diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 9f7d165925..f106f8810e 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,27 +1,32 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax arrays calendar -kernel math unix unix.time unix.types namespaces system -accessors classes.struct ; +USING: accessors alien.data calendar calendar.private +classes.struct kernel math system unix unix.time unix.types ; IN: calendar.unix +: timeval>seconds ( timeval -- seconds ) + [ sec>> ] [ usec>> 1,000,000 / ] bi + ; inline + +: timeval>micros ( timeval -- micros ) + [ sec>> 1,000,000 * ] [ usec>> ] bi + ; inline + : timeval>duration ( timeval -- duration ) - [ sec>> seconds ] [ usec>> microseconds ] bi time+ ; + timeval>seconds seconds ; inline : timeval>unix-time ( timeval -- timestamp ) - timeval>duration since-1970 ; + [ unix-1970 ] dip timeval>seconds +second ; inline -: timespec>duration ( timespec -- seconds ) - [ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ; +: timespec>seconds ( timespec -- seconds ) + [ sec>> ] [ nsec>> 1,000,000,000 / ] bi + ; inline -: timespec>nanoseconds ( timespec -- seconds ) - [ sec>> 1000000000 * ] [ nsec>> ] bi + ; +: timespec>duration ( timespec -- duration ) + timespec>seconds seconds ; inline : timespec>unix-time ( timespec -- timestamp ) - timespec>duration since-1970 ; + [ unix-1970 ] dip timespec>seconds +second ; inline : get-time ( -- alien ) - f time localtime ; + f time time_t localtime ; inline : timezone-name ( -- string ) get-time zone>> ; @@ -30,11 +35,10 @@ M: unix gmt-offset ( -- hours minutes seconds ) get-time gmtoff>> 3600 /mod 60 /mod ; : current-timeval ( -- timeval ) - timeval f [ gettimeofday io-error ] 2keep drop ; + timeval f [ gettimeofday io-error ] 2keep drop ; inline : system-micros ( -- n ) - current-timeval - [ sec>> 1,000,000 * ] [ usec>> ] bi + ; + current-timeval timeval>micros ; M: unix gmt current-timeval timeval>unix-time ; diff --git a/basis/channels/remote/remote-docs.factor b/basis/channels/remote/remote-docs.factor index c612b4256a..2215d959a3 100644 --- a/basis/channels/remote/remote-docs.factor +++ b/basis/channels/remote/remote-docs.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup channels concurrency.distributed ; +USING: channels concurrency.distributed help.markup help.syntax +io.servers ; IN: channels.remote HELP: @@ -45,9 +46,9 @@ HELP: publish ARTICLE: { "remote-channels" "remote-channels" } "Remote Channels" "Remote channels are channels that can be accessed by other Factor instances. It uses distributed concurrency to serialize and send data between channels." $nl -"To start a remote node, distributed concurrency must have been started. This can be done using " { $link start-node } "." +"To start a remote node, distributed concurrency must have been started. This can be done using " { $link start-server } "." $nl -{ $snippet "\"myhost.com\" 9001 start-node" } +{ $snippet "\"myhost.com\" 9001 start-server" } $nl "Once the node is started, channels can be published using " { $link publish } " to be accessed remotely. " { $link publish } " returns an id which a remote node " diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 76675f9413..f979a6e719 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -14,8 +14,8 @@ SYMBOL: bytes-read : pad-last-block ( str big-endian? length -- str ) [ - [ % ] 2dip HEX: 80 , - [ HEX: 3f bitand calculate-pad-length % ] + [ % ] 2dip 0x80 , + [ 0x3f bitand calculate-pad-length % ] [ 3 shift 8 rot [ >be ] [ >le ] if % ] bi ] B{ } make 64 group ; diff --git a/basis/checksums/fnv1/fnv1-docs.factor b/basis/checksums/fnv1/fnv1-docs.factor index 1c242a6591..4fd109807e 100644 --- a/basis/checksums/fnv1/fnv1-docs.factor +++ b/basis/checksums/fnv1/fnv1-docs.factor @@ -43,7 +43,7 @@ HELP: fnv1a-1024 { $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 1024-bit." } ; ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum" - "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details." + "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See " { $url "http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash" } " for more details." { $subsections fnv1-32 fnv1a-32 diff --git a/basis/checksums/fnv1/fnv1-tests.factor b/basis/checksums/fnv1/fnv1-tests.factor index de665a1547..27c3027769 100644 --- a/basis/checksums/fnv1/fnv1-tests.factor +++ b/basis/checksums/fnv1/fnv1-tests.factor @@ -3,25 +3,25 @@ IN: checksums.fnv1.tests ! A few test vectors taken from http://www.isthe.com/chongo/src/fnv/test_fnv.c -[ HEX: 811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test -[ HEX: 811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test -[ HEX: cbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test -[ HEX: cbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test +[ 0x811c9dc5 ] [ "" fnv1-32 checksum-bytes ] unit-test +[ 0x811c9dc5 ] [ "" fnv1a-32 checksum-bytes ] unit-test +[ 0xcbf29ce484222325 ] [ "" fnv1-64 checksum-bytes ] unit-test +[ 0xcbf29ce484222325 ] [ "" fnv1a-64 checksum-bytes ] unit-test -[ HEX: 050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test -[ HEX: e40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test -[ HEX: af63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test -[ HEX: af63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test +[ 0x050c5d7e ] [ "a" fnv1-32 checksum-bytes ] unit-test +[ 0xe40c292c ] [ "a" fnv1a-32 checksum-bytes ] unit-test +[ 0xaf63bd4c8601b7be ] [ "a" fnv1-64 checksum-bytes ] unit-test +[ 0xaf63dc4c8601ec8c ] [ "a" fnv1a-64 checksum-bytes ] unit-test -[ HEX: 050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test -[ HEX: e70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test -[ HEX: af63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test -[ HEX: af63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test +[ 0x050c5d7d ] [ "b" fnv1-32 checksum-bytes ] unit-test +[ 0xe70c2de5 ] [ "b" fnv1a-32 checksum-bytes ] unit-test +[ 0xaf63bd4c8601b7bd ] [ "b" fnv1-64 checksum-bytes ] unit-test +[ 0xaf63df4c8601f1a5 ] [ "b" fnv1a-64 checksum-bytes ] unit-test -[ HEX: 31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test -[ HEX: bf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test -[ HEX: 340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test -[ HEX: 85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test +[ 0x31f0b262 ] [ "foobar" fnv1-32 checksum-bytes ] unit-test +[ 0xbf9cf968 ] [ "foobar" fnv1a-32 checksum-bytes ] unit-test +[ 0x340d8765a4dda9c2 ] [ "foobar" fnv1-64 checksum-bytes ] unit-test +[ 0x85944171f73967e8 ] [ "foobar" fnv1a-64 checksum-bytes ] unit-test ! I couldn't find any test vectors for 128, 256, 512, or 1024 versions of FNV1 hashes. ! So, just to check that your maths works the same as my maths, here's a few samples computed on my laptop. diff --git a/basis/checksums/fnv1/fnv1.factor b/basis/checksums/fnv1/fnv1.factor index 5cc6b02425..053556537c 100644 --- a/basis/checksums/fnv1/fnv1.factor +++ b/basis/checksums/fnv1/fnv1.factor @@ -24,19 +24,19 @@ CONSTANT: fnv1-256-prime 374144419156711147060143317175368453031918731002211 CONSTANT: fnv1-512-prime 35835915874844867368919076489095108449946327955754392558399825615420669938882575126094039892345713852759 CONSTANT: fnv1-1024-prime 5016456510113118655434598811035278955030765345404790744303017523831112055108147451509157692220295382716162651878526895249385292291816524375083746691371804094271873160484737966720260389217684476157468082573 -CONSTANT: fnv1-32-mod HEX: ffffffff -CONSTANT: fnv1-64-mod HEX: ffffffffffffffff -CONSTANT: fnv1-128-mod HEX: ffffffffffffffffffffffffffffffff -CONSTANT: fnv1-256-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -CONSTANT: fnv1-512-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -CONSTANT: fnv1-1024-mod HEX: ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +CONSTANT: fnv1-32-mod 0xffffffff +CONSTANT: fnv1-64-mod 0xffffffffffffffff +CONSTANT: fnv1-128-mod 0xffffffffffffffffffffffffffffffff +CONSTANT: fnv1-256-mod 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +CONSTANT: fnv1-512-mod 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +CONSTANT: fnv1-1024-mod 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -CONSTANT: fnv1-32-basis HEX: 811c9dc5 -CONSTANT: fnv1-64-basis HEX: cbf29ce484222325 -CONSTANT: fnv1-128-basis HEX: 6c62272e07bb014262b821756295c58d -CONSTANT: fnv1-256-basis HEX: dd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535 -CONSTANT: fnv1-512-basis HEX: b86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9 -CONSTANT: fnv1-1024-basis HEX: 5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3 +CONSTANT: fnv1-32-basis 0x811c9dc5 +CONSTANT: fnv1-64-basis 0xcbf29ce484222325 +CONSTANT: fnv1-128-basis 0x6c62272e07bb014262b821756295c58d +CONSTANT: fnv1-256-basis 0xdd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b4c8caee0535 +CONSTANT: fnv1-512-basis 0xb86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9 +CONSTANT: fnv1-1024-basis 0x5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3 M: fnv1-32 checksum-bytes ( bytes checksum -- value ) drop diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor index 70451252f7..3054a91c80 100644 --- a/basis/checksums/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -15,8 +15,8 @@ IN: checksums.hmac.tests "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ - 50 HEX: dd - 16 HEX: aa md5 hmac-bytes >string + 50 0xdd + 16 0xaa md5 hmac-bytes >string ] unit-test [ @@ -34,12 +34,12 @@ IN: checksums.hmac.tests [ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ - 50 HEX: dd - 16 HEX: aa sha1 hmac-bytes >string + 50 0xdd + 16 0xaa sha1 hmac-bytes >string ] unit-test [ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ] -[ "Hi There" 20 HEX: b sha-256 hmac-bytes hex-string ] unit-test +[ "Hi There" 20 0xb sha-256 hmac-bytes hex-string ] unit-test [ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ] [ diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index cb536cd75e..d6fc24d4b0 100644 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -9,9 +9,9 @@ IN: checksums.hmac : seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ; -: opad ( checksum-state -- seq ) block-size>> HEX: 5c ; +: opad ( checksum-state -- seq ) block-size>> 0x5c ; -: ipad ( checksum-state -- seq ) block-size>> HEX: 36 ; +: ipad ( checksum-state -- seq ) block-size>> 0x36 ; :: init-key ( checksum key checksum-state -- o i ) checksum-state block-size>> key length < diff --git a/basis/checksums/internet/internet-docs.factor b/basis/checksums/internet/internet-docs.factor new file mode 100644 index 0000000000..c25f1246a7 --- /dev/null +++ b/basis/checksums/internet/internet-docs.factor @@ -0,0 +1,11 @@ +USING: help.markup help.syntax ; +IN: checksums.internet + +HELP: internet +{ $class-description "Internet (RFC1071) checksum algorithm." } ; + +ARTICLE: "checksums.internet" "Internet checksum" +"The internet checksum algorithm implements RFC1071 (" { $url "http://www.ietf.org/rfc/rfc1141.txt" } ")." +{ $subsections internet } ; + +ABOUT: "checksums.internet" diff --git a/basis/checksums/internet/internet-tests.factor b/basis/checksums/internet/internet-tests.factor index b01ba28001..249b21104d 100644 --- a/basis/checksums/internet/internet-tests.factor +++ b/basis/checksums/internet/internet-tests.factor @@ -12,10 +12,10 @@ IN: checksums : test-data ( -- bytes ) B{ - HEX: 00 HEX: 01 - HEX: f2 HEX: 03 - HEX: f4 HEX: f5 - HEX: f6 HEX: f7 + 0x00 0x01 + 0xf2 0x03 + 0xf4 0xf5 + 0xf6 0xf7 } ; [ B{ 34 13 } ] [ test-data internet checksum-bytes ] unit-test diff --git a/basis/checksums/internet/internet.factor b/basis/checksums/internet/internet.factor index 8c609674b1..254d46d0ab 100644 --- a/basis/checksums/internet/internet.factor +++ b/basis/checksums/internet/internet.factor @@ -11,6 +11,6 @@ INSTANCE: internet checksum M: internet checksum-bytes drop 0 swap 2 [ le> + ] each - [ -16 shift ] [ HEX: ffff bitand ] bi + + [ -16 shift ] [ 0xffff bitand ] bi + [ -16 shift ] keep + bitnot 2 >le ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index f83d0354f6..6a0d553ec1 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2006, 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io io.binary io.files io.streams.byte-array math -math.functions math.parser namespaces splitting grouping strings -sequences byte-arrays locals sequences.private macros fry -io.encodings.binary math.bitwise checksums accessors -checksums.common checksums.stream combinators combinators.smart -specialized-arrays literals hints ; +USING: alien.c-types alien.data kernel io io.binary io.files +io.streams.byte-array math math.functions math.parser namespaces +splitting grouping strings sequences byte-arrays locals +sequences.private macros fry io.encodings.binary math.bitwise +checksums accessors checksums.common checksums.stream +combinators combinators.smart specialized-arrays literals hints ; +FROM: sequences.private => change-nth-unsafe ; SPECIALIZED-ARRAY: uint IN: checksums.md5 @@ -18,7 +19,7 @@ TUPLE: md5-state < checksum-state state old-state ; : ( -- md5 ) md5-state new-checksum-state 64 >>block-size - uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } + uint-array{ 0x67452301 0xefcdab89 0x98badcfe 0x10325476 } [ clone >>state ] [ >>old-state ] bi ; M: md5 initialize-checksum-state drop ; @@ -183,7 +184,7 @@ HINTS: (process-md5-block-I) { uint-array md5-state } ; ] unless ; : uint-array-cast-le ( byte-array -- uint-array ) - byte-array>le uint-array-cast ; + byte-array>le uint cast-array ; HINTS: uint-array-cast-le byte-array ; diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor index 82d2c2b491..c71cd864f2 100644 --- a/basis/checksums/sha/sha.factor +++ b/basis/checksums/sha/sha.factor @@ -20,19 +20,19 @@ TUPLE: sha1-state < checksum-state K H W word-size ; CONSTANT: initial-H-sha1 { - HEX: 67452301 - HEX: efcdab89 - HEX: 98badcfe - HEX: 10325476 - HEX: c3d2e1f0 + 0x67452301 + 0xefcdab89 + 0x98badcfe + 0x10325476 + 0xc3d2e1f0 } CONSTANT: K-sha1 $[ - 20 HEX: 5a827999 - 20 HEX: 6ed9eba1 - 20 HEX: 8f1bbcdc - 20 HEX: ca62c1d6 + 20 0x5a827999 + 20 0x6ed9eba1 + 20 0x8f1bbcdc + 20 0xca62c1d6 4 { } nappend-as ] @@ -64,83 +64,83 @@ CONSTANT: h 7 CONSTANT: initial-H-224 { - HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939 - HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4 + 0xc1059ed8 0x367cd507 0x3070dd17 0xf70e5939 + 0xffc00b31 0x68581511 0x64f98fa7 0xbefa4fa4 } CONSTANT: initial-H-256 { - HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a - HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19 + 0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a + 0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19 } CONSTANT: initial-H-384 { - HEX: cbbb9d5dc1059ed8 - HEX: 629a292a367cd507 - HEX: 9159015a3070dd17 - HEX: 152fecd8f70e5939 - HEX: 67332667ffc00b31 - HEX: 8eb44a8768581511 - HEX: db0c2e0d64f98fa7 - HEX: 47b5481dbefa4fa4 + 0xcbbb9d5dc1059ed8 + 0x629a292a367cd507 + 0x9159015a3070dd17 + 0x152fecd8f70e5939 + 0x67332667ffc00b31 + 0x8eb44a8768581511 + 0xdb0c2e0d64f98fa7 + 0x47b5481dbefa4fa4 } CONSTANT: initial-H-512 { - HEX: 6a09e667f3bcc908 - HEX: bb67ae8584caa73b - HEX: 3c6ef372fe94f82b - HEX: a54ff53a5f1d36f1 - HEX: 510e527fade682d1 - HEX: 9b05688c2b3e6c1f - HEX: 1f83d9abfb41bd6b - HEX: 5be0cd19137e2179 + 0x6a09e667f3bcc908 + 0xbb67ae8584caa73b + 0x3c6ef372fe94f82b + 0xa54ff53a5f1d36f1 + 0x510e527fade682d1 + 0x9b05688c2b3e6c1f + 0x1f83d9abfb41bd6b + 0x5be0cd19137e2179 } CONSTANT: K-256 { - HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5 - HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5 - HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3 - HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174 - HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc - HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da - HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7 - HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967 - HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13 - HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85 - HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3 - HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070 - HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5 - HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3 - HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208 - HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2 + 0x428a2f98 0x71374491 0xb5c0fbcf 0xe9b5dba5 + 0x3956c25b 0x59f111f1 0x923f82a4 0xab1c5ed5 + 0xd807aa98 0x12835b01 0x243185be 0x550c7dc3 + 0x72be5d74 0x80deb1fe 0x9bdc06a7 0xc19bf174 + 0xe49b69c1 0xefbe4786 0x0fc19dc6 0x240ca1cc + 0x2de92c6f 0x4a7484aa 0x5cb0a9dc 0x76f988da + 0x983e5152 0xa831c66d 0xb00327c8 0xbf597fc7 + 0xc6e00bf3 0xd5a79147 0x06ca6351 0x14292967 + 0x27b70a85 0x2e1b2138 0x4d2c6dfc 0x53380d13 + 0x650a7354 0x766a0abb 0x81c2c92e 0x92722c85 + 0xa2bfe8a1 0xa81a664b 0xc24b8b70 0xc76c51a3 + 0xd192e819 0xd6990624 0xf40e3585 0x106aa070 + 0x19a4c116 0x1e376c08 0x2748774c 0x34b0bcb5 + 0x391c0cb3 0x4ed8aa4a 0x5b9cca4f 0x682e6ff3 + 0x748f82ee 0x78a5636f 0x84c87814 0x8cc70208 + 0x90befffa 0xa4506ceb 0xbef9a3f7 0xc67178f2 } CONSTANT: K-384 { - HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc - HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118 - HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2 - HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 - HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 - HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 - HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 - HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 - HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df - HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b - HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 - HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 - HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 - HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 - HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec - HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b - HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 - HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b - HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c - HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817 + 0x428a2f98d728ae22 0x7137449123ef65cd 0xb5c0fbcfec4d3b2f 0xe9b5dba58189dbbc + 0x3956c25bf348b538 0x59f111f1b605d019 0x923f82a4af194f9b 0xab1c5ed5da6d8118 + 0xd807aa98a3030242 0x12835b0145706fbe 0x243185be4ee4b28c 0x550c7dc3d5ffb4e2 + 0x72be5d74f27b896f 0x80deb1fe3b1696b1 0x9bdc06a725c71235 0xc19bf174cf692694 + 0xe49b69c19ef14ad2 0xefbe4786384f25e3 0x0fc19dc68b8cd5b5 0x240ca1cc77ac9c65 + 0x2de92c6f592b0275 0x4a7484aa6ea6e483 0x5cb0a9dcbd41fbd4 0x76f988da831153b5 + 0x983e5152ee66dfab 0xa831c66d2db43210 0xb00327c898fb213f 0xbf597fc7beef0ee4 + 0xc6e00bf33da88fc2 0xd5a79147930aa725 0x06ca6351e003826f 0x142929670a0e6e70 + 0x27b70a8546d22ffc 0x2e1b21385c26c926 0x4d2c6dfc5ac42aed 0x53380d139d95b3df + 0x650a73548baf63de 0x766a0abb3c77b2a8 0x81c2c92e47edaee6 0x92722c851482353b + 0xa2bfe8a14cf10364 0xa81a664bbc423001 0xc24b8b70d0f89791 0xc76c51a30654be30 + 0xd192e819d6ef5218 0xd69906245565a910 0xf40e35855771202a 0x106aa07032bbd1b8 + 0x19a4c116b8d2d0c8 0x1e376c085141ab53 0x2748774cdf8eeb99 0x34b0bcb5e19b48a8 + 0x391c0cb3c5c95a63 0x4ed8aa4ae3418acb 0x5b9cca4f7763e373 0x682e6ff3d6b2b8a3 + 0x748f82ee5defb2fc 0x78a5636f43172f60 0x84c87814a1f0ab72 0x8cc702081a6439ec + 0x90befffa23631e28 0xa4506cebde82bde9 0xbef9a3f7b2c67915 0xc67178f2e372532b + 0xca273eceea26619c 0xd186b8c721c0c207 0xeada7dd6cde0eb1e 0xf57d4f7fee6ed178 + 0x06f067aa72176fba 0x0a637dc5a2c898a6 0x113f9804bef90dae 0x1b710b35131c471b + 0x28db77f523047d84 0x32caab7b40c72493 0x3c9ebe0a15c9bebc 0x431d67c49c100d4c + 0x4cc5d4becb3e42b6 0x597f299cfc657e2a 0x5fcb6fab3ad6faec 0x6c44198c4a475817 } ALIAS: K-512 K-384 @@ -308,17 +308,17 @@ M: sha2-short checksum-block [ prepare-message-schedule ] [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ; -: seq>byte-array ( seq n -- string ) +: sequence>byte-array ( seq n -- string ) '[ _ >be ] map B{ } concat-as ; : sha1>checksum ( sha2 -- bytes ) - H>> 4 seq>byte-array ; + H>> 4 sequence>byte-array ; : sha-224>checksum ( sha2 -- bytes ) - H>> 7 head 4 seq>byte-array ; + H>> 7 head 4 sequence>byte-array ; : sha-256>checksum ( sha2 -- bytes ) - H>> 4 seq>byte-array ; + H>> 4 sequence>byte-array ; : pad-last-short-block ( state -- ) [ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri diff --git a/basis/classes/struct/authors.txt b/basis/classes/struct/authors.txt index f13c9c1e77..b1b0eae445 100644 --- a/basis/classes/struct/authors.txt +++ b/basis/classes/struct/authors.txt @@ -1 +1,4 @@ Joe Groff +Daniel Ehrenberg +John Benediktsson +Slava Pestov diff --git a/basis/classes/struct/bit-accessors/bit-accessors-tests.factor b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor index ecf7b68a2d..44bc90b023 100644 --- a/basis/classes/struct/bit-accessors/bit-accessors-tests.factor +++ b/basis/classes/struct/bit-accessors/bit-accessors-tests.factor @@ -4,5 +4,5 @@ USING: classes.struct.bit-accessors tools.test effects kernel sequences random stack-checker ; IN: classes.struct.bit-accessors.test -[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test -[ t ] [ 20 random 20 random bit-writer infer (( n alien -- )) effect= ] unit-test +[ t ] [ 20 random 20 random bit-reader infer ( alien -- n ) effect= ] unit-test +[ t ] [ 20 random 20 random bit-writer infer ( n alien -- ) effect= ] unit-test diff --git a/basis/classes/struct/bit-accessors/bit-accessors.factor b/basis/classes/struct/bit-accessors/bit-accessors.factor index c5959ab7ac..9893ce416c 100644 --- a/basis/classes/struct/bit-accessors/bit-accessors.factor +++ b/basis/classes/struct/bit-accessors/bit-accessors.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math fry locals math.order alien.accessors ; +USING: alien.accessors fry kernel locals math math.bitwise +math.order sequences ; IN: classes.struct.bit-accessors ! Bitfield accessors are little-endian on all platforms ! Why not? It's unspecified in C : ones-between ( start end -- n ) - [ 2^ 1 - ] bi@ swap bitnot bitand ; + [ on-bits ] bi@ swap unmask ; :: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' ) offset 8 /mod :> ( i start-bit ) @@ -25,10 +26,10 @@ IN: classes.struct.bit-accessors combine-quot: ( prev-quot shift-amount next-quot -- quot ) -- quot ) offset bits step-quot manipulate-bits - dup zero? [ 3drop ] [ + [ 2drop ] [ step-quot combine-quot bit-manipulator combine-quot call( prev shift next -- quot ) - ] if ; inline recursive + ] if-zero ; inline recursive : bit-reader ( offset bits -- quot: ( alien -- n ) ) [ neg '[ _ alien-unsigned-1 _ bitand _ shift ] ] diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index b7b51432dd..64d2dfa70c 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -1,20 +1,25 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types alien.data alien.prettyprint arrays -assocs classes classes.struct combinators combinators.short-circuit -continuations fry kernel libc make math math.parser mirrors -prettyprint.backend prettyprint.custom prettyprint.sections -see.private sequences slots strings summary words ; +USING: accessors alien alien.c-types alien.data +alien.prettyprint arrays assocs classes classes.struct +combinators combinators.short-circuit continuations fry kernel +libc make math math.parser mirrors prettyprint.backend +prettyprint.custom prettyprint.sections see.private sequences +slots strings summary words ; IN: classes.struct.prettyprint = - [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ] - [ drop \ STRUCT: ] if ; + struct-slots + { + { [ dup [ packed?>> ] all? ] [ drop \ PACKED-STRUCT: ] } + { [ dup length 1 <= ] [ drop \ STRUCT: ] } + { [ dup [ offset>> 0 = ] all? ] [ drop \ UNION-STRUCT: ] } + [ drop \ STRUCT: ] + } cond ; : struct>assoc ( struct -- assoc ) - [ class struct-slots ] [ struct-slot-values ] bi zip ; + [ class-of struct-slots ] [ struct-slot-values ] bi zip ; : pprint-struct-slot ( slot -- ) assoc [ [ name>> ] dip ] assoc-map ] bi \ } (pprint-tuple) ] ?pprint-tuple ; : pprint-struct-pointer ( struct -- ) - \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ; + \ S@ [ [ class-of pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ; PRIVATE> @@ -53,7 +58,7 @@ M: struct pprint-delims drop \ S{ \ } ; M: struct >pprint-sequence - [ class ] [ struct-slot-values ] bi class-slot-sequence ; + [ class-of ] [ struct-slot-values ] bi class-slot-sequence ; M: struct pprint* [ pprint-struct ] @@ -61,7 +66,7 @@ M: struct pprint* M: struct summary [ - dup class name>> % + dup class-of name>> % " struct of " % byte-length # " bytes " % @@ -71,19 +76,19 @@ TUPLE: struct-mirror { object read-only } ; C: struct-mirror : get-struct-slot ( struct slot -- value present? ) - over class struct-slots slot-named + over class-of struct-slots slot-named [ name>> reader-word execute( struct -- value ) t ] [ drop f f ] if* ; : set-struct-slot ( value struct slot -- ) - over class struct-slots slot-named + over class-of struct-slots slot-named [ name>> writer-word execute( value struct -- ) ] [ 2drop ] if* ; : reset-struct-slot ( struct slot -- ) - over class struct-slots slot-named + over class-of struct-slots slot-named [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ] [ drop ] if* ; : reset-struct-slots ( struct -- ) - dup class struct-prototype + dup class-of struct-prototype dup byte-length memcpy ; M: struct-mirror at* diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index 68a4876f92..2457e86a1a 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/basis/classes/struct/struct-docs.factor @@ -55,12 +55,23 @@ HELP: UNION-STRUCT: { $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } } { $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ; +HELP: PACKED-STRUCT: +{ $syntax "PACKED-STRUCT: class { slot type } { slot type } ... ;" } +{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } } +{ $description "Defines a new " { $link struct } " type with no alignment padding between slots or at the end. In all other respects, behaves like " { $link POSTPONE: STRUCT: } "." } ; + HELP: define-struct-class { $values { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } } { $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ; +HELP: define-packed-struct-class +{ $values + { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } +} +{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: PACKED-STRUCT: } " syntax." } ; + HELP: define-union-struct-class { $values { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" } @@ -88,6 +99,10 @@ HELP: memory>struct } { $description "Constructs a new " { $link struct } " of the specified " { $snippet "class" } " at the memory location referenced by " { $snippet "ptr" } ". The referenced memory is unchanged." } ; +HELP: read-struct +{ $values { "class" class } { "struct" struct } } +{ $description "Reads a new " { $link struct } " of the specified " { $snippet "class" } "." } ; + HELP: struct { $class-description "The parent class of all struct types." } ; @@ -110,18 +125,18 @@ ARTICLE: "classes.struct.examples" "Struct class examples" { $code "test-struct ." } "Creating a new instance with slots initialized from the stack:" { $code - "USING: libc specialized-arrays ;" + "USING: libc specialized-arrays alien.data ;" "SPECIALIZED-ARRAY: char" "" "42" - "\"Hello, chicken.\" >char-array" + "\"Hello, chicken.\" char >c-array" "1024 malloc" "test-struct ." } ; ARTICLE: "classes.struct.define" "Defining struct classes" "Struct classes are defined using a syntax similar to the " { $link POSTPONE: TUPLE: } " syntax for defining tuple classes:" -{ $subsections POSTPONE: STRUCT: } +{ $subsections POSTPONE: STRUCT: POSTPONE: PACKED-STRUCT: } "Union structs are also supported, which behave like structs but share the same memory for all the slots." { $subsections POSTPONE: UNION-STRUCT: } ; diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index 90f60a4205..dba07661ad 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,12 +1,14 @@ ! (c)Joe Groff bsd license -USING: accessors alien alien.c-types alien.data alien.syntax ascii -assocs byte-arrays classes.struct classes.tuple.parser -classes.tuple.private classes.tuple combinators compiler.tree.debugger -compiler.units delegate destructors io.encodings.utf8 io.pathnames -io.streams.string kernel libc literals math mirrors namespaces -prettyprint prettyprint.config see sequences specialized-arrays -system tools.test parser lexer eval layouts generic.single classes -vocabs ; +USING: accessors alien alien.c-types alien.data alien.syntax +ascii assocs byte-arrays classes.struct +classes.struct.prettyprint classes.struct.prettyprint.private +classes.tuple.parser classes.tuple.private classes.tuple +combinators compiler.tree.debugger compiler.units delegate +destructors io.encodings.utf8 io.pathnames io.streams.string +kernel libc literals math mirrors namespaces prettyprint +prettyprint.config see sequences specialized-arrays system +tools.test parser lexer eval layouts generic.single classes +vocabs generic classes.private definitions ; FROM: math => float ; FROM: specialized-arrays.private => specialized-array-vocab ; QUALIFIED-WITH: alien.c-types c @@ -26,7 +28,7 @@ STRUCT: struct-test-foo { z bool } ; STRUCT: struct-test-bar - { w ushort initial: HEX: ffff } + { w ushort initial: 0xffff } { foo struct-test-foo } ; [ 12 ] [ struct-test-foo heap-size ] unit-test @@ -51,7 +53,7 @@ STRUCT: struct-test-bar [ { { "underlying" B{ 98 0 0 98 127 0 0 127 0 0 0 0 } } { { "x" char } 98 } - { { "y" int } HEX: 7F00007F } + { { "y" int } 0x7F00007F } { { "z" bool } f } } ] [ B{ 98 0 0 98 127 0 0 127 0 0 0 0 } struct-test-foo memory>struct @@ -131,6 +133,9 @@ STRUCT: struct-test-bar [ make-mirror clear-assoc ] keep ] unit-test +[ POSTPONE: STRUCT: ] +[ struct-test-foo struct-definer-word ] unit-test + UNION-STRUCT: struct-test-float-and-bits { f c:float } { bits uint } ; @@ -140,6 +145,9 @@ UNION-STRUCT: struct-test-float-and-bits [ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test +[ POSTPONE: UNION-STRUCT: ] +[ struct-test-float-and-bits struct-definer-word ] unit-test + STRUCT: struct-test-string-ptr { x c-string } ; @@ -153,36 +161,30 @@ STRUCT: struct-test-string-ptr [ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ] [ - [ - boa-tuples? off - c-object-pointers? off + H{ { boa-tuples? f } { c-object-pointers? f } } [ struct-test-foo 7654 >>y [ pprint ] with-string-writer - ] with-scope + ] with-variables ] unit-test [ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ] [ - [ - c-object-pointers? on + H{ { c-object-pointers? t } } [ 12 struct-test-foo memory>struct [ pprint ] with-string-writer - ] with-scope + ] with-variables ] unit-test [ "S{ struct-test-foo f 0 7654 f }" ] [ - [ - boa-tuples? on - c-object-pointers? off + H{ { boa-tuples? t } { c-object-pointers? f } } [ struct-test-foo 7654 >>y [ pprint ] with-string-writer - ] with-scope + ] with-variables ] unit-test [ "S@ struct-test-foo f" ] [ - [ - c-object-pointers? off + H{ { c-object-pointers? f } } [ f struct-test-foo memory>struct [ pprint ] with-string-writer - ] with-scope + ] with-variables ] unit-test [ "USING: alien.c-types classes.struct ; @@ -221,7 +223,7 @@ UNION-STRUCT: struct-test-float-and-bits { type bool } { class object } } -} ] [ struct-test-foo c-type fields>> ] unit-test +} ] [ struct-test-foo lookup-c-type fields>> ] unit-test [ { T{ struct-slot-spec @@ -238,7 +240,7 @@ UNION-STRUCT: struct-test-float-and-bits { class $[ cell 4 = integer fixnum ? ] } { initial 0 } } -} ] [ struct-test-float-and-bits c-type fields>> ] unit-test +} ] [ struct-test-float-and-bits lookup-c-type fields>> ] unit-test STRUCT: struct-test-equality-1 { x int } ; @@ -265,7 +267,7 @@ STRUCT: struct-test-equality-2 [ struct-test-equality-1 5 >>x struct-test-equality-1 malloc-struct &free 5 >>x - [ hashcode ] bi@ = + [ hashcode ] same? ] with-destructors ] unit-test @@ -289,7 +291,7 @@ SPECIALIZED-ARRAY: struct-test-optimization [ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test [ t ] [ - [ 3 third y>> ] + [ 3 struct-test-optimization third y>> ] { memory>struct y>> } inlined? ] unit-test @@ -297,7 +299,7 @@ SPECIALIZED-ARRAY: struct-test-optimization [ t ] [ [ struct-test-optimization memory>struct x>> second ] - { memory>struct x>> } inlined? + { memory>struct x>> int } inlined? ] unit-test [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test @@ -320,7 +322,7 @@ STRUCT: clone-test-struct { x int } { y char[3] } ; clone-test-struct 1 >>x char-array{ 9 1 1 } >>y clone - [ x>> ] [ y>> >char-array ] bi + [ x>> ] [ y>> char >c-array ] bi ] unit-test [ t 1 char-array{ 9 1 1 } ] [ @@ -328,7 +330,7 @@ STRUCT: clone-test-struct { x int } { y char[3] } ; clone-test-struct malloc-struct &free 1 >>x char-array{ 9 1 1 } >>y clone - [ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri + [ >c-ptr byte-array? ] [ x>> ] [ y>> char >c-array ] tri ] with-destructors ] unit-test @@ -460,8 +462,8 @@ cpu ppc? [ { y int } { x longlong } ; - [ 12 ] [ ppc-align-test-2 heap-size ] unit-test - [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test + [ 16 ] [ ppc-align-test-2 heap-size ] unit-test + [ 8 ] [ "x" ppc-align-test-2 offset-of ] unit-test ] when STRUCT: struct-test-delegate @@ -482,3 +484,62 @@ SPECIALIZED-ARRAY: void* STRUCT: silly-array-field-test { x int*[3] } ; [ t ] [ silly-array-field-test x>> void*-array? ] unit-test + +! Packed structs +PACKED-STRUCT: packed-struct-test + { d c:int } + { e c:short } + { f c:int } + { g c:char } + { h c:int } ; + +[ 15 ] [ packed-struct-test heap-size ] unit-test + +[ 0 ] [ "d" packed-struct-test offset-of ] unit-test +[ 4 ] [ "e" packed-struct-test offset-of ] unit-test +[ 6 ] [ "f" packed-struct-test offset-of ] unit-test +[ 10 ] [ "g" packed-struct-test offset-of ] unit-test +[ 11 ] [ "h" packed-struct-test offset-of ] unit-test + +[ POSTPONE: PACKED-STRUCT: ] +[ packed-struct-test struct-definer-word ] unit-test + +STRUCT: struct-1 { a c:int } ; +PACKED-STRUCT: struct-1-packed { a c:int } ; +UNION-STRUCT: struct-1-union { a c:int } ; + +[ "USING: alien.c-types classes.struct ; +IN: classes.struct.tests +STRUCT: struct-1 { a int initial: 0 } ; +" ] +[ \ struct-1 [ see ] with-string-writer ] unit-test +[ "USING: alien.c-types classes.struct ; +IN: classes.struct.tests +PACKED-STRUCT: struct-1-packed { a int initial: 0 } ; +" ] +[ \ struct-1-packed [ see ] with-string-writer ] unit-test +[ "USING: alien.c-types classes.struct ; +IN: classes.struct.tests +STRUCT: struct-1-union { a int initial: 0 } ; +" ] +[ \ struct-1-union [ see ] with-string-writer ] unit-test + +! Bug #206 +STRUCT: going-to-redefine { a uint } ; +[ ] [ + "IN: classes.struct.tests TUPLE: going-to-redefine b ;" eval( -- ) +] unit-test +[ f ] [ \ going-to-redefine \ clone ?lookup-method ] unit-test +[ f ] [ \ going-to-redefine \ struct-slot-values ?lookup-method ] unit-test + +! Test reset-class on structs, which should forget all the accessors, clone, and struct-slot-values +STRUCT: some-accessors { aaa uint } { bbb int } ; +[ ] [ [ \ some-accessors reset-class ] with-compilation-unit ] unit-test +[ f ] [ \ some-accessors \ a>> ?lookup-method ] unit-test +[ f ] [ \ some-accessors \ a<< ?lookup-method ] unit-test +[ f ] [ \ some-accessors \ b>> ?lookup-method ] unit-test +[ f ] [ \ some-accessors \ b<< ?lookup-method ] unit-test +[ f ] [ \ some-accessors \ clone ?lookup-method ] unit-test +[ f ] [ \ some-accessors \ struct-slot-values ?lookup-method ] unit-test + +<< \ some-accessors forget >> diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 15a7b72c6c..3ca6bf05a0 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -1,15 +1,15 @@ -! (c)Joe Groff, Daniel Ehrenberg bsd license +! Copyright (C) 2010, 2011 Joe Groff, Daniel Ehrenberg, +! John Benediktsson, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license USING: accessors alien alien.c-types alien.data alien.parser -arrays byte-arrays classes classes.private classes.parser -classes.tuple classes.tuple.parser classes.tuple.private -combinators combinators.short-circuit combinators.smart -cpu.architecture definitions functors.backend fry -generalizations generic.parser kernel kernel.private lexer libc -locals macros make math math.order parser quotations sequences -slots slots.private specialized-arrays vectors words summary -namespaces assocs vocabs.parser math.functions -classes.struct.bit-accessors bit-arrays -stack-checker.dependencies system layouts ; +arrays byte-arrays classes classes.parser classes.private +classes.struct.bit-accessors classes.tuple classes.tuple.parser +combinators combinators.smart cpu.architecture definitions fry +functors.backend generalizations generic generic.parser io kernel +kernel.private lexer libc locals macros math math.order parser +quotations sequences slots slots.private specialized-arrays +stack-checker.dependencies summary vectors vocabs.loader +vocabs.parser words ; FROM: delegate.private => group-words slot-group-words ; QUALIFIED: math IN: classes.struct @@ -24,8 +24,11 @@ M: struct-must-have-slots summary TUPLE: struct { (underlying) c-ptr read-only } ; +! We hijack the core slots vocab's slot-spec type for struct +! fields. Note that 'offset' is in bits, not bytes, to support +! bitfields. TUPLE: struct-slot-spec < slot-spec - type ; + type packed? ; ! For a struct-bit-slot-spec, offset is in bits, not bytes TUPLE: struct-bit-slot-spec < struct-slot-spec @@ -49,7 +52,7 @@ M: struct >c-ptr M: struct equal? over struct? [ - 2dup [ class ] bi@ = [ + 2dup [ class-of ] same? [ 2dup [ >c-ptr ] both? [ [ >c-ptr ] [ binary-object ] bi* memory= ] [ [ >c-ptr not ] both? ] @@ -59,7 +62,7 @@ M: struct equal? M: struct hashcode* binary-object over - [ hashcode* ] [ 3drop 0 ] if ; inline + [ uchar hashcode* ] [ 3drop 0 ] if ; inline : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable @@ -68,6 +71,9 @@ M: struct hashcode* ! optimized down to efficient code if it is. '[ _ boa ] call( ptr -- struct ) ; inline +: read-struct ( class -- struct ) + [ heap-size read ] [ memory>struct ] bi ; + struct ; inline @@ -133,11 +139,11 @@ M: struct-bit-slot-spec (writer-quot) drop [ >c-ptr ] ; MACRO: read-struct-slot ( slot -- ) - dup type>> depends-on-c-type + dup type>> add-depends-on-c-type (reader-quot) ; MACRO: write-struct-slot ( slot -- ) - dup type>> depends-on-c-type + dup type>> add-depends-on-c-type (writer-quot) ; PRIVATE> @@ -146,7 +152,7 @@ M: struct-class boa>object [ ] [ struct-slots ] bi [ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ; -M: struct-class initial-value* ; inline +M: struct-class initial-value* t ; inline ! Struct slot accessors @@ -170,7 +176,7 @@ TUPLE: struct-c-type < abstract-c-type INSTANCE: struct-c-type value-type -M: struct-c-type c-type ; +M: struct-c-type lookup-c-type ; M: struct-c-type base-type ; @@ -192,6 +198,9 @@ M: struct-c-type base-type ; [ \ struct-slot-values ] [ struct-slot-values-quot ] bi define-inline-method ; +: forget-struct-slot-values-method ( class -- ) + \ struct-slot-values ?lookup-method forget ; + : clone-underlying ( struct -- byte-array ) binary-object memory>byte-array ; inline @@ -200,6 +209,9 @@ M: struct-c-type base-type ; [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi define-inline-method ; +: forget-clone-method ( class -- ) + \ clone ?lookup-method forget ; + :: c-type-for-class ( class slots size align -- c-type ) struct-c-type new byte-array >>class @@ -213,11 +225,14 @@ M: struct-c-type base-type ; GENERIC: compute-slot-offset ( offset class -- offset' ) -: c-type-align-at ( class offset -- n ) - 0 = [ c-type-align-first ] [ c-type-align ] if ; +: c-type-align-at ( slot-spec offset -- n ) + over packed?>> [ 2drop 1 ] [ + [ type>> ] dip + 0 = [ c-type-align-first ] [ c-type-align ] if + ] if ; M: struct-slot-spec compute-slot-offset - [ type>> over c-type-align-at 8 * align ] keep + [ over c-type-align-at 8 * align ] keep [ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ; M: struct-bit-slot-spec compute-slot-offset @@ -231,12 +246,12 @@ M: struct-bit-slot-spec compute-slot-offset : struct-alignment ( slots -- align ) [ struct-bit-slot-spec? not ] filter - 1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ; + 1 [ dup offset>> c-type-align-at max ] reduce ; PRIVATE> -M: struct byte-length class "struct-size" word-prop ; foldable -M: struct binary-zero? binary-object [ 0 = ] all? ; inline +M: struct byte-length class-of "struct-size" word-prop ; foldable +M: struct binary-zero? binary-object uchar [ 0 = ] all? ; inline ! class definition @@ -262,40 +277,64 @@ M: struct binary-zero? binary-object [ 0 = ] all? ; inline bi ; : check-struct-slots ( slots -- ) - [ type>> c-type drop ] each ; + [ type>> lookup-c-type drop ] each ; : redefine-struct-tuple-class ( class -- ) [ struct f define-tuple-class ] [ make-final ] bi ; -:: (define-struct-class) ( class slots offsets-quot -- ) - slots empty? [ struct-must-have-slots ] when +:: (define-struct-class) ( class slot-specs offsets-quot alignment-quot -- ) + slot-specs check-struct-slots + slot-specs empty? [ struct-must-have-slots ] when class redefine-struct-tuple-class - slots make-slots dup check-struct-slots :> slot-specs slot-specs offsets-quot call :> unaligned-size - slot-specs struct-alignment :> alignment + slot-specs alignment-quot call :> alignment unaligned-size alignment align :> size - class slot-specs size alignment c-type-for-class :> c-type + class slot-specs size alignment c-type-for-class :> c-type c-type class typedef class slot-specs define-accessors class size "struct-size" set-word-prop class dup make-struct-prototype "prototype" set-word-prop class (struct-methods) ; inline + +: make-packed-slots ( slots -- slot-specs ) + make-slots [ t >>packed? ] map! ; + PRIVATE> : define-struct-class ( class slots -- ) - [ compute-struct-offsets ] (define-struct-class) ; + make-slots + [ compute-struct-offsets ] [ struct-alignment ] + (define-struct-class) ; + +: define-packed-struct-class ( class slots -- ) + make-packed-slots + [ compute-struct-offsets ] [ drop 1 ] + (define-struct-class) ; : define-union-struct-class ( class slots -- ) - [ compute-union-offsets ] (define-struct-class) ; + make-slots + [ compute-union-offsets ] [ struct-alignment ] + (define-struct-class) ; ERROR: invalid-struct-slot token ; : struct-slot-class ( c-type -- class' ) - c-type c-type-boxed-class + lookup-c-type c-type-boxed-class dup \ byte-array = [ drop \ c-ptr ] when ; +M: struct-class reset-class + { + [ dup "c-type" word-prop fields>> forget-slot-accessors ] + [ + [ forget-struct-slot-values-method ] + [ forget-clone-method ] bi + ] + [ { "c-type" "layout" "struct-size" } reset-props ] + [ call-next-method ] + } cleave ; + SYMBOL: bits: : ( name c-type attributes -- slot-spec ) [ struct-slot-spec new ] 3dip [ >>name ] - [ [ >>type ] [ struct-slot-class >>class ] bi ] + [ [ >>type ] [ struct-slot-class init-slot-class ] bi ] [ [ dup empty? ] [ peel-off-struct-attributes ] until drop ] tri* ; ; + scan-token scan-c-type \ } parse-until ; : parse-struct-slots ( slots -- slots' more? ) scan-token { @@ -346,12 +385,16 @@ PRIVATE> } case ; : parse-struct-definition ( -- class slots ) - CREATE-CLASS 8 [ parse-struct-slots ] [ ] while >array + scan-new-class 8 [ parse-struct-slots ] [ ] while >array dup [ name>> ] map check-duplicate-slots ; PRIVATE> SYNTAX: STRUCT: parse-struct-definition define-struct-class ; + +SYNTAX: PACKED-STRUCT: + parse-struct-definition define-packed-struct-class ; + SYNTAX: UNION-STRUCT: parse-struct-definition define-union-struct-class ; @@ -365,18 +408,19 @@ SYNTAX: S@ array ] [ search ] if ; + scan-token dup "{" = [ drop \ } parse-until >array ] [ search ] if ; : parse-struct-slot` ( accum -- accum ) scan-string-param scan-c-type` \ } parse-until [ suffix! ] 3curry append! ; : parse-struct-slots` ( accum -- accum more? ) - scan { + scan-token { { ";" [ f ] } { "{" [ parse-struct-slot` t ] } [ invalid-struct-slot ] } case ; + PRIVATE> FUNCTOR-SYNTAX: STRUCT: @@ -385,6 +429,4 @@ FUNCTOR-SYNTAX: STRUCT: [ parse-struct-slots` ] [ ] while [ >array define-struct-class ] append! ; -USING: vocabs vocabs.loader ; - { "classes.struct" "prettyprint" } "classes.struct.prettyprint" require-when diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 9e984d5d00..e7e60e1a17 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -17,7 +17,7 @@ CONSTANT: NSApplicationDelegateReplyFailure 2 : NSApp ( -- app ) NSApplication -> sharedApplication ; -CONSTANT: NSAnyEventMask HEX: ffffffff +CONSTANT: NSAnyEventMask 0xffffffff FUNCTION: void NSBeep ( ) ; diff --git a/basis/cocoa/cocoa-docs.factor b/basis/cocoa/cocoa-docs.factor index ac529d297a..d0043f55cf 100644 --- a/basis/cocoa/cocoa-docs.factor +++ b/basis/cocoa/cocoa-docs.factor @@ -49,7 +49,7 @@ $nl "objc-calling" "objc-subclassing" } -"A utility library is built to faciliate the development of Cocoa applications in Factor:" +"A utility library is built to facilitate the development of Cocoa applications in Factor:" { $subsections "cocoa-application-utils" "cocoa-dialogs" diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor index fee8c60c21..a2a0b533c3 100644 --- a/basis/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -16,7 +16,7 @@ CLASS: Foo < NSObject dup 1.0 2.0 101.0 102.0 -> foo: -> release ; -test-foo +[ ] [ test-foo ] unit-test [ 1.0 ] [ "x" get CGRect-x ] unit-test [ 2.0 ] [ "x" get CGRect-y ] unit-test @@ -28,11 +28,13 @@ CLASS: Bar < NSObject METHOD: NSRect bar [ test-foo "x" get ] ] -Bar [ - -> alloc -> init - dup -> bar "x" set - -> release -] compile-call +[ ] [ + Bar [ + -> alloc -> init + dup -> bar "x" set + -> release + ] compile-call +] unit-test [ 1.0 ] [ "x" get CGRect-x ] unit-test [ 2.0 ] [ "x" get CGRect-y ] unit-test diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index fb21843c0f..558c4f5f26 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -14,14 +14,14 @@ SYMBOL: sent-messages : remember-send ( selector -- ) sent-messages (remember-send) ; -SYNTAX: -> scan dup remember-send suffix! \ send suffix! ; +SYNTAX: -> scan-token dup remember-send suffix! \ send suffix! ; SYMBOL: super-sent-messages : remember-super-send ( selector -- ) super-sent-messages (remember-send) ; -SYNTAX: SUPER-> scan dup remember-super-send suffix! \ super-send suffix! ; +SYNTAX: SUPER-> scan-token dup remember-super-send suffix! \ super-send suffix! ; SYMBOL: frameworks @@ -29,9 +29,9 @@ frameworks [ V{ } clone ] initialize [ frameworks get [ load-framework ] each ] "cocoa" add-startup-hook -SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; +SYNTAX: FRAMEWORK: scan-token [ load-framework ] [ frameworks get push ] bi ; -SYNTAX: IMPORT: scan [ ] import-objc-class ; +SYNTAX: IMPORT: scan-token [ ] import-objc-class ; "Importing Cocoa classes..." print @@ -43,7 +43,9 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ; "NSApplication" "NSArray" "NSAutoreleasePool" + "NSBitmapImageRep" "NSBundle" + "NSColorSpace" "NSData" "NSDictionary" "NSError" diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 4d786aaf72..f1670e1de9 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -5,17 +5,17 @@ arrays assocs classes.struct continuations combinators compiler core-graphics.types stack-checker kernel math namespaces make quotations sequences strings words cocoa.runtime cocoa.types io macros memoize io.encodings.utf8 effects layouts libc lexer init -core-foundation fry generalizations specialized-arrays ; +core-foundation fry generalizations specialized-arrays locals ; QUALIFIED-WITH: alien.c-types c IN: cocoa.messages SPECIALIZED-ARRAY: void* -: make-sender ( method function -- quot ) +: make-sender ( signature function -- quot ) [ over first , f , , second , \ alien-invoke , ] [ ] make ; -: sender-stub ( method function -- word ) - [ "( sender-stub )" f dup ] 2dip +: sender-stub ( name signature function -- word ) + [ "( sender-stub:" ")" surround f dup ] 2dip over first large-struct? [ "_stret" append ] when make-sender dup infer define-declared ; @@ -25,13 +25,13 @@ SYMBOL: super-message-senders message-senders [ H{ } clone ] initialize super-message-senders [ H{ } clone ] initialize -: cache-stub ( method assoc function -- ) - '[ _ sender-stub ] cache drop ; +:: cache-stub ( name signature function assoc -- ) + signature assoc [ [ name ] dip function sender-stub ] cache drop ; -: cache-stubs ( method -- ) - [ super-message-senders get "objc_msgSendSuper" cache-stub ] - [ message-senders get "objc_msgSend" cache-stub ] - bi ; +: cache-stubs ( name signature -- ) + [ "objc_msgSendSuper" super-message-senders get cache-stub ] + [ "objc_msgSend" message-senders get cache-stub ] + 2bi ; : ( receiver -- super ) [ ] [ object_getClass class_getSuperclass ] bi @@ -109,7 +109,7 @@ H{ { "d" c:double } { "B" c:bool } { "v" c:void } - { "*" c:c-string } + { "*" c:void* } { "?" unknown_type } { "@" id } { "#" Class } @@ -209,16 +209,18 @@ ERROR: no-objc-type name ; [ utf8 alien>string parse-objc-type ] keep (free) ; +: method-name ( method -- name ) + method_getName sel_getName ; + : register-objc-method ( method -- ) - dup method-return-type over method-arg-types 2array - dup cache-stubs - swap method_getName sel_getName - objc-methods get set-at ; + [ method-name ] + [ [ method-return-type ] [ method-arg-types ] bi 2array ] bi + [ cache-stubs ] [ swap objc-methods get set-at ] 2bi ; : each-method-in-class ( class quot -- ) [ { uint } [ class_copyMethodList ] with-out-parameters ] dip over 0 = [ 3drop ] [ - [ ] dip + [ void* ] dip [ each ] [ drop (free) ] 2bi ] if ; inline @@ -231,7 +233,7 @@ ERROR: no-objc-type name ; [ class-init-hooks get set-at ] [ [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi - (( -- class )) define-declared + ( -- class ) define-declared ] bi ; : import-objc-class ( name quot -- ) diff --git a/basis/cocoa/plists/plists-tests.factor b/basis/cocoa/plists/plists-tests.factor index e5d7dfd239..dab09e0c80 100644 --- a/basis/cocoa/plists/plists-tests.factor +++ b/basis/cocoa/plists/plists-tests.factor @@ -15,13 +15,13 @@ IN: cocoa.plists.tests H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 5 } } H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 6 } } } [ >cf &CFRelease ] [ >cf &CFRelease ] bi - [ plist> ] bi@ = + [ plist> ] same? ] unit-test [ t ] [ { "DeviceUsagePage" 1 } [ >cf &CFRelease ] [ >cf &CFRelease ] bi - [ plist> ] bi@ = + [ plist> ] same? ] unit-test [ V{ "DeviceUsagePage" "Yes" } ] [ diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index e8d28b0004..0ac7a43229 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -2,10 +2,11 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: strings arrays hashtables assocs sequences fry macros -cocoa.messages cocoa.classes cocoa.application cocoa kernel -namespaces io.backend math cocoa.enumeration byte-arrays -combinators alien.c-types alien.data words core-foundation -quotations core-foundation.data core-foundation.utilities ; +cocoa cocoa.messages cocoa.classes cocoa.application +kernel namespaces io.backend math cocoa.enumeration byte-arrays +combinators alien.c-types alien.data words quotations +core-foundation core-foundation.data core-foundation.strings +core-foundation.utilities ; IN: cocoa.plists : >plist ( value -- plist ) >cf -> autorelease ; @@ -18,9 +19,6 @@ DEFER: plist> ) ( NSString -- string ) - -> UTF8String ; - : (plist-NSNumber>) ( NSNumber -- number ) dup -> doubleValue dup >integer = [ -> longLongValue ] [ -> doubleValue ] if ; @@ -55,7 +53,7 @@ ERROR: invalid-plist-object object ; : plist> ( plist -- value ) { - { NSString [ (plist-NSString>) ] } + { NSString [ CF>string ] } { NSNumber [ (plist-NSNumber>) ] } { NSData [ (plist-NSData>) ] } { NSArray [ (plist-NSArray>) ] } diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 9e49835242..4fbfa622c3 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -21,15 +21,15 @@ STRUCT: objc-super { receiver id } { class Class } ; -CONSTANT: CLS_CLASS HEX: 1 -CONSTANT: CLS_META HEX: 2 -CONSTANT: CLS_INITIALIZED HEX: 4 -CONSTANT: CLS_POSING HEX: 8 -CONSTANT: CLS_MAPPED HEX: 10 -CONSTANT: CLS_FLUSH_CACHE HEX: 20 -CONSTANT: CLS_GROW_CACHE HEX: 40 -CONSTANT: CLS_NEED_BIND HEX: 80 -CONSTANT: CLS_METHOD_ARRAY HEX: 100 +CONSTANT: CLS_CLASS 0x1 +CONSTANT: CLS_META 0x2 +CONSTANT: CLS_INITIALIZED 0x4 +CONSTANT: CLS_POSING 0x8 +CONSTANT: CLS_MAPPED 0x10 +CONSTANT: CLS_FLUSH_CACHE 0x20 +CONSTANT: CLS_GROW_CACHE 0x40 +CONSTANT: CLS_NEED_BIND 0x80 +CONSTANT: CLS_METHOD_ARRAY 0x100 FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ; @@ -62,10 +62,6 @@ FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ; FUNCTION: uint method_getNumberOfArguments ( Method method ) ; -FUNCTION: uint method_getSizeOfArguments ( Method method ) ; - -FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, c-string* type, int* offset ) ; - FUNCTION: void* method_copyReturnType ( Method method ) ; FUNCTION: void* method_copyArgumentType ( Method method, uint index ) ; diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index 3b88a8868c..742b0b6b75 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -43,12 +43,12 @@ IN: cocoa.subclassing : prepare-method ( ret types quot -- type imp ) [ [ encode-types ] 2keep ] dip '[ _ _ cdecl _ alien-callback ] - (( -- callback )) define-temp ; + ( -- callback ) define-temp ; : prepare-methods ( methods -- methods ) [ [ first4 prepare-method 3array ] map - ] with-compilation-unit ; + ] with-nested-compilation-unit ; :: (redefine-objc-method) ( class method -- ) method init-method :> ( sel imp types ) @@ -58,7 +58,7 @@ IN: cocoa.subclassing ] [ class sel imp types add-method ] if* ; - + : redefine-objc-methods ( methods name -- ) dup class-exists? [ objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each @@ -92,7 +92,7 @@ SYNTAX: CLASS: [ sift { "self" "selector" } prepend ] tri* ; : parse-method-body ( names -- quot ) - [ [ make-local ] map ] H{ } make-assoc + [ [ make-local ] map ] H{ } make (parse-lambda) ?rewrite-closures first ; SYNTAX: METHOD: diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor index a4b1b7f210..4f18adeedf 100644 --- a/basis/cocoa/windows/windows.factor +++ b/basis/cocoa/windows/windows.factor @@ -16,7 +16,7 @@ CONSTANT: NSTexturedBackgroundWindowMask 256 CONSTANT: NSUtilityWindowMask 16 CONSTANT: NSDocModalWindowMask 64 CONSTANT: NSNonactivatingPanelMask 128 -CONSTANT: NSHUDWindowMask HEX: 1000 +CONSTANT: NSHUDWindowMask 0x1000 CONSTANT: NSBackingStoreRetained 0 CONSTANT: NSBackingStoreNonretained 1 @@ -27,7 +27,7 @@ CONSTANT: NSBackingStoreBuffered 2 -> initWithContentRect:styleMask:backing:defer: ; : class-for-style ( style -- NSWindow/NSPanel ) - HEX: 1ef0 bitand zero? NSWindow NSPanel ? ; + 0x1ef0 bitand zero? NSWindow NSPanel ? ; : ( view rect style -- window ) dup class-for-style [ swap -> setContentView: ] keep diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index c17d1069b2..14d3e0ad1a 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -9,7 +9,7 @@ IN: colors.constants : parse-color ( line -- name color ) first4 [ [ string>number 255 /f ] tri@ 1.0 ] dip - [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap ; + [ blank? ] trim-head H{ { CHAR: \s CHAR: - } } substitute swap ; : parse-colors ( lines -- assoc ) [ "!" head? not ] filter @@ -30,4 +30,4 @@ ERROR: no-such-color name ; : named-color ( name -- color ) dup colors at [ ] [ no-such-color ] ?if ; -SYNTAX: COLOR: scan named-color suffix! ; +SYNTAX: COLOR: scan-token named-color suffix! ; diff --git a/basis/colors/hex/authors.txt b/basis/colors/hex/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/colors/hex/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/colors/hex/hex-docs.factor b/basis/colors/hex/hex-docs.factor new file mode 100644 index 0000000000..9f67875da2 --- /dev/null +++ b/basis/colors/hex/hex-docs.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: colors help.markup help.syntax strings ; + +IN: colors.hex + +HELP: hex>rgba +{ $values { "hex" string } { "rgba" color } } +{ $description "Converts a hexadecimal string value into a " { $link color } "." } +; + +HELP: rgba>hex +{ $values { "rgba" color } { "hex" string } } +{ $description "Converts a " { $link color } " into a hexadecimal string value." } +; + +HELP: HEXCOLOR: +{ $syntax "HEXCOLOR: value" } +{ $description "Parses as a " { $link color } " object with the given hexadecimal value." } +{ $examples + { $code + "USING: colors.hex io.styles ;" + "\"Hello!\" { { foreground HEXCOLOR: 336699 } } format nl" + } +} ; + +ARTICLE: "colors.hex" "HEX colors" +"The " { $vocab-link "colors.hex" } " vocabulary implements colors specified " +"by their hexadecimal value." +{ $subsections + hex>rgba + rgba>hex + POSTPONE: HEXCOLOR: +} +{ $see-also "colors" } ; + +ABOUT: "colors.hex" diff --git a/basis/colors/hex/hex-tests.factor b/basis/colors/hex/hex-tests.factor new file mode 100644 index 0000000000..0ab1fd5216 --- /dev/null +++ b/basis/colors/hex/hex-tests.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: colors colors.hex tools.test ; + +IN: colors.hex.test + +[ HEXCOLOR: 000000 ] [ 0.0 0.0 0.0 1.0 ] unit-test +[ HEXCOLOR: FFFFFF ] [ 1.0 1.0 1.0 1.0 ] unit-test +[ HEXCOLOR: abcdef ] [ "abcdef" hex>rgba ] unit-test +[ HEXCOLOR: abcdef ] [ "ABCDEF" hex>rgba ] unit-test +[ "ABCDEF" ] [ HEXCOLOR: abcdef rgba>hex ] unit-test diff --git a/basis/colors/hex/hex.factor b/basis/colors/hex/hex.factor new file mode 100644 index 0000000000..c9f13b7236 --- /dev/null +++ b/basis/colors/hex/hex.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2010 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: accessors colors formatting grouping kernel lexer math +math.parser sequences ; + +IN: colors.hex + +: hex>rgba ( hex -- rgba ) + 2 group [ hex> 255 /f ] map first3 1.0 ; + +: rgba>hex ( rgba -- hex ) + [ red>> ] [ green>> ] [ blue>> ] tri + [ 255 * >integer ] tri@ "%02X%02X%02X" sprintf ; + +SYNTAX: HEXCOLOR: scan-token hex>rgba suffix! ; diff --git a/basis/colors/hex/summary.txt b/basis/colors/hex/summary.txt new file mode 100644 index 0000000000..37b6abaac4 --- /dev/null +++ b/basis/colors/hex/summary.txt @@ -0,0 +1 @@ +Hexadecimal colors diff --git a/basis/combinators/random/authors.txt b/basis/combinators/random/authors.txt new file mode 100644 index 0000000000..2c5e05bdac --- /dev/null +++ b/basis/combinators/random/authors.txt @@ -0,0 +1 @@ +Jon Harper diff --git a/basis/combinators/random/random-docs.factor b/basis/combinators/random/random-docs.factor new file mode 100644 index 0000000000..826474420c --- /dev/null +++ b/basis/combinators/random/random-docs.factor @@ -0,0 +1,120 @@ +! 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 prettyprint ;" + "{" + " { 0.2 [ 1 ] }" + " { 0.3 [ 2 ] }" + " { 0.5 [ 3 ] }" + "} casep ." + } + $nl + { $code + "USING: combinators.random prettyprint ;" + "{" + " { 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 prettyprint ;" + "{" + " { 0.5 [ 1 ] }" + " { 0.5 [ 2 ] }" + " { 1 [ 3 ] }" + "} casep* ." + } + $nl + { $code + "USING: combinators.random prettyprint ;" + "{" + " { 0.5 [ 1 ] }" + " { 0.5 [ 2 ] }" + " [ 3 ]" + "} casep* ." + } + +} +{ $see-also casep } ; + +HELP: unlessp +{ $values + { "p" "a number between 0 and 1" } { "false" quotation } +} +{ $description "Variant of " { $link ifp } " with no " { $snippet "true" } " quotation." } ; + +HELP: whenp +{ $values + { "p" "a number between 0 and 1" } { "true" quotation } +} +{ $description "Variant of " { $link ifp } " with no " { $snippet "false" } " quotation." } ; + +ARTICLE: "combinators.random" "Random combinators" +"The " { $vocab-link "combinators.random" } " vocabulary implements simple combinators to easily express random choices" +" between multiple code paths." +$nl +"For all these combinators, the stack effect of the different given quotations or words must be the same." +$nl +"Variants of if, when and unless:" +{ $subsections + ifp + whenp + unlessp } +"Variants of case:" +{ $subsections + casep + casep* + call-random + execute-random +} ; + +ABOUT: "combinators.random" diff --git a/basis/combinators/random/random-tests.factor b/basis/combinators/random/random-tests.factor new file mode 100644 index 0000000000..32f2874538 --- /dev/null +++ b/basis/combinators/random/random-tests.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2010 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test combinators.random combinators.random.private ; +IN: combinators.random.tests + +[ 1 ] [ 1 [ 1 ] [ 2 ] ifp ] unit-test +[ 2 ] [ 0 [ 1 ] [ 2 ] ifp ] unit-test + +[ 3 ] +[ { { 0 [ 1 ] } + { 0 [ 2 ] } + { 1 [ 3 ] } + [ 4 ] + } casep ] unit-test + +[ 4 ] +[ { { 0 [ 1 ] } + { 0 [ 2 ] } + { 0 [ 3 ] } + [ 4 ] + } casep ] unit-test + +[ 1 1 ] [ 1 { + { 1 [ 1 ] } + { 0 [ 2 ] } + { 0 [ 3 ] } + [ 4 ] + } casep ] unit-test + +[ 1 4 ] [ 1 { + { 0 [ 1 ] } + { 0 [ 2 ] } + { 0 [ 3 ] } + [ 4 ] + } casep ] unit-test + +[ 2 ] [ 0.7 { + { 0.3 [ 1 ] } + { 0.5 [ 2 ] } + [ 2 ] } (casep) ] unit-test + +[ { { 1/3 [ 1 ] } + { 1/3 [ 2 ] } + { 1/3 [ 3 ] } } ] +[ { [ 1 ] [ 2 ] [ 3 ] } call-random>casep ] unit-test + +[ { { 1/2 [ 1 ] } + { 1/4 [ 2 ] } + { 1/4 [ 3 ] } } ] +[ { { 1/2 [ 1 ] } + { 1/2 [ 2 ] } + { 1 [ 3 ] } } direct>conditional ] unit-test + +[ { { 1/2 [ 1 ] } + { 1/4 [ 2 ] } + { [ 3 ] } } ] +[ { { 1/2 [ 1 ] } + { 1/2 [ 2 ] } + { [ 3 ] } } direct>conditional ] unit-test + +[ f ] [ { { 0.6 [ 1 ] } + { 0.6 [ 2 ] } } good-probabilities? ] unit-test +[ f ] [ { { 0.3 [ 1 ] } + { 0.6 [ 2 ] } } good-probabilities? ] unit-test +[ f ] [ { { -0.6 [ 1 ] } + { 1.4 [ 2 ] } } good-probabilities? ] unit-test +[ f ] [ { { -0.6 [ 1 ] } + [ 2 ] } good-probabilities? ] unit-test +[ t ] [ { { 0.6 [ 1 ] } + [ 2 ] } good-probabilities? ] unit-test +[ t ] [ { { 0.6 [ 1 ] } + { 0.4 [ 2 ] } } good-probabilities? ] unit-test diff --git a/basis/combinators/random/random.factor b/basis/combinators/random/random.factor new file mode 100644 index 0000000000..5a66b878cf --- /dev/null +++ b/basis/combinators/random/random.factor @@ -0,0 +1,72 @@ +! 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 -- ) [ random-unit > ] 2dip if ; inline + +: whenp ( p true -- ) [ ] ifp ; inline + +: unlessp ( p false -- ) [ [ ] ] dip ifp ; inline + +quot) ( assoc -- quot ) + dup good-probabilities? [ + [ dup pair? [ prepare-pair ] [ with-drop ] if ] map + cond>quot + ] [ bad-probabilities ] if ; + +MACRO: (casep) ( assoc -- ) (casep>quot) ; + +: casep>quot ( assoc -- quot ) + (casep>quot) [ random-unit ] 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 ; diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index 284e2a60d4..f775c2f24c 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -1,5 +1,5 @@ -USING: kernel combinators quotations arrays sequences assocs -generalizations macros fry math ; +USING: arrays combinators fry generalizations kernel macros +math sequences ; IN: combinators.short-circuit array { $values - { "quot" quotation } - { "newquot" quotation } + { "quot" quotation } + { "array" array } } -{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." } +{ $description "Infers the number of outputs from the quotation and constructs an array from those outputs." } { $examples { $example "USING: combinators combinators.smart math prettyprint ; @@ -36,8 +36,8 @@ HELP: output>array HELP: output>sequence { $values - { "quot" quotation } { "exemplar" "an exemplar" } - { "newquot" quotation } + { "quot" quotation } { "exemplar" "an exemplar" } + { "seq" sequence } } { $description "Infers the number of outputs from the quotation and constructs a new sequence from those objects of the same type as the exemplar." } { $examples @@ -50,8 +50,7 @@ HELP: output>sequence HELP: reduce-outputs { $values - { "quot" quotation } { "operation" quotation } - { "newquot" quotation } + { "quot" quotation } { "operation" quotation } } { $description "Infers the number of outputs from " { $snippet "quot" } " and reduces them using " { $snippet "operation" } ". The identity for the " { $link reduce } " operation is the first output." } { $examples @@ -64,8 +63,8 @@ HELP: reduce-outputs HELP: sum-outputs { $values - { "quot" quotation } - { "n" integer } + { "quot" quotation } + { "n" integer } } { $description "Infers the number of outputs from " { $snippet "quot" } " and returns their sum." } { $examples @@ -78,8 +77,8 @@ HELP: sum-outputs HELP: append-outputs { $values - { "quot" quotation } - { "seq" sequence } + { "quot" quotation } + { "seq" sequence } } { $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of the outputs appended." } { $examples @@ -92,8 +91,8 @@ HELP: append-outputs HELP: append-outputs-as { $values - { "quot" quotation } { "exemplar" sequence } - { "seq" sequence } + { "quot" quotation } { "exemplar" sequence } + { "seq" sequence } } { $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of type " { $snippet "exemplar" } " of the outputs appended." } { $examples @@ -119,7 +118,7 @@ HELP: keep-inputs HELP: dropping { $values { "quot" quotation } - { "quot" quotation } + { "quot'" quotation } } { $description "Outputs a quotation that, when called, will have the effect of dropping the number of inputs to the original quotation." } { $examples @@ -132,7 +131,7 @@ HELP: dropping HELP: inputarray ] infer ] unit-test + +:: map-reduce-test ( a b c -- d ) [ a b c ] [ a - ] [ b * + ] map-reduce-outputs ; + +[ 10 ] [ 1 2 3 map-reduce-test ] unit-test + +[ ( x x -- x ) ] [ [ curry inputs ] infer ] unit-test + +[ ( x -- x ) ] [ [ [ curry ] curry inputs ] infer ] unit-test + +{ 1 1 1 } [ 1 3 [ ] smart-with times ] unit-test +{ "BCD" } [ 1 "ABC" [ + ] smart-with map ] unit-test +{ H{ { 1 2 } } } [ 1 H{ { 1 2 } { 3 4 } } [ drop = ] smart-with assoc-filter ] unit-test diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index a350d0a72b..e808f3e32e 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -1,73 +1,124 @@ -! Copyright (C) 2009 Doug Coleman. +! Copyright (C) 2009, 2011 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors fry generalizations sequences.generalizations -kernel macros math.order stack-checker math sequences ; +USING: accessors arrays effects fry generalizations kernel +macros math math.order sequences sequences.generalizations +stack-checker stack-checker.backend stack-checker.errors +stack-checker.values stack-checker.visitor words memoize ; IN: combinators.smart -MACRO: drop-outputs ( quot -- quot' ) - dup outputs '[ @ _ ndrop ] ; +GENERIC: infer-known* ( known -- effect ) -MACRO: keep-inputs ( quot -- quot' ) - dup inputs '[ _ _ nkeep ] ; +: infer-known ( value -- effect ) + known dup (literal-value?) [ + (literal) [ infer-literal-quot ] with-infer drop + ] [ infer-known* ] if ; -MACRO: output>sequence ( quot exemplar -- newquot ) - [ dup outputs ] dip - '[ @ _ _ nsequence ] ; +IDENTITY-MEMO: inputs/outputs ( quot -- in out ) + infer [ in>> ] [ out>> ] bi [ length ] bi@ ; -MACRO: output>array ( quot -- newquot ) - '[ _ { } output>sequence ] ; +: inputs ( quot -- n ) inputs/outputs drop ; inline -MACRO: input> ] [ out>> ] bi [ length apply-object ] bi@ ] bi* + ] [ + \ inputs/outputs dup required-stack-effect apply-word/effect + pop-d pop-d swap + [ [ input-parameter swap set-known ] [ push-d ] bi ] bi@ + ] if* +] "special" set-word-prop -MACRO: reduce-outputs ( quot operation -- newquot ) - [ dup outputs 1 [-] ] dip n*quot compose ; +M: curried infer-known* + quot>> infer-known dup [ + curry-effect + ] [ + drop f + ] if ; -MACRO: sum-outputs ( quot -- n ) - '[ _ [ + ] reduce-outputs ] ; +M: composed infer-known* + [ quot1>> ] [ quot2>> ] bi + [ infer-known ] bi@ + 2dup and [ compose-effects ] [ 2drop f ] if ; -MACRO: map-reduce-outputs ( quot mapper reducer -- newquot ) - [ dup outputs ] 2dip - [ swap '[ _ _ napply ] ] - [ [ 1 [-] ] dip n*quot ] bi-curry* bi - '[ @ @ @ ] ; +M: declared-effect infer-known* + known>> infer-known* ; -MACRO: append-outputs-as ( quot exemplar -- newquot ) - [ dup outputs ] dip '[ @ _ _ nappend-as ] ; +M: input-parameter infer-known* drop f ; -MACRO: append-outputs ( quot -- seq ) - '[ _ { } append-outputs-as ] ; +M: object infer-known* drop f ; -MACRO: preserving ( quot -- ) - [ inputs ] keep '[ _ ndup @ ] ; +: drop-inputs ( quot -- ) + inputs ndrop ; inline -MACRO: dropping ( quot -- quot' ) - inputs '[ [ _ ndrop ] ] ; +: drop-outputs ( quot -- ) + [ call ] [ outputs ndrop ] bi ; inline -MACRO: nullary ( quot -- quot' ) dropping ; +: keep-inputs ( quot -- ) + [ ] [ inputs ] bi nkeep ; inline -MACRO: smart-if ( pred true false -- quot ) - '[ _ preserving _ _ if ] ; +: output>sequence ( quot exemplar -- seq ) + [ [ call ] [ outputs ] bi ] dip nsequence ; inline -MACRO: smart-when ( pred true -- quot ) - '[ _ _ [ ] smart-if ] ; +: output>array ( quot -- array ) + { } output>sequence ; inline -MACRO: smart-unless ( pred false -- quot ) - '[ _ [ ] _ smart-if ] ; +: input 1 enables polymorphic inline caching" } - { { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" } } "If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the Factor executable." ; @@ -78,9 +78,9 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap" "By default, all optional components are loaded. To load all optional components except for a given list, use the " { $snippet "-exclude=" } " switch; to only load specified optional components, use the " { $snippet "-include=" } "." $nl "For example, to build an image with the compiler but no other components, you could do:" -{ $code "./factor -i=boot.macosx-ppc.image -include=compiler" } +{ $code "./factor -i=boot.unix-x86.64.image -include=compiler" } "To build an image with everything except for the user interface and graphical tools," -{ $code "./factor -i=boot.macosx-ppc.image -exclude=\"ui ui.tools\"" } +{ $code "./factor -i=boot.unix-x86.64.image -exclude=\"ui ui.tools\"" } "To generate a bootstrap image in the first place, see " { $link "bootstrap.image" } "." ; ARTICLE: "standard-cli-args" "Command line switches for general usage" @@ -89,24 +89,23 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage" { { $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.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." } } } ; -ARTICLE: "factor-boot-rc" "Bootstrap initialization file" -"The bootstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts." +ARTICLE: ".factor-boot-rc" "Bootstrap initialization file" +"The bootstrap initialization file is named " { $snippet ".factor-boot-rc" } ". This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts." $nl "A word to run this file from an existing Factor session:" { $subsections run-bootstrap-init } "For example, if you changed " { $snippet ".factor-boot-rc" } " and do not want to bootstrap again, you can just invoke " { $link run-bootstrap-init } " in the listener." ; -ARTICLE: "factor-rc" "Startup initialization file" -"The startup initialization file is named " { $snippet "factor-rc" } " on Windows and " { $snippet ".factor-rc" } " on Unix. If it exists, it is run every time Factor starts." +ARTICLE: ".factor-rc" "Startup initialization file" +"The startup initialization file is named " { $snippet ".factor-rc" } ". If it exists, it is run every time Factor starts." $nl "A word to run this file from an existing Factor session:" { $subsections run-user-init } ; -ARTICLE: "factor-roots" "Additional vocabulary roots file" -"The vocabulary roots file is named " { $snippet "factor-roots" } " on Windows and " { $snippet ".factor-roots" } " on Unix. If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "." +ARTICLE: ".factor-roots" "Additional vocabulary roots file" +"The vocabulary roots file is named " { $snippet ".factor-roots" } ". If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "." $nl "A word to run this file from an existing Factor session:" { $subsections load-vocab-roots } ; @@ -114,17 +113,17 @@ $nl ARTICLE: "rc-files" "Running code on startup" "Factor looks for three optional files in your home directory." { $subsections - "factor-boot-rc" - "factor-rc" - "factor-roots" + ".factor-boot-rc" + ".factor-rc" + ".factor-roots" } "The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files." $nl "If you are unsure where the files should be located, evaluate the following code:" { $code "USE: command-line" - "\"factor-rc\" rc-path print" - "\"factor-boot-rc\" rc-path print" + "\".factor-rc\" rc-path print" + "\".factor-boot-rc\" rc-path print" } "Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration:" { $code @@ -132,10 +131,10 @@ $nl "\"/opt/local/bin\" \\ gvim-path set-global" } ; -ARTICLE: "cli" "Command line arguments" +ARTICLE: "command-line" "Command line arguments" "Factor command line usage:" { $code "factor [VM args...] [script] [args...]" } -"Zero or more VM arguments can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in the following variable, with no further processing by Factor itself:" +"Zero or more VM arguments can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup using " { $link run-script } ". Any arguments after the script file are stored in the following variable, with no further processing by Factor itself:" { $subsections command-line } "Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:" { $code "factor [system switches...] -run=" } @@ -159,4 +158,9 @@ $nl "There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:" { $subsections main-vocab-hook } ; -ABOUT: "cli" +HELP: run-script +{ $values { "file" "a pathname string" } } +{ $description "Parses the Factor source code stored in a file and runs it. The initial vocabulary search path is used. If the source file contains a " { $link POSTPONE: MAIN: } " declaration, the main entry point of the file will be also be executed. Loading messages will be suppressed." } +{ $errors "Throws an error if loading the file fails, there input is malformed, or if a runtime error occurs while calling the parsed quotation or executing the main entry point." } ; + +ABOUT: "command-line" diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index f30182b936..8f38208c89 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -1,33 +1,50 @@ ! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: init continuations hashtables io io.encodings.utf8 -io.files io.pathnames kernel kernel.private namespaces parser -sequences strings system splitting vocabs.loader alien.strings ; +USING: accessors alien.strings assocs continuations fry init +io.encodings.utf8 io.files io.pathnames kernel kernel.private +namespaces parser parser.notes sequences source-files +source-files.errors splitting system vocabs.loader ; IN: command-line +SYMBOL: user-init-errors +SYMBOL: +user-init-error+ + +TUPLE: user-init-error error file line# asset ; + +: ( error -- error' ) + [ ] [ error-file ] [ error-line ] tri + f user-init-error boa ; inline +M: user-init-error error-file file>> ; +M: user-init-error error-line line#>> ; +M: user-init-error error-type drop +user-init-error+ ; + SYMBOL: script SYMBOL: command-line : (command-line) ( -- args ) - 10 special-object sift [ alien>native-string ] map ; + OBJ-ARGS special-object sift [ alien>native-string ] map ; : rc-path ( name -- path ) - os windows? [ "." prepend ] unless home prepend-path ; -: run-bootstrap-init ( -- ) - "user-init" get [ - "factor-boot-rc" rc-path ?run-file +: try-user-init ( file -- ) + "user-init" get swap '[ + _ [ ?run-file ] [ + + swap user-init-errors get set-at + notify-error-observers + ] recover ] when ; +: run-bootstrap-init ( -- ) + ".factor-boot-rc" rc-path try-user-init ; + : run-user-init ( -- ) - "user-init" get [ - "factor-rc" rc-path ?run-file - ] when ; + ".factor-rc" rc-path try-user-init ; : load-vocab-roots ( -- ) "user-init" get [ - "factor-roots" rc-path dup exists? [ + ".factor-roots" rc-path dup exists? [ utf8 file-lines harvest [ add-vocab-root ] each ] [ drop ] if ] when ; @@ -40,14 +57,23 @@ SYMBOL: command-line "=" split1 [ var-param ] [ bool-param ] if* ; : run-script ( file -- ) - t "quiet" set-global run-file ; + t parser-quiet? [ + [ run-file ] + [ source-file main>> [ execute( -- ) ] when* ] bi + ] with-variable ; + +: (parse-command-line) ( run? args -- ) + [ command-line off script off drop ] [ + unclip "-" ?head + [ param (parse-command-line) ] + [ + rot [ prefix f ] when + script set command-line set + ] if + ] if-empty ; : parse-command-line ( args -- ) - [ command-line off script off ] [ - unclip "-" ?head - [ param parse-command-line ] - [ script set command-line set ] if - ] if-empty ; + [ [ "-run=" head? ] any? ] keep (parse-command-line) ; SYMBOL: main-vocab-hook @@ -59,12 +85,15 @@ SYMBOL: main-vocab-hook ] if ; : default-cli-args ( -- ) - global [ - "quiet" off + [ "e" off "user-init" on - embedded? "quiet" set main-vocab "run" set - ] bind ; + ] with-global ; -[ default-cli-args ] "command-line" add-startup-hook +[ + H{ } user-init-errors set-global + default-cli-args +] "command-line" add-startup-hook + +{ "debugger" "command-line" } "command-line.debugger" require-when diff --git a/basis/command-line/debugger/debugger.factor b/basis/command-line/debugger/debugger.factor new file mode 100644 index 0000000000..5b25d83e03 --- /dev/null +++ b/basis/command-line/debugger/debugger.factor @@ -0,0 +1,6 @@ +USING: accessors debugger io kernel make math.parser +prettyprint command-line summary ; +IN: command-line.debugger + +M: user-init-error error. + error>> error. ; diff --git a/basis/compiler/codegen/fixup/authors.txt b/basis/command-line/startup/authors.txt similarity index 100% rename from basis/compiler/codegen/fixup/authors.txt rename to basis/command-line/startup/authors.txt diff --git a/basis/command-line/startup/startup.factor b/basis/command-line/startup/startup.factor new file mode 100644 index 0000000000..a3e2750f1b --- /dev/null +++ b/basis/command-line/startup/startup.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2011 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: command-line eval io io.pathnames kernel namespaces +system vocabs.loader ; +IN: command-line.startup + +: cli-usage ( -- ) +""" +Usage: """ write vm file-name write """ [Factor arguments] [script] [script arguments] + +Common arguments: + -help print this message and exit + -i= load Factor image file (default """ write vm file-stem write """.image) + -run= run the MAIN: entry point of + -run=listener run terminal listener + -run=ui.tools run Factor development UI + -e= evaluate + -no-user-init suppress loading of .factor-rc + +Enter + "command-line" help +from within Factor for more information. + +""" write ; + +: help? ( -- ? ) + "help" get "-help" get or "h" get or + os windows? [ script get "/?" = ] [ f ] if or ; + +: command-line-startup ( -- ) + (command-line) parse-command-line + help? [ cli-usage ] [ + load-vocab-roots + run-user-init + "e" get script get or [ + "e" get [ eval( -- ) ] when* + script get [ run-script ] when* + ] [ + "run" get run + ] if + ] if + + output-stream get [ stream-flush ] when* + 0 exit ; + diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 6fff3f0216..2cfeb51014 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -6,7 +6,6 @@ sets classes layouts fry locals cpu.architecture compiler.cfg compiler.cfg.rpo compiler.cfg.def-use -compiler.cfg.liveness compiler.cfg.registers compiler.cfg.utilities compiler.cfg.comparisons @@ -15,7 +14,8 @@ compiler.cfg.representations.preferred ; FROM: namespaces => set ; IN: compiler.cfg.alias-analysis -! We try to eliminate redundant slot operations using some simple heuristics. +! We try to eliminate redundant slot operations using some +! simple heuristics. ! ! All heap-allocated objects which are loaded from the stack, or ! other object slots are pessimistically assumed to belong to @@ -79,19 +79,23 @@ SYMBOL: copies ! Map vregs -> alias classes SYMBOL: vregs>acs -ERROR: vreg-ac-not-set vreg ; +! Map alias classes -> sequence of vregs +SYMBOL: acs>vregs + +! Alias class for objects which are loaded from the data stack +! or other object slots. We pessimistically assume that they +! can all alias each other. +SYMBOL: heap-ac + +: ac>vregs ( ac -- vregs ) + acs>vregs get [ drop V{ } clone ] cache ; : vreg>ac ( vreg -- ac ) #! Only vregs produced by ##allot, ##peek and ##slot can #! ever be used as valid inputs to ##slot and ##set-slot, #! so we assert this fact by not giving alias classes to #! other vregs. - vregs>acs get ?at [ vreg-ac-not-set ] unless ; - -! Map alias classes -> sequence of vregs -SYMBOL: acs>vregs - -: ac>vregs ( ac -- vregs ) acs>vregs get at ; + vregs>acs get [ heap-ac get [ ac>vregs push ] keep ] cache ; : aliases ( vreg -- vregs ) #! All vregs which may contain the same value as vreg. @@ -105,7 +109,7 @@ SYMBOL: acs>vregs 2dup eq? [ 2drop ] [ [ ac>vregs ] dip [ vregs>acs get '[ [ _ ] dip _ set-at ] each ] - [ acs>vregs get at push-all ] + [ ac>vregs push-all ] 2bi ] if ; @@ -120,22 +124,21 @@ SYMBOL: dead-stores : dead-store ( insn# -- ) dead-stores get adjoin ; +ERROR: vreg-not-new vreg ; + :: set-ac ( vreg ac -- ) #! Set alias class of newly-seen vreg. - H{ } clone vreg recent-stores get set-at - H{ } clone vreg live-slots get set-at + vreg vregs>acs get key? [ vreg vreg-not-new ] when ac vreg vregs>acs get set-at - vreg ac acs>vregs get push-at ; + vreg ac ac>vregs push ; : live-slot ( slot#/f vreg -- vreg' ) #! If the slot number is unknown, we never reuse a previous #! value. over [ live-slots get at at ] [ 2drop f ] if ; -ERROR: vreg-has-no-slots vreg ; - : load-constant-slot ( value slot# vreg -- ) - live-slots get ?at [ vreg-has-no-slots ] unless set-at ; + live-slots get [ drop H{ } clone ] cache set-at ; : load-slot ( value slot#/f vreg -- ) over [ load-constant-slot ] [ 3drop ] if ; @@ -160,20 +163,16 @@ SYMBOL: ac-counter : next-ac ( -- n ) ac-counter [ dup 1 + ] change ; -! Alias class for objects which are loaded from the data stack -! or other object slots. We pessimistically assume that they -! can all alias each other. -SYMBOL: heap-ac - -: set-heap-ac ( vreg -- ) heap-ac get set-ac ; - : set-new-ac ( vreg -- ) next-ac set-ac ; : kill-constant-set-slot ( slot# vreg -- ) [ live-slots get at delete-at ] with each-alias ; +: recent-stores-of ( vreg -- assoc ) + recent-stores get [ drop H{ } clone ] cache ; + :: record-constant-set-slot ( insn# slot# vreg -- ) - vreg recent-stores get at :> recent-stores + vreg recent-stores-of :> recent-stores slot# recent-stores at [ dead-store ] when* insn# slot# recent-stores set-at ; @@ -210,9 +209,9 @@ M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; -M: ##alien-global insn-object drop \ ##alien-global ; -M: ##vm-field insn-object drop \ ##vm-field ; -M: ##set-vm-field insn-object drop \ ##vm-field ; +M: ##alien-global insn-object drop ##alien-global ; +M: ##vm-field insn-object drop ##vm-field ; +M: ##set-vm-field insn-object drop ##vm-field ; GENERIC: analyze-aliases ( insn -- insn' ) @@ -226,15 +225,12 @@ M: insn analyze-aliases ; ! inserted yet. dup [ { int-rep tagged-rep } member? - [ set-heap-ac ] [ set-new-ac ] if + [ drop ] [ set-new-ac ] if ] each-def-rep ; M: vreg-insn analyze-aliases def-acs ; -M: ##phi analyze-aliases - dup dst>> set-heap-ac ; - M: ##allocation analyze-aliases #! A freshly allocated object is distinct from any other #! object. @@ -279,13 +275,13 @@ M: ##copy analyze-aliases : useless-compare? ( insn -- ? ) { [ cc>> cc= eq? ] - [ [ src1>> ] [ src2>> ] bi [ resolve vreg>ac ] bi@ = not ] + [ [ src1>> ] [ src2>> ] bi [ resolve vreg>ac ] same? not ] } 1&& ; inline M: ##compare analyze-aliases call-next-method dup useless-compare? [ - dst>> f \ ##load-reference new-insn + dst>> f ##load-reference new-insn analyze-aliases ] when ; @@ -321,14 +317,13 @@ M: insn eliminate-dead-stores drop t ; dead-stores get table>> clear-assoc next-ac heap-ac set - \ ##vm-field set-new-ac - \ ##alien-global set-new-ac ; + ##vm-field set-new-ac + ##alien-global set-new-ac ; : alias-analysis-step ( insns -- insns' ) reset-alias-analysis - [ local-live-in [ set-heap-ac ] each ] [ 0 [ [ insn#<< ] [ drop 1 + ] 2bi ] reduce drop ] - [ [ analyze-aliases ] map! [ eliminate-dead-stores ] filter! ] tri ; + [ [ analyze-aliases ] map! [ eliminate-dead-stores ] filter! ] bi ; : alias-analysis ( cfg -- cfg ) init-alias-analysis diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 985d296cc6..eab1453b3d 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -1,19 +1,20 @@ -! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov. +! Copyright (C) 2009, 2011 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators combinators.short-circuit kernel -locals math math.order sequences assocs namespaces vectors fry -arrays splitting compiler.cfg.def-use compiler.cfg +USING: arrays accessors assocs combinators combinators.short-circuit +dlists deques kernel locals math math.order sequences +sets vectors fry splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.predecessors compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ; +FROM: namespaces => get set ; IN: compiler.cfg.branch-splitting : clone-instructions ( insns -- insns' ) [ clone dup rename-insn-temps ] map ; : clone-basic-block ( bb -- bb' ) - ! The new block temporarily gets the same RPO number as the old one, - ! until the next time RPO is computed. This is just to make - ! 'back-edge?' work. + ! The new block temporarily gets the same RPO number as the + ! old one, until the next time RPO is computed. This is just + ! to make 'back-edge?' work. swap { @@ -25,18 +26,21 @@ IN: compiler.cfg.branch-splitting : new-blocks ( bb -- copies ) dup predecessors>> [ - [ clone-basic-block ] dip - 1vector >>predecessors + [ clone-basic-block ] [ 1vector ] bi* + >>predecessors ] with map ; : update-predecessor-successors ( copies old-bb -- ) [ predecessors>> swap ] keep - '[ [ _ ] 2dip update-predecessors ] 2each ; + '[ [ _ ] dip update-successors ] 2each ; :: update-successor-predecessor ( copies old-bb succ -- ) - succ - [ { old-bb } split copies join V{ } like ] change-predecessors - drop ; + succ predecessors>> dup >array :> ( preds preds' ) + preds delete-all + preds' [ + dup old-bb eq? + [ drop copies preds push-all ] [ preds push ] if + ] each ; : update-successor-predecessors ( copies old-bb -- ) dup successors>> @@ -77,11 +81,29 @@ UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ; ] if ] if ; +SYMBOL: worklist +SYMBOL: visited + +: add-to-worklist ( bb -- ) + dup visited get in? [ drop ] [ + [ visited get adjoin ] + [ worklist get push-front ] bi + ] if ; + +: init-worklist ( cfg -- ) + worklist set + HS{ } clone visited set + entry>> add-to-worklist ; + : split-branches ( cfg -- cfg' ) needs-predecessors - - dup [ - dup split-branch? [ split-branch ] [ drop ] if - ] each-basic-block + dup init-worklist + ! For back-edge? + dup post-order drop + + worklist get [ + dup split-branch? [ dup split-branch ] when + successors>> [ add-to-worklist ] each + ] slurp-deque cfg-changed ; diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index d5502ab3ba..3d2d3cc0ca 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -10,7 +10,7 @@ compiler.cfg.builder compiler.cfg.builder.alien.params compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks compiler.cfg.instructions compiler.cfg.stack-frame compiler.cfg.stacks compiler.cfg.stacks.local -compiler.cfg.registers compiler.cfg.hats ; +compiler.cfg.registers compiler.cfg.hats compiler.errors ; FROM: compiler.errors => no-such-symbol no-such-library ; IN: compiler.cfg.builder.alien @@ -39,12 +39,12 @@ IN: compiler.cfg.builder.alien dup large-struct? [ heap-size cell f ^^local-allot [ '[ _ prefix ] - [ int-rep struct-return-on-stack? 2array prefix ] bi* + [ int-rep struct-return-on-stack? f 3array prefix ] bi* ] keep ] [ drop f ] if ; : (caller-parameters) ( vregs reps -- ) - [ first2 next-parameter ] 2each ; + [ first3 next-parameter ] 2each ; : caller-parameters ( params -- reg-inputs stack-inputs ) [ abi>> ] [ parameters>> ] [ return>> ] tri @@ -67,11 +67,17 @@ M: string dlsym-valid? dlsym ; M: array dlsym-valid? '[ _ dlsym ] any? ; -: check-dlsym ( symbols dll -- ) - dup dll-valid? [ - dupd dlsym-valid? - [ drop ] [ cfg get word>> no-such-symbol ] if - ] [ dll-path cfg get word>> no-such-library drop ] if ; +: check-dlsym ( symbols library -- ) + { + { [ dup library-dll dll-valid? not ] [ + [ library-dll dll-path ] [ dlerror>> ] bi + cfg get word>> no-such-library-error drop + ] } + { [ 2dup library-dll dlsym-valid? not ] [ + drop dlerror cfg get word>> no-such-symbol-error + ] } + [ 2drop ] + } cond ; : decorated-symbol ( params -- symbols ) [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi @@ -85,8 +91,8 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; : caller-linkage ( params -- symbols dll ) [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ] - [ library>> load-library ] - bi 2dup check-dlsym ; + [ library>> library ] + bi 2dup check-dlsym library-dll ; : caller-return ( params -- ) return>> [ ] [ @@ -106,7 +112,7 @@ M: #alien-invoke emit-node [ caller-stack-frame ] [ caller-linkage ] } cleave - ##alien-invoke + ##alien-invoke, ] [ caller-return ] bi ; @@ -118,7 +124,7 @@ M: #alien-indirect emit-node ( node -- ) [ caller-parameters ] [ prepare-caller-return ] [ caller-stack-frame ] tri - ##alien-indirect + ##alien-indirect, ] [ caller-return ] bi ; @@ -131,21 +137,21 @@ M: #alien-assembly emit-node [ prepare-caller-return ] [ caller-stack-frame ] [ quot>> ] - } cleave ##alien-assembly + } cleave ##alien-assembly, ] [ caller-return ] bi ; -: callee-parameter ( rep on-stack? -- dst ) - [ next-vreg dup ] 2dip next-parameter ; +: callee-parameter ( rep on-stack? odd-register? -- dst ) + [ next-vreg dup ] 3dip next-parameter ; : prepare-struct-callee ( c-type -- vreg ) large-struct? - [ int-rep struct-return-on-stack? callee-parameter ] [ f ] if ; + [ int-rep struct-return-on-stack? f callee-parameter ] [ f ] if ; : (callee-parameters) ( params -- vregs reps ) [ flatten-parameter-type ] map - [ [ [ first2 callee-parameter ] map ] map ] + [ [ [ first3 callee-parameter ] map ] map ] [ [ keys ] map ] bi ; @@ -176,6 +182,9 @@ M: #alien-assembly emit-node : emit-callback-body ( nodes -- ) [ last #return? t assert= ] [ but-last emit-nodes ] bi ; +: emit-callback-return ( params -- ) + basic-block get [ callee-return ##callback-outputs, ] [ drop ] if ; + M: #alien-callback emit-node dup params>> xt>> dup [ @@ -184,12 +193,12 @@ M: #alien-callback emit-node begin-word { - [ params>> callee-parameters ##callback-inputs ] + [ params>> callee-parameters ##callback-inputs, ] [ params>> box-parameters ] [ child>> emit-callback-body ] - [ params>> callee-return ##callback-outputs ] + [ params>> emit-callback-return ] [ params>> callback-stack-cleanup ] } cleave - end-word + basic-block get [ end-word ] when ] with-cfg-builder ; diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor index 180b22e477..472d12f833 100644 --- a/basis/compiler/cfg/builder/alien/boxing/boxing.factor +++ b/basis/compiler/cfg/builder/alien/boxing/boxing.factor @@ -15,19 +15,23 @@ SYMBOL: struct-return-area GENERIC: flatten-c-type ( c-type -- pairs ) M: c-type flatten-c-type - rep>> f 2array 1array ; + rep>> f f 3array 1array ; M: long-long-type flatten-c-type - drop 2 [ int-rep long-long-on-stack? 2array ] replicate ; + drop 2 [ int-rep long-long-on-stack? f 3array ] replicate ; HOOK: flatten-struct-type cpu ( type -- pairs ) +HOOK: flatten-struct-type-return cpu ( type -- pairs ) M: object flatten-struct-type - heap-size cell align cell /i { int-rep f } ; + heap-size cell align cell /i { int-rep f f } ; M: struct-c-type flatten-c-type flatten-struct-type ; +M: object flatten-struct-type-return + flatten-struct-type ; + : stack-size ( c-type -- n ) base-type flatten-c-type keys 0 [ rep-size + ] reduce ; @@ -40,9 +44,15 @@ M: struct-c-type flatten-c-type [| rep offset | src offset rep f ^^load-memory-imm ] 2map reps ; +:: explode-struct-return ( src c-type -- vregs reps ) + c-type flatten-struct-type-return :> reps + reps keys dup component-offsets + [| rep offset | src offset rep f ^^load-memory-imm ] 2map + reps ; + :: implode-struct ( src vregs reps -- ) vregs reps dup component-offsets - [| vreg rep offset | vreg src offset rep f ##store-memory-imm ] 3each ; + [| vreg rep offset | vreg src offset rep f ##store-memory-imm, ] 3each ; GENERIC: unbox ( src c-type -- vregs reps ) @@ -62,11 +72,12 @@ M: c-type unbox [ swap ^^unbox ] } case 1array ] - [ drop f 2array 1array ] 2bi ; + [ drop f f 3array 1array ] 2bi ; M: long-long-type unbox - [ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long 2array - int-rep long-long-on-stack? 2array dup 2array ; + [ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long, 2array + int-rep long-long-on-stack? long-long-odd-register? 3array + int-rep long-long-on-stack? f 3array 2array ; M: struct-c-type unbox ( src c-type -- vregs reps ) [ ^^unbox-any-c-ptr ] dip explode-struct ; @@ -85,7 +96,7 @@ M: struct-c-type unbox-parameter [ nip heap-size cell f ^^local-allot dup ] [ [ ^^unbox-any-c-ptr ] dip explode-struct keys ] 2bi implode-struct - 1array { { int-rep f } } + 1array { { int-rep f f } } ] if ; : store-return ( vregs reps -- triples ) @@ -165,6 +176,6 @@ M: struct-c-type box-return [ [ [ [ { } assert-sequence= ] bi@ struct-return-area get ] dip - explode-struct keys + explode-struct-return keys ] keep box ] if ; diff --git a/basis/compiler/cfg/builder/alien/params/params.factor b/basis/compiler/cfg/builder/alien/params/params.factor index 651e5890a4..ff7d11b4e3 100644 --- a/basis/compiler/cfg/builder/alien/params/params.factor +++ b/basis/compiler/cfg/builder/alien/params/params.factor @@ -1,15 +1,22 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: cpu.architecture fry kernel layouts math math.order -namespaces sequences vectors assocs arrays ; +namespaces sequences vectors assocs arrays locals ; IN: compiler.cfg.builder.alien.params SYMBOL: stack-params -: alloc-stack-param ( rep -- n ) +GENERIC: alloc-stack-param ( reg -- n ) + +M: object alloc-stack-param ( rep -- n ) stack-params get [ rep-size cell align stack-params +@ ] dip ; +M: float-rep alloc-stack-param ( rep -- n ) + stack-params get swap rep-size + [ cell align stack-params +@ ] keep + float-right-align-on-stack? [ + ] [ drop ] if ; + : ?dummy-stack-params ( rep -- ) dummy-stack-params? [ alloc-stack-param drop ] [ drop ] if ; @@ -22,21 +29,29 @@ SYMBOL: stack-params : ?dummy-fp-params ( rep -- ) drop dummy-fp-params? [ float-regs get [ pop* ] unless-empty ] when ; -GENERIC: next-reg-param ( rep -- reg ) +GENERIC: next-reg-param ( odd-register? rep -- reg ) M: int-rep next-reg-param - [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi - int-regs get pop ; + [ nip ?dummy-stack-params ] + [ nip ?dummy-fp-params ] + [ drop [ + int-regs get last even? + [ int-regs get pop* ] when + ] when ] + 2tri int-regs get pop ; M: float-rep next-reg-param - [ ?dummy-stack-params ] [ ?dummy-int-params ] bi + nip [ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ; M: double-rep next-reg-param - [ ?dummy-stack-params ] [ ?dummy-int-params ] bi + nip [ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ; -: reg-class-full? ( reg-class -- ? ) get empty? ; +:: reg-class-full? ( reg-class odd-register? -- ? ) + reg-class get empty? + reg-class get length 1 = odd-register? and + dup [ reg-class get delete-all ] when or ; : init-reg-class ( abi reg-class -- ) [ swap param-regs at >vector ] keep set ; @@ -49,9 +64,10 @@ M: double-rep next-reg-param SYMBOLS: stack-values reg-values ; -: next-parameter ( vreg rep on-stack? -- ) - [ dup dup reg-class-of reg-class-full? ] dip or - [ alloc-stack-param stack-values ] [ next-reg-param reg-values ] if +:: next-parameter ( vreg rep on-stack? odd-register? -- ) + vreg rep on-stack? + [ dup dup reg-class-of odd-register? reg-class-full? ] dip or + [ alloc-stack-param stack-values ] [ odd-register? swap next-reg-param reg-values ] if [ 3array ] dip get push ; : next-return-reg ( rep -- reg ) reg-class-of get pop ; diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index a480b2799a..b9fdaf9066 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -27,9 +27,9 @@ IN: compiler.cfg.builder.blocks (begin-basic-block) ; : emit-trivial-block ( quot -- ) - ##branch begin-basic-block + ##branch, begin-basic-block call - ##branch begin-basic-block ; inline + ##branch, begin-basic-block ; inline : make-kill-block ( -- ) basic-block get t >>kill-block? drop ; @@ -39,7 +39,7 @@ IN: compiler.cfg.builder.blocks : emit-primitive ( node -- ) [ - [ word>> ##call ] + [ word>> ##call, ] [ call-height adjust-d ] bi make-kill-block ] emit-trivial-block ; @@ -49,7 +49,7 @@ IN: compiler.cfg.builder.blocks : end-branch ( -- pair/f ) ! pair is { final-bb final-height } basic-block get dup [ - ##branch + ##branch, end-local-analysis current-height get clone 2array ] when ; diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 5f2b75f0e0..73d1204c37 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -221,3 +221,12 @@ IN: compiler.cfg.builder.tests ! Regression. Make sure everything is inlined correctly [ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test + +! Regression. Make sure branch splitting works. +[ 2 ] [ [ 1 2 ? ] [ ##return? ] count-insns ] unit-test + +! Make sure fast union predicates don't have conditionals. +[ f ] [ + [ tag 1 swap fixnum-shift-fast ] + [ ##compare-integer-imm-branch? ] contains-insn? +] unit-test diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 60f6f0acbf..fce6cf2f84 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -57,8 +57,9 @@ GENERIC: emit-node ( node -- ) : begin-word ( -- ) make-kill-block - ##prologue - ##branch + ##safepoint, + ##prologue, + ##branch, begin-basic-block ; : (build-cfg) ( nodes word label -- ) @@ -75,7 +76,8 @@ GENERIC: emit-node ( node -- ) ] keep ; : emit-loop-call ( basic-block -- ) - ##branch + ##safepoint, + ##branch, basic-block get successors>> push end-basic-block ; @@ -84,7 +86,7 @@ GENERIC: emit-node ( node -- ) [ drop loops get at emit-loop-call ] [ [ - [ ##call ] [ adjust-d ] bi* + [ ##call, ] [ adjust-d ] bi* make-kill-block ] emit-trivial-block ] if ; @@ -101,7 +103,7 @@ GENERIC: emit-node ( node -- ) basic-block get swap loops get set-at ; : emit-loop ( node -- ) - ##branch + ##branch, begin-basic-block [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ; @@ -141,7 +143,7 @@ M: #recursive emit-node : emit-actual-if ( #if -- ) ! Inputs to the final instruction need to be copied because of ! loc>vreg sync - ds-pop any-rep ^^copy f cc/= ##compare-imm-branch emit-if ; + ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ; M: #if emit-node { @@ -155,7 +157,7 @@ M: #dispatch emit-node ! Inputs to the final instruction need to be copied because of ! loc>vreg sync. ^^offset>slot always returns a fresh vreg, ! though. - ds-pop ^^offset>slot next-vreg ##dispatch emit-if ; + ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ; ! #call M: #call emit-node @@ -178,9 +180,9 @@ M: #push emit-node : make-input-map ( #shuffle -- assoc ) ! Assoc maps high-level IR values to stack locations. [ - [ in-d>> [ swap set ] each-index ] - [ in-r>> [ swap set ] each-index ] bi - ] H{ } make-assoc ; + [ in-d>> [ swap ,, ] each-index ] + [ in-r>> [ swap ,, ] each-index ] bi + ] H{ } make ; : make-output-seq ( values mapping input-map -- vregs ) '[ _ at _ at peek-loc ] map ; @@ -199,11 +201,12 @@ M: #shuffle emit-node ! #return : end-word ( -- ) - ##branch + ##branch, begin-basic-block make-kill-block - ##epilogue - ##return ; + ##safepoint, + ##epilogue, + ##return, ; M: #return emit-node drop end-word ; @@ -211,7 +214,7 @@ M: #return-recursive emit-node label>> id>> loops get key? [ end-word ] unless ; ! #terminate -M: #terminate emit-node drop ##no-tco end-basic-block ; +M: #terminate emit-node drop ##no-tco, end-basic-block ; ! No-op nodes M: #introduce emit-node drop ; diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index 553b843833..b5e9535d97 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -133,7 +133,7 @@ INSTANCE: name-analysis backward-analysis PRIVATE> SYNTAX: FORWARD-ANALYSIS: - scan [ define-analysis ] [ define-forward-analysis ] bi ; + scan-token [ define-analysis ] [ define-forward-analysis ] bi ; SYNTAX: BACKWARD-ANALYSIS: - scan [ define-analysis ] [ define-backward-analysis ] bi ; + scan-token [ define-analysis ] [ define-backward-analysis ] bi ; diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index db41b0c18d..1a5d264891 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -3,6 +3,7 @@ USING: accessors arrays assocs kernel namespaces sequences compiler.cfg.instructions compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.predecessors hash-sets sets ; +FROM: assocs => change-at ; FROM: namespaces => set ; IN: compiler.cfg.dce diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 28036241a5..58d782aad3 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008, 2010 Slava Pestov. +! Copyright (C) 2008, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words sequences quotations namespaces io vectors arrays hashtables classes.tuple math accessors prettyprint prettyprint.config assocs prettyprint.backend prettyprint.custom -prettyprint.sections parser compiler.tree.builder +prettyprint.sections parser random compiler.tree.builder compiler.tree.optimizer cpu.architecture compiler.cfg.builder compiler.cfg.linearization compiler.cfg.registers compiler.cfg.stack-frame compiler.cfg.linear-scan @@ -12,7 +12,8 @@ compiler.cfg.instructions compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.representations compiler.cfg.gc-checks compiler.cfg.save-contexts compiler.cfg -compiler.cfg.representations.preferred ; +compiler.cfg.representations.preferred +compiler.cfg.scheduling compiler.units ; FROM: compiler.cfg.linearization => number-blocks ; IN: compiler.cfg.debugger @@ -26,9 +27,6 @@ M: word test-builder 0 vreg-counter set-global [ build-tree optimize-tree ] keep build-cfg ; -: test-optimizer ( quot -- cfgs ) - test-builder [ [ optimize-cfg ] with-cfg ] map ; - : test-ssa ( quot -- cfgs ) test-builder [ [ @@ -132,3 +130,8 @@ M: rs-loc pprint* \ R pprint-loc ; : contains-insn? ( quot insn-check -- ? ) count-insns 0 > ; inline + +! Random instruction scheduling exposes bugs in +! compiler.cfg.dependencies +: random-scheduling ( -- ) + [ \ score [ drop 100 random ] define ] with-compilation-unit ; diff --git a/basis/compiler/cfg/dependence/dependence.factor b/basis/compiler/cfg/dependence/dependence.factor index 54f308324a..d15351e770 100644 --- a/basis/compiler/cfg/dependence/dependence.factor +++ b/basis/compiler/cfg/dependence/dependence.factor @@ -24,7 +24,7 @@ TUPLE: node children parent registers parent-index ; -M: node equal? over node? [ [ number>> ] bi@ = ] [ 2drop f ] if ; +M: node equal? over node? [ [ number>> ] same? ] [ 2drop f ] if ; M: node hashcode* nip number>> ; @@ -55,6 +55,7 @@ UNION: slot-insn ##read ##write ; UNION: memory-insn + ##allot ##load-memory ##load-memory-imm ##store-memory ##store-memory-imm ##write-barrier ##write-barrier-imm @@ -144,7 +145,7 @@ ERROR: node-missing-children trees nodes ; : verify-children ( trees -- trees ) dup [ flatten-tree ] map concat nodes get - { [ [ length ] bi@ = ] [ set= ] } 2&& + { [ [ length ] same? ] [ set= ] } 2&& [ nodes get node-missing-children ] unless ; : verify-trees ( trees -- trees ) diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor index 44ede70c97..43e69c8800 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor @@ -103,7 +103,7 @@ V{ [ ] [ 1 get instructions>> allocation-size 123 size assert= ] unit-test -2 \ vreg-counter set-global +2 vreg-counter set-global : gc-check? ( bb -- ? ) instructions>> @@ -119,11 +119,11 @@ V{ T{ ##branch } } = ; -4 \ vreg-counter set-global +4 vreg-counter set-global [ t ] [ gc-call? ] unit-test -30 \ vreg-counter set-global +30 vreg-counter set-global V{ T{ ##prologue } @@ -290,7 +290,7 @@ V{ 0 1 edge 1 2 edge -2 \ vreg-counter set-global +2 vreg-counter set-global [ ] [ test-gc-checks ] unit-test @@ -326,7 +326,7 @@ V{ 0 1 edge 1 2 edge -2 \ vreg-counter set-global +2 vreg-counter set-global [ ] [ test-gc-checks ] unit-test diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 8213c577e1..c7f79b5ef5 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -76,7 +76,7 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ; 2 [ first2 allocation-size cc<= int-rep next-vreg-rep int-rep next-vreg-rep - \ ##check-nursery-branch new-insn + ##check-nursery-branch new-insn swap push ] each ; @@ -85,7 +85,7 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ; : ( -- bb ) - [ ##call-gc ##branch ] V{ } make + [ ##call-gc, ##branch, ] V{ } make >>instructions t >>unlikely? ; :: connect-gc-checks ( bbs -- ) diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index bed856ab9b..0c4239f826 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -23,7 +23,7 @@ IN: compiler.cfg.hats [ drop [ ] ] } case swap [ dip ] curry compose ] reduce - ] keep suffix ; + ] keep insn-ctor-name "compiler.cfg.instructions" lookup-word suffix ; : hat-effect ( insn -- effect ) "insn-slots" word-prop diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor index 8594e6d9b5..f8f360f007 100644 --- a/basis/compiler/cfg/height/height.factor +++ b/basis/compiler/cfg/height/height.factor @@ -47,8 +47,8 @@ M: insn visit-insn drop ; [ [ visit-insn ] each ] [ [ [ ##inc-d? ] [ ##inc-r? ] bi or not ] filter! - ds-height get [ \ ##inc-d new-insn prefix ] unless-zero - rs-height get [ \ ##inc-r new-insn prefix ] unless-zero + ds-height get [ ##inc-d new-insn prefix ] unless-zero + rs-height get [ ##inc-r new-insn prefix ] unless-zero ] bi ; : normalize-height ( cfg -- cfg' ) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index c51d41443a..91c1488750 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -84,6 +84,8 @@ INSN: ##epilogue ; INSN: ##return ; +INSN: ##safepoint ; + ! Dummy instruction that simply inhibits TCO INSN: ##no-tco ; @@ -378,6 +380,11 @@ def: dst use: src1 src2 literal: rep cc ; +FOLDABLE-INSN: ##move-vector-mask +def: dst/int-rep +use: src +literal: rep ; + FOLDABLE-INSN: ##test-vector def: dst/tagged-rep use: src1 @@ -608,7 +615,7 @@ literal: offset rep c-type ; ! Memory allocation FLUSHABLE-INSN: ##allot def: dst/tagged-rep -literal: size class +literal: size class-of temp: temp/int-rep ; VREG-INSN: ##write-barrier @@ -830,13 +837,16 @@ UNION: conditional-branch-insn UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ; UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; -! Instructions that contain subroutine calls to functions which -! can callback arbitrary Factor code -UNION: factor-call-insn +UNION: alien-call-insn ##alien-invoke ##alien-indirect ##alien-assembly ; +! Instructions that contain subroutine calls to functions which +! can callback arbitrary Factor code +UNION: factor-call-insn +alien-call-insn ; + ! Instructions that contain subroutine calls to functions which ! allocate memory UNION: gc-map-insn @@ -848,15 +858,10 @@ factor-call-insn ; M: gc-map-insn clone call-next-method [ clone ] change-gc-map ; ! Each one has a gc-map slot -TUPLE: gc-map scrub-d scrub-r gc-roots ; +TUPLE: gc-map scrub-d scrub-r gc-roots derived-roots ; : ( -- gc-map ) gc-map new ; -UNION: alien-call-insn -##alien-invoke -##alien-indirect -##alien-assembly ; - ! Instructions that clobber registers. They receive inputs and ! produce outputs in spill slots. UNION: hairy-clobber-insn diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index 16a3ff4158..af47881d8a 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -15,7 +15,7 @@ TUPLE: insn-slot-spec type name rep ; { { [ dup not ] [ ] } { [ dup "scalar-rep" = ] [ drop scalar-rep ] } - [ "cpu.architecture" lookup ] + [ "cpu.architecture" lookup-word ] } cond ; : parse-insn-slot-spec ( type string -- spec ) @@ -48,19 +48,19 @@ TUPLE: insn-slot-spec type name rep ; ! We cannot reference words in compiler.cfg.instructions directly ! since that would create circularity. : insn-classes-word ( -- word ) - "insn-classes" "compiler.cfg.instructions" lookup ; + "insn-classes" "compiler.cfg.instructions" lookup-word ; : insn-word ( -- word ) - "insn" "compiler.cfg.instructions" lookup ; + "insn" "compiler.cfg.instructions" lookup-word ; : vreg-insn-word ( -- word ) - "vreg-insn" "compiler.cfg.instructions" lookup ; + "vreg-insn" "compiler.cfg.instructions" lookup-word ; : flushable-insn-word ( -- word ) - "flushable-insn" "compiler.cfg.instructions" lookup ; + "flushable-insn" "compiler.cfg.instructions" lookup-word ; : foldable-insn-word ( -- word ) - "foldable-insn" "compiler.cfg.instructions" lookup ; + "foldable-insn" "compiler.cfg.instructions" lookup-word ; : insn-effect ( word -- effect ) boa-effect in>> but-last { } ; @@ -71,8 +71,11 @@ TUPLE: insn-slot-spec type name rep ; : define-insn-tuple ( class superclass specs -- ) [ name>> ] map "insn#" suffix define-tuple-class ; +: insn-ctor-name ( word -- name ) + name>> "," append ; + : define-insn-ctor ( class specs -- ) - [ dup '[ _ ] [ f ] [ boa , ] surround ] dip + [ [ insn-ctor-name create-in ] [ '[ _ ] [ f ] [ boa , ] surround ] bi ] dip [ name>> ] map { } define-declared ; : define-insn ( class superclass specs -- ) @@ -86,13 +89,13 @@ TUPLE: insn-slot-spec type name rep ; } 3cleave ; SYNTAX: INSN: - CREATE-CLASS insn-word ";" parse-tokens define-insn ; + scan-new-class insn-word ";" parse-tokens define-insn ; SYNTAX: VREG-INSN: - CREATE-CLASS vreg-insn-word ";" parse-tokens define-insn ; + scan-new-class vreg-insn-word ";" parse-tokens define-insn ; SYNTAX: FLUSHABLE-INSN: - CREATE-CLASS flushable-insn-word ";" parse-tokens define-insn ; + scan-new-class flushable-insn-word ";" parse-tokens define-insn ; SYNTAX: FOLDABLE-INSN: - CREATE-CLASS foldable-insn-word ";" parse-tokens define-insn ; + scan-new-class foldable-insn-word ";" parse-tokens define-insn ; diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 23143b2f86..cbd9f3730e 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics.alien :: (emit-store-memory) ( node rep c-type prepare-quot test-quot -- ) node - [ prepare-quot call rep c-type ##store-memory-imm ] + [ prepare-quot call rep c-type ##store-memory-imm, ] [ test-quot call inline-store-memory? ] inline-accessor ; inline diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 72816bde7f..82fbe06119 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -8,13 +8,13 @@ compiler.cfg.utilities compiler.cfg.builder.blocks compiler.constants cpu.architecture alien.c-types ; IN: compiler.cfg.intrinsics.allot -: ##set-slots ( regs obj class -- ) - '[ _ swap 1 + _ type-number ##set-slot-imm ] each-index ; +: ##set-slots, ( regs obj class -- ) + '[ _ swap 1 + _ type-number ##set-slot-imm, ] each-index ; : emit-simple-allot ( node -- ) [ in-d>> length ] [ node-output-infos first class>> ] bi [ drop ds-load ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri - [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ; + [ ##set-slots, ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ; : tuple-slot-regs ( layout -- vregs ) [ second ds-load ] [ ^^load-literal ] bi prefix ; @@ -28,14 +28,14 @@ IN: compiler.cfg.intrinsics.allot nip ds-drop [ tuple-slot-regs ] [ second ^^allot-tuple ] bi - [ tuple ##set-slots ] [ ds-push drop ] 2bi + [ tuple ##set-slots, ] [ ds-push drop ] 2bi ] [ drop emit-primitive ] if ; : store-length ( len reg class -- ) - [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ; + [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm, ; :: store-initial-element ( len reg elt class -- ) - len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each-integer ; + len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm, ] each-integer ; : expand-? ( obj -- ? ) dup integer? [ 0 8 between? ] [ drop f ] if ; @@ -76,7 +76,7 @@ IN: compiler.cfg.intrinsics.allot 0 ^^load-literal :> elt reg ^^tagged>integer :> reg len cell align cell /i iota [ - [ elt reg ] dip cells byte-array-offset + int-rep f ##store-memory-imm + [ elt reg ] dip cells byte-array-offset + int-rep f ##store-memory-imm, ] each ; :: emit- ( node -- ) diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 6b87ca8fd6..403918f92f 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -32,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum ] binary-op ; : emit-fixnum-shift-general ( -- ) - ds-peek 0 cc> ##compare-integer-imm-branch + ds-peek 0 cc> ##compare-integer-imm-branch, [ emit-fixnum-left-shift ] with-branch [ emit-fixnum-right-shift ] with-branch 2array emit-conditional ; @@ -52,7 +52,7 @@ IN: compiler.cfg.intrinsics.fixnum : emit-overflow-case ( word -- final-bb ) [ - ##call + ##call, -1 adjust-d make-kill-block ] with-branch ; @@ -77,4 +77,4 @@ IN: compiler.cfg.intrinsics.fixnum [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ; : emit-fixnum* ( -- ) - [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ; \ No newline at end of file + [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 475edb41a4..31b3adb0aa 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel combinators cpu.architecture assocs +math.bitwise compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index 62bb15f953..301c4f2389 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -33,7 +33,7 @@ IN: compiler.cfg.intrinsics.misc : emit-set-special-object ( node -- ) dup node-input-infos second literal>> [ ds-drop - [ ds-pop ] dip special-object-offset ##set-vm-field + [ ds-pop ] dip special-object-offset ##set-vm-field, ] [ emit-primitive ] ?if ; : context-object-offset ( n -- n ) @@ -60,4 +60,4 @@ IN: compiler.cfg.intrinsics.misc if ; : emit-cleanup-allot ( -- ) - [ ##no-tco ] emit-trivial-block ; + [ ##no-tco, ] emit-trivial-block ; diff --git a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor index 84ffc208d5..5c51afb8f9 100644 --- a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor +++ b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor @@ -37,6 +37,7 @@ M: ##tail>head-vector insn-available? rep>> %unpack-vector-head-reps member? ; M: ##integer>float-vector insn-available? rep>> %integer>float-vector-reps member? ; M: ##float>integer-vector insn-available? rep>> %float>integer-vector-reps member? ; M: ##compare-vector insn-available? [ rep>> ] [ cc>> ] bi %compare-vector-reps member? ; +M: ##move-vector-mask insn-available? rep>> %move-vector-mask-reps member? ; M: ##test-vector insn-available? rep>> %test-vector-reps member? ; M: ##add-vector insn-available? rep>> %add-vector-reps member? ; M: ##saturated-add-vector insn-available? rep>> %saturated-add-vector-reps member? ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd-tests.factor b/basis/compiler/cfg/intrinsics/simd/simd-tests.factor index 96c8da8ace..2520c6e4ff 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd-tests.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd-tests.factor @@ -22,7 +22,7 @@ IN: compiler.cfg.intrinsics.simd.tests } ; :: test-node-literal ( lit rep -- node ) - lit class :> lit-class + lit class-of :> lit-class T{ #call { in-d { 1 2 3 4 } } { out-d { 5 } } @@ -63,26 +63,26 @@ IN: compiler.cfg.intrinsics.simd.tests H{ } clone \ kill-sets pick set-at ; : make-classes ( quot -- seq ) - { } make [ class ] map ; inline + { } make [ class-of ] map ; inline : test-emit ( cpu rep quot -- node ) [ [ new \ cpu ] 2dip '[ - test-compiler-env [ _ test-node @ ] bind + test-compiler-env [ _ test-node @ ] with-variables ] with-variable ] make-classes ; inline : test-emit-literal ( cpu lit rep quot -- node ) [ [ new \ cpu ] 3dip '[ - test-compiler-env [ _ _ test-node-literal @ ] bind + test-compiler-env [ _ _ test-node-literal @ ] with-variables ] with-variable ] make-classes ; inline : test-emit-nonliteral-rep ( cpu quot -- node ) [ [ new \ cpu ] dip '[ - test-compiler-env [ test-node-nonliteral-rep @ ] bind + test-compiler-env [ test-node-nonliteral-rep @ ] with-variables ] with-variable ] make-classes ; inline @@ -97,20 +97,21 @@ CONSTANT: all-reps TUPLE: scalar-cpu ; TUPLE: simple-ops-cpu ; -M: simple-ops-cpu %zero-vector-reps all-reps ; -M: simple-ops-cpu %fill-vector-reps all-reps ; -M: simple-ops-cpu %add-vector-reps all-reps ; -M: simple-ops-cpu %sub-vector-reps all-reps ; -M: simple-ops-cpu %mul-vector-reps all-reps ; -M: simple-ops-cpu %div-vector-reps all-reps ; -M: simple-ops-cpu %andn-vector-reps all-reps ; -M: simple-ops-cpu %and-vector-reps all-reps ; -M: simple-ops-cpu %or-vector-reps all-reps ; -M: simple-ops-cpu %xor-vector-reps all-reps ; +M: simple-ops-cpu %zero-vector-reps all-reps ; +M: simple-ops-cpu %fill-vector-reps all-reps ; +M: simple-ops-cpu %add-vector-reps all-reps ; +M: simple-ops-cpu %sub-vector-reps all-reps ; +M: simple-ops-cpu %mul-vector-reps all-reps ; +M: simple-ops-cpu %div-vector-reps all-reps ; +M: simple-ops-cpu %andn-vector-reps all-reps ; +M: simple-ops-cpu %and-vector-reps all-reps ; +M: simple-ops-cpu %or-vector-reps all-reps ; +M: simple-ops-cpu %xor-vector-reps all-reps ; M: simple-ops-cpu %merge-vector-reps all-reps ; -M: simple-ops-cpu %sqrt-vector-reps all-reps ; +M: simple-ops-cpu %sqrt-vector-reps all-reps ; +M: simple-ops-cpu %move-vector-mask-reps all-reps ; M: simple-ops-cpu %test-vector-reps all-reps ; -M: simple-ops-cpu %signed-pack-vector-reps all-reps ; +M: simple-ops-cpu %signed-pack-vector-reps all-reps ; M: simple-ops-cpu %unsigned-pack-vector-reps all-reps ; M: simple-ops-cpu %gather-vector-2-reps { longlong-2-rep ulonglong-2-rep double-2-rep } ; M: simple-ops-cpu %gather-vector-4-reps { int-4-rep uint-4-rep float-4-rep } ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index 9d15feb96f..b35efc0d97 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -22,22 +22,22 @@ IN: compiler.cfg.intrinsics.simd : sign-bit-mask ( rep -- byte-array ) signed-rep { { char-16-rep [ uchar-array{ - HEX: 80 HEX: 80 HEX: 80 HEX: 80 - HEX: 80 HEX: 80 HEX: 80 HEX: 80 - HEX: 80 HEX: 80 HEX: 80 HEX: 80 - HEX: 80 HEX: 80 HEX: 80 HEX: 80 + 0x80 0x80 0x80 0x80 + 0x80 0x80 0x80 0x80 + 0x80 0x80 0x80 0x80 + 0x80 0x80 0x80 0x80 } underlying>> ] } { short-8-rep [ ushort-array{ - HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000 - HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000 + 0x8000 0x8000 0x8000 0x8000 + 0x8000 0x8000 0x8000 0x8000 } underlying>> ] } { int-4-rep [ uint-array{ - HEX: 8000,0000 HEX: 8000,0000 - HEX: 8000,0000 HEX: 8000,0000 + 0x8000,0000 0x8000,0000 + 0x8000,0000 0x8000,0000 } underlying>> ] } { longlong-2-rep [ ulonglong-array{ - HEX: 8000,0000,0000,0000 - HEX: 8000,0000,0000,0000 + 0x8000,0000,0000,0000 + 0x8000,0000,0000,0000 } underlying>> ] } } case ; @@ -555,6 +555,10 @@ PREDICATE: fixnum-vector-rep < int-vector-rep { [ vcc-none ^^test-vector ] } emit-v-vector-op ; +: emit-simd-vgetmask ( node -- ) + { + [ ^^move-vector-mask ] + } emit-v-vector-op ; : emit-simd-v>float ( node -- ) { @@ -632,7 +636,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep dup [ '[ ds-drop prepare-store-memory - _ f ##store-memory-imm + _ f ##store-memory-imm, ] [ byte-array inline-store-memory? ] inline-accessor @@ -700,6 +704,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep { alien-vector [ emit-alien-vector ] } { set-alien-vector [ emit-set-alien-vector ] } { assert-positive [ drop ] } + { (simd-vgetmask) [ emit-simd-vgetmask ] } } enable-intrinsics ; enable-simd diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index a3f532b4db..6b72f29846 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -52,10 +52,10 @@ IN: compiler.cfg.intrinsics.slots infos second value-tag :> tag slot tag slot-indexing :> ( slot scale tag ) - src obj slot scale tag ##set-slot + src obj slot scale tag ##set-slot, infos emit-write-barrier? - [ obj slot scale tag next-vreg next-vreg ##write-barrier ] when ; + [ obj slot scale tag next-vreg next-vreg ##write-barrier, ] when ; :: (emit-set-slot-imm) ( infos -- ) ds-drop @@ -65,10 +65,10 @@ IN: compiler.cfg.intrinsics.slots infos third literal>> :> slot infos second value-tag :> tag - src obj slot tag ##set-slot-imm + src obj slot tag ##set-slot-imm, infos emit-write-barrier? - [ obj slot tag next-vreg next-vreg ##write-barrier-imm ] when ; + [ obj slot tag next-vreg next-vreg ##write-barrier-imm, ] when ; : emit-set-slot ( node -- ) dup node-input-infos diff --git a/basis/compiler/cfg/intrinsics/strings/strings.factor b/basis/compiler/cfg/intrinsics/strings/strings.factor index 70d8442a2b..36ac0307c1 100644 --- a/basis/compiler/cfg/intrinsics/strings/strings.factor +++ b/basis/compiler/cfg/intrinsics/strings/strings.factor @@ -12,4 +12,4 @@ IN: compiler.cfg.intrinsics.strings 2inputs (string-nth) ^^load-memory-imm ds-push ; : emit-set-string-nth-fast ( -- ) - 3inputs (string-nth) ##store-memory-imm ; + 3inputs (string-nth) ##store-memory-imm, ; diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index 827b878d68..7f98e53688 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -5,6 +5,7 @@ heaps kernel math math.order namespaces layouts sequences vectors linked-assocs compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ; +FROM: assocs => change-at ; IN: compiler.cfg.linear-scan.allocation.state ! Start index of current live interval. We ensure that all diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 365d4e2f21..49c492cb31 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -6,7 +6,6 @@ cpu.architecture layouts compiler.cfg compiler.cfg.def-use compiler.cfg.liveness -compiler.cfg.liveness.ssa compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linearization @@ -98,7 +97,7 @@ SYMBOL: machine-live-outs init-unhandled ; : insert-spill ( live-interval -- ) - [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill ; + [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill, ; : handle-spill ( live-interval -- ) dup spill-to>> [ insert-spill ] [ drop ] if ; @@ -118,7 +117,7 @@ SYMBOL: machine-live-outs pending-interval-heap get (expire-old-intervals) ; : insert-reload ( live-interval -- ) - [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload ; + [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload, ; : handle-reload ( live-interval -- ) dup reload-from>> [ insert-reload ] [ drop ] if ; @@ -147,9 +146,15 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ] M: vreg-insn assign-registers-in-insn [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ; +: assign-gc-roots ( gc-map -- ) + [ [ vreg>spill-slot ] map ] change-gc-roots drop ; + +: assign-derived-roots ( gc-map -- ) + [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ; + M: gc-map-insn assign-registers-in-insn [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ] - [ gc-map>> [ [ vreg>spill-slot ] map ] change-gc-roots drop ] + [ gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi ] bi ; M: insn assign-registers-in-insn drop ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 5f1abd3165..d3ee2f6fbb 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -12,6 +12,7 @@ compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.assignment compiler.cfg.linear-scan.resolve ; +FROM: assocs => change-at ; IN: compiler.cfg.linear-scan ! References: diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 41545981c2..a514a6738e 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -132,17 +132,30 @@ M: vreg-insn compute-live-intervals* ( insn -- ) [ [ temp-vregs ] dip '[ _ record-temp ] each ] 2tri ; +! Extend lifetime intervals of base pointers, so that their +! values are available even if the base pointer is never used +! again. + +GENERIC: uses-vregs* ( insn -- seq ) + +M: gc-map-insn uses-vregs* + [ uses-vregs ] [ gc-map>> derived-roots>> values ] bi append ; + +M: vreg-insn uses-vregs* uses-vregs ; + +M: insn uses-vregs* drop f ; + M: clobber-insn compute-live-intervals* ( insn -- ) dup insn#>> [ [ defs-vregs ] dip '[ _ f record-def ] each ] - [ [ uses-vregs ] dip '[ _ t record-use ] each ] + [ [ uses-vregs* ] dip '[ _ t record-use ] each ] [ [ temp-vregs ] dip '[ _ record-temp ] each ] 2tri ; M: hairy-clobber-insn compute-live-intervals* ( insn -- ) dup insn#>> [ [ defs-vregs ] dip '[ _ t record-def ] each ] - [ [ uses-vregs ] dip '[ _ t record-use ] each ] + [ [ uses-vregs* ] dip '[ _ t record-use ] each ] [ [ temp-vregs ] dip '[ _ record-temp ] each ] 2tri ; diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 564c2978f5..68c43dfc87 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -27,7 +27,7 @@ TUPLE: location M: location equal? over location? [ - { [ [ reg>> ] bi@ = ] [ [ reg-class>> ] bi@ = ] } 2&& + { [ [ reg>> ] same? ] [ [ reg-class>> ] same? ] } 2&& ] [ 2drop f ] if ; M: location hashcode* @@ -60,19 +60,19 @@ SYMBOL: spill-temps ] if ; : memory->register ( from to -- ) - swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* ##reload ; + swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* ##reload, ; : register->memory ( from to -- ) - [ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* ##spill ; + [ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* ##spill, ; : temp->register ( from to -- ) - nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri ##reload ; + nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri ##reload, ; : register->temp ( from to -- ) - drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi ##spill ; + drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi ##spill, ; : register->register ( from to -- ) - swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy ; + swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy, ; SYMBOL: temp @@ -87,7 +87,7 @@ SYMBOL: temp : mapping-instructions ( alist -- insns ) [ swap ] H{ } assoc-map-as - [ temp [ swap >insn ] parallel-mapping ##branch ] { } make ; + [ temp [ swap >insn ] parallel-mapping ##branch, ] { } make ; : perform-mappings ( bb to mappings -- ) dup empty? [ 3drop ] [ diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor index 7099d3a06e..ba870fbc75 100644 --- a/basis/compiler/cfg/liveness/liveness-tests.factor +++ b/basis/compiler/cfg/liveness/liveness-tests.factor @@ -1,19 +1,15 @@ -USING: compiler.cfg.liveness compiler.cfg.liveness.ssa +USING: compiler.cfg.liveness compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.predecessors compiler.cfg.registers compiler.cfg cpu.architecture accessors namespaces sequences kernel tools.test vectors alien math compiler.cfg.comparisons -cpu.x86.assembler.operands ; +cpu.x86.assembler.operands assocs ; IN: compiler.cfg.liveness.tests : test-liveness ( -- ) cfg new 1 get >>entry compute-live-sets ; -: test-ssa-liveness ( -- ) - cfg new 1 get >>entry - compute-ssa-live-sets ; - ! Sanity check... V{ @@ -148,9 +144,104 @@ V{ 7 8 edge 8 9 edge -[ ] [ test-ssa-liveness ] unit-test +[ ] [ test-liveness ] unit-test [ H{ { 28 28 } { 29 29 } { 30 30 } { 31 31 } } ] [ 5 get live-out ] unit-test [ H{ { 28 28 } { 29 29 } { 30 30 } } ] [ 6 get live-in ] unit-test [ H{ { 28 28 } { 29 29 } { 31 31 } } ] [ 7 get live-in ] unit-test -[ H{ { 30 30 } } ] [ 6 get 8 get edge-live-in ] unit-test \ No newline at end of file +[ H{ { 30 30 } } ] [ 6 get 8 get edge-live-in ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##branch } +} 1 test-bb + +V{ + T{ ##load-integer f 0 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##load-integer f 1 1 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##phi f 2 H{ { 2 0 } { 3 1 } } } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##branch } +} 5 test-bb + +V{ + T{ ##replace f 2 D 0 } + T{ ##branch } +} 6 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 7 test-bb + +0 1 edge +1 { 2 3 } edges +2 4 edge +3 4 edge +4 { 5 6 } edges +5 6 edge +6 7 edge + +[ ] [ cfg new 0 get >>entry dup cfg set compute-live-sets ] unit-test + +[ t ] [ 0 get live-in assoc-empty? ] unit-test + +[ H{ { 2 2 } } ] [ 4 get live-out ] unit-test + +[ H{ { 0 0 } } ] [ 2 get 4 get edge-live-in ] unit-test + +[ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test + + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f 0 D 0 } + T{ ##tagged>integer f 1 0 } + T{ ##call-gc f T{ gc-map } } + T{ ##replace f 0 D 0 } + T{ ##call-gc f T{ gc-map } } + T{ ##replace f 1 D 0 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 2 test-bb + +0 1 edge +1 2 edge + +H{ + { 0 tagged-rep } + { 1 int-rep } +} representations set + +[ ] [ cfg new 0 get >>entry dup cfg set compute-live-sets ] unit-test + +[ V{ { 1 0 } } ] [ 1 get instructions>> 2 swap nth gc-map>> derived-roots>> ] unit-test + +[ { 0 } ] [ 1 get instructions>> 2 swap nth gc-map>> gc-roots>> ] unit-test + +[ V{ { 1 0 } } ] [ 1 get instructions>> 4 swap nth gc-map>> derived-roots>> ] unit-test + +[ { 0 } ] [ 1 get instructions>> 4 swap nth gc-map>> gc-roots>> ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index cbf4105392..2c6bcdfa47 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -1,17 +1,46 @@ ! Copyright (C) 2009, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors assocs namespaces sequences sets -compiler.cfg.def-use compiler.cfg.dataflow-analysis -compiler.cfg.instructions compiler.cfg.registers -cpu.architecture ; +USING: arrays kernel accessors assocs fry locals combinators +deques dlists namespaces sequences sets compiler.cfg +compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.registers compiler.cfg.utilities +compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture ; +FROM: namespaces => set ; IN: compiler.cfg.liveness -! See http://en.wikipedia.org/wiki/Liveness_analysis -! Do not run after SSA construction; compiler.cfg.liveness.ssa -! should be used instead. The transfer-liveness word is used -! by SSA liveness too, so it handles ##phi instructions. +! Similar to http://en.wikipedia.org/wiki/Liveness_analysis, +! with three additions: -BACKWARD-ANALYSIS: live +! 1) With SSA, it is not sufficient to have a single live-in set +! per block. There is also there is an edge-live-in set per +! edge, consisting of phi inputs from each predecessor. +! 2) Liveness analysis annotates call sites with GC maps +! indicating the spill slots in the stack frame that contain +! tagged pointers, and thus have to be visited if a GC occurs +! inside the call. +! 3) GC maps can contain derived pointers. A derived pointer is +! a pointer into the middle of a data heap object. Each derived +! pointer has a base pointer, to keep it up to date when objects +! are moved by the garbage collector. This extends live +! intervals and inserts new ##phi instructions. +SYMBOL: live-ins + +: live-in ( bb -- set ) + live-ins get at ; + +SYMBOL: live-outs + +: live-out ( bb -- set ) + live-outs get at ; + +! Assoc mapping basic blocks to sequences of sets of vregs; each +! sequence is in correspondence with a predecessor +SYMBOL: edge-live-ins + +: edge-live-in ( predecessor basic-block -- set ) + edge-live-ins get at at ; + +SYMBOL: base-pointers GENERIC: visit-insn ( live-set insn -- live-set ) @@ -21,15 +50,64 @@ GENERIC: visit-insn ( live-set insn -- live-set ) : gen-uses ( live-set insn -- live-set ) uses-vregs [ over conjoin ] each ; inline -M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ; +M: vreg-insn visit-insn + [ kill-defs ] [ gen-uses ] bi ; + +DEFER: lookup-base-pointer + +GENERIC: lookup-base-pointer* ( insn -- vreg/f ) + +M: ##tagged>integer lookup-base-pointer* src>> ; + +M: ##unbox-any-c-ptr lookup-base-pointer* + ! If the input to unbox-any-c-ptr was an alien and not a + ! byte array, then the derived pointer will be outside of + ! the data heap. The GC has to handle this case and ignore + ! it. + src>> ; + +M: ##copy lookup-base-pointer* src>> lookup-base-pointer ; + +M: ##add-imm lookup-base-pointer* src1>> lookup-base-pointer ; + +M: ##sub-imm lookup-base-pointer* src1>> lookup-base-pointer ; + +M: ##add lookup-base-pointer* + ! If both operands have a base pointer, then the user better + ! not be doing memory reads and writes on the object, since + ! we don't give it a base pointer in that case at all. + [ src1>> ] [ src2>> ] bi [ lookup-base-pointer ] bi@ xor ; + +M: ##sub lookup-base-pointer* + src1>> lookup-base-pointer ; + +M: vreg-insn lookup-base-pointer* drop f ; + +: lookup-base-pointer ( vreg -- vreg/f ) + base-pointers get [ insn-of lookup-base-pointer* ] cache ; + +:: visit-derived-root ( vreg derived-roots gc-roots -- ) + vreg lookup-base-pointer :> base + base [ + { vreg base } derived-roots push + base gc-roots adjoin + ] when ; + +: visit-gc-root ( vreg derived-roots gc-roots -- ) + pick rep-of { + { tagged-rep [ nip adjoin ] } + { int-rep [ visit-derived-root ] } + [ 2drop 2drop ] + } case ; + +: gc-roots ( live-set -- derived-roots gc-roots ) + V{ } clone HS{ } clone + [ '[ drop _ _ visit-gc-root ] assoc-each ] 2keep + members ; : fill-gc-map ( live-set insn -- live-set ) - representations get [ - gc-map>> over keys - [ rep-of tagged-rep? ] filter - >>gc-roots - ] when - drop ; + [ representations get [ dup gc-roots ] [ f f ] if ] dip + gc-map>> [ gc-roots<< ] [ derived-roots<< ] bi ; M: gc-map-insn visit-insn [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ; @@ -41,11 +119,51 @@ M: insn visit-insn drop ; : transfer-liveness ( live-set instructions -- live-set' ) [ clone ] [ ] bi* [ visit-insn ] each ; -: local-live-in ( instructions -- live-set ) - [ H{ } ] dip transfer-liveness keys ; +SYMBOL: work-list -M: live-analysis transfer-set - drop instructions>> transfer-liveness ; +: add-to-work-list ( basic-blocks -- ) + work-list get push-all-front ; -M: live-analysis join-sets - 2drop assoc-combine ; +: compute-live-in ( basic-block -- live-in ) + [ live-out ] keep instructions>> transfer-liveness ; + +: compute-edge-live-in ( basic-block -- edge-live-in ) + H{ } clone [ + '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi + ] keep ; + +: update-live-in ( basic-block -- changed? ) + [ [ compute-live-in ] keep live-ins get maybe-set-at ] + [ [ compute-edge-live-in ] keep edge-live-ins get maybe-set-at ] + bi or ; + +: compute-live-out ( basic-block -- live-out ) + [ successors>> [ live-in ] map ] + [ dup successors>> [ edge-live-in ] with map ] bi + append assoc-combine ; + +: update-live-out ( basic-block -- changed? ) + [ compute-live-out ] keep + live-outs get maybe-set-at ; + +: liveness-step ( basic-block -- ) + dup update-live-out [ + dup update-live-in + [ predecessors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-live-sets ( cfg -- ) + needs-predecessors + dup compute-insns + + work-list set + H{ } clone live-ins set + H{ } clone edge-live-ins set + H{ } clone live-outs set + H{ } clone base-pointers set + post-order add-to-work-list + work-list get [ liveness-step ] slurp-deque ; + +: live-in? ( vreg bb -- ? ) live-in key? ; + +: live-out? ( vreg bb -- ? ) live-out key? ; diff --git a/basis/compiler/cfg/liveness/ssa/ssa-tests.factor b/basis/compiler/cfg/liveness/ssa/ssa-tests.factor deleted file mode 100644 index 5413c65b32..0000000000 --- a/basis/compiler/cfg/liveness/ssa/ssa-tests.factor +++ /dev/null @@ -1,61 +0,0 @@ -USING: accessors compiler.cfg compiler.cfg.debugger -compiler.cfg.instructions compiler.cfg.liveness.ssa -compiler.cfg.liveness arrays sequences assocs -compiler.cfg.registers kernel namespaces tools.test ; -IN: compiler.cfg.liveness.ssa.tests - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##branch } -} 1 test-bb - -V{ - T{ ##load-integer f 0 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##load-integer f 1 1 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##phi f 2 H{ { 2 0 } { 3 1 } } } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##branch } -} 5 test-bb - -V{ - T{ ##replace f 2 D 0 } - T{ ##branch } -} 6 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 7 test-bb - -0 1 edge -1 { 2 3 } edges -2 4 edge -3 4 edge -4 { 5 6 } edges -5 6 edge -6 7 edge - -[ ] [ cfg new 0 get >>entry dup cfg set compute-ssa-live-sets ] unit-test - -[ t ] [ 0 get live-in assoc-empty? ] unit-test - -[ H{ { 2 2 } } ] [ 4 get live-out ] unit-test - -[ H{ { 0 0 } } ] [ 2 get 4 get edge-live-in ] unit-test - -[ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test diff --git a/basis/compiler/cfg/liveness/ssa/ssa.factor b/basis/compiler/cfg/liveness/ssa/ssa.factor deleted file mode 100644 index 84428514aa..0000000000 --- a/basis/compiler/cfg/liveness/ssa/ssa.factor +++ /dev/null @@ -1,63 +0,0 @@ -! Copyright (C) 2009, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces deques accessors sets sequences assocs fry -hashtables dlists compiler.cfg.def-use compiler.cfg.instructions -compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities -compiler.cfg.predecessors ; -FROM: namespaces => set ; -IN: compiler.cfg.liveness.ssa - -! TODO: merge with compiler.cfg.liveness - -! Assoc mapping basic blocks to sequences of sets of vregs; each sequence -! is in correspondence with a predecessor -SYMBOL: edge-live-ins - -: edge-live-in ( predecessor basic-block -- set ) edge-live-ins get at at ; - -SYMBOL: work-list - -: add-to-work-list ( basic-blocks -- ) - work-list get '[ _ push-front ] each ; - -: compute-live-in ( basic-block -- live-in ) - [ live-out ] keep instructions>> transfer-liveness ; - -: compute-edge-live-in ( basic-block -- edge-live-in ) - H{ } clone [ - '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi - ] keep ; - -: update-live-in ( basic-block -- changed? ) - [ [ compute-live-in ] keep live-ins get maybe-set-at ] - [ [ compute-edge-live-in ] keep edge-live-ins get maybe-set-at ] - bi or ; - -: compute-live-out ( basic-block -- live-out ) - [ successors>> [ live-in ] map ] - [ dup successors>> [ edge-live-in ] with map ] bi - append assoc-combine ; - -: update-live-out ( basic-block -- changed? ) - [ compute-live-out ] keep - live-outs get maybe-set-at ; - -: liveness-step ( basic-block -- ) - dup update-live-out [ - dup update-live-in - [ predecessors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-ssa-live-sets ( cfg -- ) - needs-predecessors - - work-list set - H{ } clone live-ins set - H{ } clone edge-live-ins set - H{ } clone live-outs set - post-order add-to-work-list - work-list get [ liveness-step ] slurp-deque ; - -: live-in? ( vreg bb -- ? ) live-in key? ; - -: live-out? ( vreg bb -- ? ) live-out key? ; diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.factor index ef4bada633..4e8320d3d6 100644 --- a/basis/compiler/cfg/parallel-copy/parallel-copy.factor +++ b/basis/compiler/cfg/parallel-copy/parallel-copy.factor @@ -58,4 +58,4 @@ PRIVATE> ] with-scope ; inline : parallel-copy ( mapping -- ) - next-vreg [ any-rep ##copy ] parallel-mapping ; \ No newline at end of file + next-vreg [ any-rep ##copy, ] parallel-mapping ; diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 9c7896be7e..d70d9316a2 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -9,7 +9,7 @@ SYMBOL: vreg-counter : next-vreg ( -- vreg ) ! This word cannot be called AFTER representation selection has run; ! use next-vreg-rep in that case - \ vreg-counter counter ; + vreg-counter counter ; SYMBOL: representations @@ -42,5 +42,5 @@ C: ds-loc TUPLE: rs-loc < loc ; C: rs-loc -SYNTAX: D scan-word suffix! ; -SYNTAX: R scan-word suffix! ; +SYNTAX: D scan-number suffix! ; +SYNTAX: R scan-number suffix! ; diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor index 1b7f6d5f0c..0e1cf5311d 100644 --- a/basis/compiler/cfg/renaming/functor/functor.factor +++ b/basis/compiler/cfg/renaming/functor/functor.factor @@ -74,4 +74,4 @@ insn-classes get [ insn-temp-slots empty? not ] filter [ ;FUNCTOR -SYNTAX: RENAMING: scan scan-object scan-object scan-object define-renaming ; \ No newline at end of file +SYNTAX: RENAMING: scan-token scan-object scan-object scan-object define-renaming ; diff --git a/basis/compiler/cfg/representations/conversion/conversion.factor b/basis/compiler/cfg/representations/conversion/conversion.factor index b8346fed6a..e01a030495 100644 --- a/basis/compiler/cfg/representations/conversion/conversion.factor +++ b/basis/compiler/cfg/representations/conversion/conversion.factor @@ -11,73 +11,73 @@ GENERIC: rep>tagged ( dst src rep -- ) GENERIC: tagged>rep ( dst src rep -- ) M: int-rep rep>tagged ( dst src rep -- ) - drop tag-bits get ##shl-imm ; + drop tag-bits get ##shl-imm, ; M: int-rep tagged>rep ( dst src rep -- ) - drop tag-bits get ##sar-imm ; + drop tag-bits get ##sar-imm, ; M:: float-rep rep>tagged ( dst src rep -- ) double-rep next-vreg-rep :> temp - temp src ##single>double-float + temp src ##single>double-float, dst temp double-rep rep>tagged ; M:: float-rep tagged>rep ( dst src rep -- ) double-rep next-vreg-rep :> temp temp src double-rep tagged>rep - dst temp ##double>single-float ; + dst temp ##double>single-float, ; M:: double-rep rep>tagged ( dst src rep -- ) - dst 16 float int-rep next-vreg-rep ##allot - src dst float-offset double-rep f ##store-memory-imm ; + dst 16 float int-rep next-vreg-rep ##allot, + src dst float-offset double-rep f ##store-memory-imm, ; M: double-rep tagged>rep - drop float-offset double-rep f ##load-memory-imm ; + drop float-offset double-rep f ##load-memory-imm, ; M:: vector-rep rep>tagged ( dst src rep -- ) tagged-rep next-vreg-rep :> temp - dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot - temp 16 tag-fixnum ##load-tagged - temp dst 1 byte-array type-number ##set-slot-imm - src dst byte-array-offset rep f ##store-memory-imm ; + dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot, + temp 16 tag-fixnum ##load-tagged, + temp dst 1 byte-array type-number ##set-slot-imm, + src dst byte-array-offset rep f ##store-memory-imm, ; M: vector-rep tagged>rep - [ byte-array-offset ] dip f ##load-memory-imm ; + [ byte-array-offset ] dip f ##load-memory-imm, ; M:: scalar-rep rep>tagged ( dst src rep -- ) tagged-rep next-vreg-rep :> temp - temp src rep ##scalar>integer + temp src rep ##scalar>integer, dst temp int-rep rep>tagged ; M:: scalar-rep tagged>rep ( dst src rep -- ) tagged-rep next-vreg-rep :> temp temp src int-rep tagged>rep - dst temp rep ##integer>scalar ; + dst temp rep ##integer>scalar, ; GENERIC: rep>int ( dst src rep -- ) GENERIC: int>rep ( dst src rep -- ) M: scalar-rep rep>int ( dst src rep -- ) - ##scalar>integer ; + ##scalar>integer, ; M: scalar-rep int>rep ( dst src rep -- ) - ##integer>scalar ; + ##integer>scalar, ; : emit-conversion ( dst src dst-rep src-rep -- ) { - { [ 2dup eq? ] [ drop ##copy ] } + { [ 2dup eq? ] [ drop ##copy, ] } { [ dup tagged-rep? ] [ drop tagged>rep ] } { [ over tagged-rep? ] [ nip rep>tagged ] } { [ dup int-rep? ] [ drop int>rep ] } { [ over int-rep? ] [ nip rep>int ] } [ 2dup 2array { - { { double-rep float-rep } [ 2drop ##single>double-float ] } - { { float-rep double-rep } [ 2drop ##double>single-float ] } + { { double-rep float-rep } [ 2drop ##single>double-float, ] } + { { float-rep double-rep } [ 2drop ##double>single-float, ] } ! Punning SIMD vector types? Naughty naughty! But ! it is allowed... otherwise bail out. [ drop 2dup [ reg-class-of ] bi@ eq? - [ drop ##copy ] [ bad-conversion ] if + [ drop ##copy, ] [ bad-conversion ] if ] } case ] diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor index d86259971f..0248be46e4 100644 --- a/basis/compiler/cfg/representations/peephole/peephole.factor +++ b/basis/compiler/cfg/representations/peephole/peephole.factor @@ -37,7 +37,7 @@ M: ##load-integer optimize-insn { { [ dup dst>> rep-of tagged-rep? ] - [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged here ] + [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged, here ] } [ call-next-method ] } cond ; @@ -84,23 +84,23 @@ M: ##load-reference optimize-insn { { [ dup convert-to-load-float? ] - [ [ dst>> ] [ obj>> ] bi ##load-float here ] + [ [ dst>> ] [ obj>> ] bi ##load-float, here ] } { [ dup convert-to-load-double? ] - [ [ dst>> ] [ obj>> ] bi ##load-double here ] + [ [ dst>> ] [ obj>> ] bi ##load-double, here ] } { [ dup convert-to-zero-vector? ] - [ dst>> dup rep-of ##zero-vector here ] + [ dst>> dup rep-of ##zero-vector, here ] } { [ dup convert-to-fill-vector? ] - [ dst>> dup rep-of ##fill-vector here ] + [ dst>> dup rep-of ##fill-vector, here ] } { [ dup convert-to-load-vector? ] - [ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri ##load-vector here ] + [ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri ##load-vector, here ] } [ call-next-method ] } cond ; @@ -113,9 +113,9 @@ M: ##load-reference optimize-insn ! ##sar-imm by tag-bits - X. : combine-shl-imm-input ( insn -- ) [ dst>> ] [ src1>> ] [ src2>> ] tri tag-bits get { - { [ 2dup < ] [ swap - ##sar-imm here ] } - { [ 2dup > ] [ - ##shl-imm here ] } - [ 2drop int-rep ##copy here ] + { [ 2dup < ] [ swap - ##sar-imm, here ] } + { [ 2dup > ] [ - ##shl-imm, here ] } + [ 2drop int-rep ##copy, here ] } cond ; : dst-tagged? ( insn -- ? ) dst>> rep-of tagged-rep? ; @@ -260,7 +260,7 @@ M: ##test-branch optimize-insn [ dst>> ] [ src>> ] bi [ rep-of tagged-rep? ] both? ; : combine-neg-tag ( insn -- ) - [ dst>> ] [ src>> ] bi tag-bits get 2^ neg ##mul-imm here ; + [ dst>> ] [ src>> ] bi tag-bits get 2^ neg ##mul-imm, here ; M: ##neg optimize-insn { @@ -276,8 +276,8 @@ M: ##neg optimize-insn ! tag(not(untag(x))) = not(x) xor tag-mask :: emit-tagged-not ( insn -- ) tagged-rep next-vreg-rep :> temp - temp insn src>> ##not - insn dst>> temp tag-mask get ##xor-imm here ; + temp insn src>> ##not, + insn dst>> temp tag-mask get ##xor-imm, here ; M: ##not optimize-insn { diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor index c733dba5ed..0e9a451c0a 100644 --- a/basis/compiler/cfg/representations/representations-tests.factor +++ b/basis/compiler/cfg/representations/representations-tests.factor @@ -6,6 +6,7 @@ math compiler.constants compiler.cfg.representations.conversion compiler.cfg.representations.rewrite compiler.cfg.comparisons make ; +FROM: alien.c-types => char ; IN: compiler.cfg.representations [ { double-rep double-rep } ] [ @@ -27,7 +28,7 @@ IN: compiler.cfg.representations H{ } clone representations set -3 \ vreg-counter set-global +3 vreg-counter set-global [ { @@ -196,7 +197,7 @@ V{ 3 { 3 4 } edges 2 4 edge -3 \ vreg-counter set-global +3 vreg-counter set-global [ ] [ test-representations ] unit-test @@ -395,7 +396,7 @@ cpu x86.32? [ ! Don't convert the def site into anything but tagged-rep since ! we might lose precision -5 \ vreg-counter set-global +5 vreg-counter set-global [ f ] [ V{ @@ -425,7 +426,7 @@ cpu x86.32? [ ] unit-test ! Peephole optimization if input to ##shl-imm is tagged -3 \ vreg-counter set-global +3 vreg-counter set-global [ V{ @@ -444,7 +445,7 @@ cpu x86.32? [ } test-peephole ] unit-test -3 \ vreg-counter set-global +3 vreg-counter set-global [ V{ @@ -496,7 +497,7 @@ cpu x86.32? [ ] unit-test ! Peephole optimization if both input and output of ##shl-imm -! needs to be tagged +! need to be tagged [ V{ T{ ##peek f 0 D 0 } @@ -511,7 +512,26 @@ cpu x86.32? [ } test-peephole ] unit-test -6 \ vreg-counter set-global +! Peephole optimization if neither input nor output of ##shl-imm need to be tagged +[ + V{ + T{ ##load-integer f 1 100 } + T{ ##shl-imm f 2 1 3 } + T{ ##load-integer f 3 100 } + T{ ##load-integer f 4 100 } + T{ ##store-memory f 2 3 4 0 0 int-rep char } + } +] [ + V{ + T{ ##load-integer f 1 100 } + T{ ##shl-imm f 2 1 3 } + T{ ##load-integer f 3 100 } + T{ ##load-integer f 4 100 } + T{ ##store-memory f 2 3 4 0 0 int-rep char } + } test-peephole +] unit-test + +6 vreg-counter set-global ! Peephole optimization if input to ##sar-imm is tagged [ @@ -529,6 +549,110 @@ cpu x86.32? [ } test-peephole ] unit-test +6 vreg-counter set-global + +! (Lack of) peephole optimization if output of ##sar-imm needs to be tagged +[ + V{ + T{ ##load-integer f 1 100 } + T{ ##sar-imm f 7 1 3 } + T{ ##shl-imm f 2 7 $[ tag-bits get ] } + T{ ##replace f 2 D 0 } + } +] [ + V{ + T{ ##load-integer f 1 100 } + T{ ##sar-imm f 2 1 3 } + T{ ##replace f 2 D 0 } + } test-peephole +] unit-test + +! Peephole optimization if input of ##sar-imm is tagged but output is untagged +! need to be tagged +[ + V{ + T{ ##peek f 0 D 0 } + T{ ##sar-imm f 1 0 $[ 3 tag-bits get + ] } + T{ ##load-integer f 3 100 } + T{ ##load-integer f 4 100 } + T{ ##store-memory f 1 3 4 0 0 int-rep char } + } +] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##sar-imm f 1 0 3 } + T{ ##load-integer f 3 100 } + T{ ##load-integer f 4 100 } + T{ ##store-memory f 1 3 4 0 0 int-rep char } + } test-peephole +] unit-test + +! Peephole optimization if neither input nor output of ##sar-imm need to be tagged +[ + V{ + T{ ##load-integer f 1 100 } + T{ ##sar-imm f 2 1 3 } + T{ ##load-integer f 3 100 } + T{ ##load-integer f 4 100 } + T{ ##store-memory f 2 3 4 0 0 int-rep char } + } +] [ + V{ + T{ ##load-integer f 1 100 } + T{ ##sar-imm f 2 1 3 } + T{ ##load-integer f 3 100 } + T{ ##load-integer f 4 100 } + T{ ##store-memory f 2 3 4 0 0 int-rep char } + } test-peephole +] unit-test + +[ + V{ + T{ ##load-vector f 0 B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } short-8-rep } + T{ ##select-vector f 1 0 0 short-8-rep } + T{ ##sar-imm f 2 1 3 } + T{ ##load-integer f 3 100 } + T{ ##add f 4 2 3 } + T{ ##load-integer f 5 100 } + T{ ##load-integer f 6 100 } + T{ ##store-memory f 4 5 6 0 0 int-rep char } + } +] [ + V{ + T{ ##load-vector f 0 B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } short-8-rep } + T{ ##select-vector f 1 0 0 short-8-rep } + T{ ##sar-imm f 2 1 3 } + T{ ##load-integer f 3 100 } + T{ ##add f 4 2 3 } + T{ ##load-integer f 5 100 } + T{ ##load-integer f 6 100 } + T{ ##store-memory f 4 5 6 0 0 int-rep char } + } test-peephole +] unit-test + +6 vreg-counter set-global + +[ + V{ + T{ ##load-vector f 0 B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } int-4-rep } + T{ ##select-vector f 1 0 0 int-4-rep } + T{ ##sar-imm f 2 1 3 } + T{ ##load-integer f 3 100 } + T{ ##add f 7 2 3 } + T{ ##shl-imm f 4 7 $[ tag-bits get ] } + T{ ##replace f 4 D 0 } + } +] [ + V{ + T{ ##load-vector f 0 B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } int-4-rep } + T{ ##select-vector f 1 0 0 int-4-rep } + T{ ##sar-imm f 2 1 3 } + T{ ##load-integer f 3 100 } + T{ ##add f 4 2 3 } + T{ ##replace f 4 D 0 } + } test-peephole +] unit-test + ! Tag/untag elimination [ V{ @@ -562,7 +686,7 @@ cpu x86.32? [ ! Make sure we don't exceed immediate bounds cpu x86.64? [ - 4 \ vreg-counter set-global + 4 vreg-counter set-global [ V{ @@ -611,7 +735,7 @@ cpu x86.64? [ } test-peephole ] unit-test -4 \ vreg-counter set-global +4 vreg-counter set-global [ V{ @@ -736,17 +860,17 @@ cpu x86.64? [ } test-peephole ] unit-test -4 \ vreg-counter set-global +4 vreg-counter set-global [ V{ - T{ ##peek f 5 D 0 } - T{ ##sar-imm f 0 5 $[ tag-bits get ] } - T{ ##peek f 6 D 1 } - T{ ##sar-imm f 1 6 $[ tag-bits get ] } - T{ ##mul f 2 0 1 } - T{ ##mul-imm f 3 2 -16 } - T{ ##replace f 3 D 0 } + T{ ##peek { dst 0 } { loc D 0 } } + T{ ##peek { dst 1 } { loc D 1 } } + T{ ##sar-imm { dst 5 } { src1 0 } { src2 4 } } + T{ ##sar-imm { dst 6 } { src1 1 } { src2 4 } } + T{ ##mul { dst 2 } { src1 5 } { src2 6 } } + T{ ##mul-imm { dst 3 } { src1 2 } { src2 -16 } } + T{ ##replace { src 3 } { loc D 0 } } } ] [ V{ @@ -759,7 +883,7 @@ cpu x86.64? [ ] unit-test ! Tag/untag elimination for ##not -2 \ vreg-counter set-global +2 vreg-counter set-global [ V{ @@ -774,4 +898,4 @@ cpu x86.64? [ T{ ##not f 1 0 } T{ ##replace f 1 D 0 } } test-peephole -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/cfg/representations/selection/selection.factor b/basis/compiler/cfg/representations/selection/selection.factor index 330e5d8e2a..3d435edc09 100644 --- a/basis/compiler/cfg/representations/selection/selection.factor +++ b/basis/compiler/cfg/representations/selection/selection.factor @@ -12,6 +12,7 @@ compiler.cfg.rpo compiler.cfg.utilities compiler.utilities cpu.architecture ; +FROM: assocs => change-at ; FROM: namespaces => set ; IN: compiler.cfg.representations.selection @@ -56,7 +57,7 @@ SYMBOL: possibilities : possible-reps ( vreg reps -- vreg reps ) { tagged-rep } union 2dup [ tagged-vregs get in? not ] [ { tagged-rep } = ] bi* and - [ drop { tagged-rep int-rep } ] [ ] if ; + [ drop { tagged-rep int-rep } ] when ; : compute-possibilities ( cfg -- ) collect-vreg-reps diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor index c14f4d46e6..f51499d791 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts.factor @@ -37,7 +37,7 @@ M: insn modifies-context? drop f ; [ int-rep next-vreg-rep int-rep next-vreg-rep - \ ##save-context new-insn + ##save-context new-insn ] dip [ save-context-offset ] keep [ insert-nth ] change-instructions drop diff --git a/basis/compiler/cfg/scheduling/scheduling-tests.factor b/basis/compiler/cfg/scheduling/scheduling-tests.factor index b50305c814..1a47bbf62f 100644 --- a/basis/compiler/cfg/scheduling/scheduling-tests.factor +++ b/basis/compiler/cfg/scheduling/scheduling-tests.factor @@ -1,16 +1,9 @@ USING: compiler.cfg.scheduling compiler.cfg.instructions -vocabs.loader namespaces tools.test arrays kernel ; +vocabs.loader namespaces tools.test arrays kernel random +words compiler.units ; IN: compiler.cfg.scheduling.tests -! Recompile compiler.cfg.scheduling with extra tests, -! and see if any errors come up. Back when there were -! errors of this kind, they always surfaced this way. - -t check-scheduling? [ - [ ] [ "compiler.cfg.scheduling" reload ] unit-test - [ ] [ "compiler.cfg.dependence" reload ] unit-test -] with-variable - +! Test split-3-ways [ { } { } diff --git a/basis/compiler/cfg/scheduling/scheduling.factor b/basis/compiler/cfg/scheduling/scheduling.factor index d56b5559ce..05c738d8fd 100644 --- a/basis/compiler/cfg/scheduling/scheduling.factor +++ b/basis/compiler/cfg/scheduling/scheduling.factor @@ -3,8 +3,7 @@ USING: accessors arrays assocs fry kernel locals make math namespaces sequences sets combinators.short-circuit compiler.cfg.def-use compiler.cfg.dependence -compiler.cfg.instructions compiler.cfg.liveness compiler.cfg.rpo -cpu.architecture ; +compiler.cfg.instructions compiler.cfg.rpo cpu.architecture ; IN: compiler.cfg.scheduling ! Instruction scheduling to reduce register pressure, from: @@ -58,6 +57,7 @@ UNION: final-insn ##branch ##dispatch conditional-branch-insn +##safepoint ##epilogue ##return ##callback-outputs ; @@ -81,40 +81,6 @@ conditional-branch-insn [ (reorder) ] V{ } make reverse ] dip 3append ; -ERROR: not-all-instructions-were-scheduled old-bb new-bb ; - -SYMBOL: check-scheduling? -f check-scheduling? set-global - -:: check-instructions ( new-bb old-bb -- ) - new-bb old-bb [ instructions>> ] bi@ - [ [ length ] bi@ = ] [ [ unique ] bi@ = ] 2bi and - [ old-bb new-bb not-all-instructions-were-scheduled ] unless ; - -ERROR: definition-after-usage vregs old-bb new-bb ; - -:: check-usages ( new-bb old-bb -- ) - HS{ } clone :> useds - new-bb instructions>> split-3-ways drop nip - [| insn | - insn uses-vregs [ useds adjoin ] each - insn defs-vregs :> defs-vregs - defs-vregs useds intersects? - [ defs-vregs old-bb new-bb definition-after-usage ] when - ] each ; - -: check-scheduling ( new-bb old-bb -- ) - [ check-instructions ] [ check-usages ] 2bi ; - -: with-scheduling-check ( bb quot: ( bb -- ) -- ) - check-scheduling? get [ - over dup clone - [ call( bb -- ) ] 2dip - check-scheduling - ] [ - call( bb -- ) - ] if ; inline - : number-insns ( insns -- ) [ >>insn# drop ] each-index ; @@ -123,25 +89,12 @@ ERROR: definition-after-usage vregs old-bb new-bb ; : schedule-block ( bb -- ) [ - [ - [ number-insns ] - [ reorder ] - [ clear-numbers ] tri - ] change-instructions drop - ] with-scheduling-check ; - -! Really, instruction scheduling should be aware that there are -! multiple types of registers, but this number is just used -! to decide whether to schedule instructions -: num-registers ( -- x ) int-regs machine-registers at length ; - -: might-spill? ( bb -- ? ) - [ live-in assoc-size ] - [ instructions>> [ defs-vregs length ] map-sum ] bi - + num-registers >= ; + [ number-insns ] + [ reorder ] + [ clear-numbers ] tri + ] change-instructions drop ; : schedule-instructions ( cfg -- cfg' ) dup [ - dup { [ kill-block?>> not ] [ might-spill? ] } 1&& - [ schedule-block ] [ drop ] if + dup kill-block?>> [ drop ] [ schedule-block ] if ] each-basic-block ; diff --git a/basis/compiler/cfg/ssa/construction/construction-tests.factor b/basis/compiler/cfg/ssa/construction/construction-tests.factor index 54b02b7450..a011bf7bec 100644 --- a/basis/compiler/cfg/ssa/construction/construction-tests.factor +++ b/basis/compiler/cfg/ssa/construction/construction-tests.factor @@ -10,6 +10,16 @@ IN: compiler.cfg.ssa.construction.tests 0 vreg-counter set-global 0 basic-block set-global ; +: test-ssa ( -- ) + cfg new 0 get >>entry + dup cfg set + construct-ssa + drop ; + +: clean-up-phis ( insns -- insns' ) + [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ; + +! Test 1 reset-counters V{ @@ -38,12 +48,6 @@ V{ 1 3 edge 2 3 edge -: test-ssa ( -- ) - cfg new 0 get >>entry - dup cfg set - construct-ssa - drop ; - [ ] [ test-ssa ] unit-test [ @@ -69,9 +73,6 @@ V{ } ] [ 2 get instructions>> ] unit-test -: clean-up-phis ( insns -- insns' ) - [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ; - [ V{ T{ ##phi f 6 H{ { 1 4 } { 2 5 } } } @@ -83,6 +84,7 @@ V{ clean-up-phis ] unit-test +! Test 2 reset-counters V{ } 0 test-bb @@ -110,4 +112,89 @@ V{ } 6 test-bb ] [ 4 get instructions>> clean-up-phis -] unit-test \ No newline at end of file +] unit-test + +! Test 3 +reset-counters + +V{ + T{ ##branch } +} 0 test-bb + +V{ + T{ ##load-integer f 3 3 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##load-integer f 3 4 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##branch } +} 3 test-bb + +V{ + T{ ##return } +} 4 test-bb + +0 { 1 2 3 } edges +1 4 edge +2 4 edge +3 4 edge + +[ ] [ test-ssa ] unit-test + +[ V{ } ] [ 4 get instructions>> [ ##phi? ] filter ] unit-test + +! Test 4 +reset-counters + +V{ + T{ ##branch } +} 0 test-bb + +V{ + T{ ##branch } +} 1 test-bb + +V{ + T{ ##load-integer f 0 4 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##load-integer f 0 4 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##branch } +} 4 test-bb + +V{ + T{ ##branch } +} 5 test-bb + +V{ + T{ ##branch } +} 6 test-bb + +V{ + T{ ##return } +} 7 test-bb + +0 { 1 6 } edges +1 { 2 3 4 } edges +2 5 edge +3 5 edge +4 5 edge +5 7 edge +6 7 edge + +[ ] [ test-ssa ] unit-test + +[ V{ } ] [ 5 get instructions>> [ ##phi? ] filter ] unit-test + +[ V{ } ] [ 7 get instructions>> [ ##phi? ] filter ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor index 70e088e500..46f559b54c 100644 --- a/basis/compiler/cfg/ssa/construction/construction.factor +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -1,26 +1,32 @@ ! 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 compiler.cfg.renaming compiler.cfg.renaming.functor compiler.cfg.ssa.construction.tdmsc ; +FROM: assocs => change-at ; FROM: namespaces => set ; IN: compiler.cfg.ssa.construction -! The phi placement algorithm is implemented in -! compiler.cfg.ssa.construction.tdmsc. +! Iterated dominance frontiers are computed using the DJ Graph +! method in compiler.cfg.ssa.construction.tdmsc. ! The renaming algorithm is based on "Practical Improvements to -! the Construction and Destruction of Static Single Assignment Form", -! however we construct pruned SSA, not semi-pruned SSA. +! the Construction and Destruction of Static Single Assignment +! Form". + +! We construct pruned SSA without computing live sets, by +! building a dependency graph for phi instructions, marking the +! transitive closure of a vertex as live if it is referenced by +! some non-phi instruction. Thanks to Cameron Zwarich for the +! trick. ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683 @@ -50,31 +56,32 @@ M: vreg-insn compute-insn-defs [ compute-insn-defs ] with each ] simple-analysis ; -! Maps basic blocks to sequences of vregs -SYMBOL: inserting-phi-nodes +! Maps basic blocks to sequences of ##phi instructions +SYMBOL: inserting-phis -: insert-phi-node-later ( vreg bb -- ) - 2dup live-in key? [ - [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep - inserting-phi-nodes get push-at - ] [ 2drop ] if ; +: insert-phi-later ( vreg bb -- ) + [ predecessors>> over '[ _ ] H{ } map>assoc ##phi new-insn ] keep + inserting-phis get push-at ; -: compute-phi-nodes-for ( vreg bbs -- ) - keys merge-set [ insert-phi-node-later ] with each ; +: compute-phis-for ( vreg bbs -- ) + keys merge-set [ insert-phi-later ] with each ; -: compute-phi-nodes ( -- ) - H{ } clone inserting-phi-nodes set - defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ; +: compute-phis ( -- ) + H{ } clone inserting-phis set + defs-multi get defs get '[ _ at compute-phis-for ] assoc-each ; -: insert-phi-nodes-in ( phis bb -- ) - [ append ] change-instructions drop ; +! Maps vregs to ##phi instructions +SYMBOL: phis -: insert-phi-nodes ( -- ) - inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ; +! Worklist of used vregs, to calculate used phis +SYMBOL: used-vregs +! Maps vregs to renaming stacks SYMBOLS: stacks pushed ; : init-renaming ( -- ) + H{ } clone phis set + used-vregs set H{ } clone stacks set ; : gen-name ( vreg -- vreg' ) @@ -84,8 +91,12 @@ SYMBOLS: stacks pushed ; [ conjoin stacks get push-at ] if ; +: (top-name) ( vreg -- vreg' ) + stacks get at ?last ; + : top-name ( vreg -- vreg' ) - stacks get at last ; + (top-name) + dup [ dup used-vregs get push-front ] when ; RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ] @@ -98,17 +109,22 @@ M: vreg-insn rename-insn [ ssa-rename-insn-defs ] bi ; -M: ##phi rename-insn - ssa-rename-insn-defs ; +: rename-phis ( bb -- ) + inserting-phis get at [ + [ + [ ssa-rename-insn-defs ] + [ dup dst>> phis get set-at ] bi + ] each + ] when* ; : rename-insns ( bb -- ) instructions>> [ rename-insn ] each ; : rename-successor-phi ( phi bb -- ) - swap inputs>> [ top-name ] change-at ; + swap inputs>> [ (top-name) ] change-at ; : rename-successor-phis ( succ bb -- ) - [ inserting-phi-nodes get at ] dip + [ inserting-phis get at ] dip '[ _ rename-successor-phi ] each ; : rename-successors-phis ( bb -- ) @@ -119,26 +135,56 @@ M: ##phi rename-insn : rename-in-block ( bb -- ) H{ } clone pushed set - [ rename-insns ] - [ rename-successors-phis ] - [ - pushed get - [ dom-children [ rename-in-block ] each ] dip - pushed set - ] tri + { + [ rename-phis ] + [ rename-insns ] + [ rename-successors-phis ] + [ + pushed get + [ dom-children [ rename-in-block ] each ] dip + pushed set + ] + } cleave pop-stacks ; : rename ( cfg -- ) init-renaming entry>> rename-in-block ; +! Live phis +SYMBOL: live-phis + +: live-phi? ( ##phi -- ? ) + dst>> live-phis get key? ; + +: compute-live-phis ( -- ) + H{ } clone live-phis set + used-vregs get [ + phis get at [ + [ + dst>> + [ live-phis get conjoin ] + [ phis get delete-at ] + bi + ] + [ inputs>> [ nip used-vregs get push-front ] assoc-each ] bi + ] when* + ] slurp-deque ; + +: insert-phis-in ( phis bb -- ) + [ [ live-phi? ] filter! ] dip + [ append ] change-instructions drop ; + +: insert-phis ( -- ) + inserting-phis get + [ swap insert-phis-in ] assoc-each ; + PRIVATE> : construct-ssa ( cfg -- cfg' ) { - [ compute-live-sets ] [ compute-merge-sets ] - [ compute-defs compute-phi-nodes insert-phi-nodes ] - [ rename ] + [ compute-defs compute-phis ] + [ rename compute-live-phis insert-phis ] [ ] } cleave ; diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor index 9b24c55078..2b80ce9d59 100644 --- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor @@ -24,10 +24,10 @@ V{ } 5 test-bb [ ] [ test-tdmsc ] unit-test -[ V{ 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test -[ V{ 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test -[ V{ } ] [ 0 get 1array merge-set ] unit-test -[ V{ } ] [ 4 get 1array merge-set ] unit-test +[ { 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test +[ { 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test +[ { } ] [ 0 get 1array merge-set ] unit-test +[ { } ] [ 4 get 1array merge-set ] unit-test V{ } 0 test-bb V{ } 1 test-bb @@ -70,5 +70,5 @@ V{ } 7 test-bb [ ] [ test-tdmsc ] unit-test -[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test -[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test +[ { 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test +[ { } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor index 4cdc290c41..75d9d80f37 100644 --- a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor @@ -4,6 +4,7 @@ USING: accessors arrays assocs bit-arrays bit-sets fry hashtables hints kernel locals math namespaces sequences sets compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ; FROM: namespaces => set ; +FROM: assocs => change-at ; IN: compiler.cfg.ssa.construction.tdmsc ! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor index ed2046bdaa..57ec9af42d 100644 --- a/basis/compiler/cfg/ssa/cssa/cssa.factor +++ b/basis/compiler/cfg/ssa/cssa/cssa.factor @@ -23,7 +23,7 @@ IN: compiler.cfg.ssa.cssa :: insert-copy ( bb src rep -- bb dst ) bb src insert-copy? [ rep next-vreg-rep :> dst - bb [ dst src rep ##copy ] add-instructions + bb [ dst src rep ##copy, ] add-instructions bb dst ] [ bb src ] if ; @@ -31,4 +31,4 @@ IN: compiler.cfg.ssa.cssa dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ; : construct-cssa ( cfg -- ) - [ [ convert-phi ] each-phi ] each-basic-block ; \ No newline at end of file + [ [ convert-phi ] each-phi ] each-basic-block ; diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index 197093e5ae..981ce42363 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -9,7 +9,7 @@ compiler.cfg.def-use compiler.cfg.registers compiler.cfg.dominance compiler.cfg.instructions -compiler.cfg.liveness.ssa +compiler.cfg.liveness compiler.cfg.ssa.cssa compiler.cfg.ssa.interference compiler.cfg.ssa.interference.live-ranges @@ -28,9 +28,9 @@ IN: compiler.cfg.ssa.destruction ! 2) Useless ##copy instructions, and all ##phi instructions, ! are eliminated, so the register allocator does not have to ! remove any redundant operations. -! 3) A side effect of running this pass is that SSA liveness -! information is computed, so the register allocator does not -! need to compute it again. +! 3) This pass computes live sets and fills out GC maps with +! compiler.cfg.liveness, so the linear scan register allocator +! does not need to compute liveness again. SYMBOL: leader-map @@ -134,7 +134,7 @@ PRIVATE> dup construct-cssa dup compute-defs dup compute-insns - dup compute-ssa-live-sets + dup compute-live-sets dup compute-live-ranges dup prepare-coalescing process-copies diff --git a/basis/compiler/cfg/ssa/interference/interference-tests.factor b/basis/compiler/cfg/ssa/interference/interference-tests.factor index 36c03bc6af..8648c3ae50 100644 --- a/basis/compiler/cfg/ssa/interference/interference-tests.factor +++ b/basis/compiler/cfg/ssa/interference/interference-tests.factor @@ -1,6 +1,6 @@ USING: accessors compiler.cfg compiler.cfg.debugger compiler.cfg.def-use compiler.cfg.dominance -compiler.cfg.instructions compiler.cfg.liveness.ssa +compiler.cfg.instructions compiler.cfg.liveness compiler.cfg.registers compiler.cfg.predecessors compiler.cfg.comparisons compiler.cfg.ssa.interference compiler.cfg.ssa.interference.private @@ -11,7 +11,7 @@ IN: compiler.cfg.ssa.interference.tests : test-interference ( -- ) cfg new 0 get >>entry - dup compute-ssa-live-sets + dup compute-live-sets dup compute-defs dup compute-insns compute-live-ranges ; diff --git a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor index ffbbf8739f..c3b3d4cf0b 100644 --- a/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor +++ b/basis/compiler/cfg/ssa/interference/live-ranges/live-ranges.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs fry kernel namespaces sequences math arrays compiler.cfg.def-use compiler.cfg.instructions -compiler.cfg.liveness.ssa compiler.cfg.rpo +compiler.cfg.liveness compiler.cfg.rpo compiler.cfg.dominance compiler.cfg ; IN: compiler.cfg.ssa.interference.live-ranges diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor index a35d82bbb5..25759781bd 100644 --- a/basis/compiler/cfg/stacks/finalize/finalize.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -34,17 +34,17 @@ ERROR: bad-peek dst loc ; : insert-peeks ( from to -- ) [ inserting-peeks ] keep - [ dup n>> 0 < [ bad-peek ] [ ##peek ] if ] each-insertion ; + [ dup n>> 0 < [ bad-peek ] [ ##peek, ] if ] each-insertion ; : insert-replaces ( from to -- ) [ inserting-replaces ] keep - [ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ; + [ dup n>> 0 < [ 2drop ] [ ##replace, ] if ] each-insertion ; : visit-edge ( from to -- ) ! If both blocks are subroutine calls, don't bother ! computing anything. 2dup [ kill-block?>> ] both? [ 2drop ] [ - 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make + 2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch, ] V{ } make [ 2drop ] [ insert-basic-block ] if-empty ] if ; diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor index 95feb4c034..958af12587 100644 --- a/basis/compiler/cfg/stacks/local/local.factor +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -45,8 +45,8 @@ M: rs-loc translate-local-loc n>> current-height get r>> - ; : emit-height-changes ( -- ) current-height get - [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ] - [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ; + [ emit-d>> dup 0 = [ drop ] [ ##inc-d, ] if ] + [ emit-r>> dup 0 = [ drop ] [ ##inc-r, ] if ] bi ; : emit-changes ( -- ) ! Insert height and stack changes prior to the last instruction diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor index 7498cddf10..025541e1f3 100644 --- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor @@ -39,13 +39,13 @@ M: ##inc-r visit-insn n>> rs-loc handle-inc ; ERROR: uninitialized-peek insn ; : visit-peek ( ##peek -- ) - dup loc>> [ n>> ] [ class get ] bi ?nth 0 = + dup loc>> [ n>> ] [ class-of get ] bi ?nth 0 = [ uninitialized-peek ] [ drop ] if ; inline M: ##peek visit-insn visit-peek ; : visit-replace ( ##replace -- ) - loc>> [ n>> ] [ class get ] bi + loc>> [ n>> ] [ class-of get ] bi 2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ; M: ##replace visit-insn visit-replace ; @@ -68,7 +68,7 @@ M: insn visit-insn drop ; : finish ( -- pair ) ds-loc get rs-loc get 2array ; : (join-sets) ( seq1 seq2 -- seq ) - 2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ; + 2dup max-length '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ; PRIVATE> @@ -77,5 +77,5 @@ FORWARD-ANALYSIS: uninitialized M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' ) drop [ prepare ] dip visit-block finish ; -M: uninitialized-analysis join-sets ( sets analysis -- pair ) +M: uninitialized-analysis join-sets ( sets bb dfa -- set ) 2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ; diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor index bd8a7cf754..2effc432ac 100644 --- a/basis/compiler/cfg/tco/tco.factor +++ b/basis/compiler/cfg/tco/tco.factor @@ -15,9 +15,10 @@ IN: compiler.cfg.tco : return? ( bb -- ? ) skip-empty-blocks instructions>> { - [ length 2 = ] - [ first ##epilogue? ] - [ second ##return? ] + [ length 3 = ] + [ first ##safepoint? ] + [ second ##epilogue? ] + [ third ##return? ] } 1&& ; : tail-call? ( bb -- ? ) @@ -33,14 +34,15 @@ IN: compiler.cfg.tco '[ instructions>> [ pop* ] [ pop ] [ ] tri - [ [ \ ##epilogue new-insn ] dip push ] - [ _ dip push ] bi + [ [ ##safepoint new-insn ] dip push ] + [ [ ##epilogue new-insn ] dip push ] + [ _ dip push ] tri ] [ successors>> delete-all ] bi ; inline : convert-word-tail-call ( bb -- ) - [ word>> \ ##jump new-insn ] convert-tail-call ; + [ word>> ##jump new-insn ] convert-tail-call ; : loop-tail-call? ( bb -- ? ) instructions>> penultimate @@ -48,7 +50,14 @@ IN: compiler.cfg.tco : convert-loop-tail-call ( bb -- ) ! If a word calls itself, this becomes a loop in the CFG. - [ instructions>> [ pop* ] [ pop* ] [ [ \ ##branch new-insn ] dip push ] tri ] + [ + instructions>> { + [ pop* ] + [ pop* ] + [ [ ##safepoint new-insn ] dip push ] + [ [ ##branch new-insn ] dip push ] + } cleave + ] [ successors>> delete-all ] [ [ cfg get entry>> successors>> first ] dip successors>> push ] tri ; diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor index b2529655bb..cf7a490c9f 100644 --- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor +++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor @@ -23,7 +23,7 @@ IN: compiler.cfg.useless-conditionals : delete-conditional ( bb -- ) [ first skip-empty-blocks 1vector ] change-successors - instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ; + instructions>> [ pop* ] [ [ ##branch new-insn ] dip push ] bi ; : delete-useless-conditionals ( cfg -- cfg' ) dup [ diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 0ca2b2d11c..820871ea05 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -78,4 +78,4 @@ SYMBOL: visited predecessors>> first ; inline : ( dst src -- insn ) - any-rep \ ##copy new-insn ; + any-rep ##copy new-insn ; diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor index 58674602d9..d4d5dbd129 100644 --- a/basis/compiler/cfg/value-numbering/alien/alien.factor +++ b/basis/compiler/cfg/value-numbering/alien/alien.factor @@ -31,7 +31,7 @@ M: ##box-displaced-alien rewrite [ dst>> ] [ [ base>> ] [ base-class>> ] [ displacement>> ] tri ] bi* [ ^^unbox-c-ptr ] dip - ##add + ##add, ] { } make ; : rewrite-unbox-any-c-ptr ( insn -- insn/f ) @@ -82,8 +82,8 @@ M: ##store-memory-imm alien-insn-value src>> ; GENERIC: new-alien-insn ( value base displacement scale offset rep c-type insn -- insn ) -M: ##load-memory-imm new-alien-insn drop \ ##load-memory new-insn ; -M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ; +M: ##load-memory-imm new-alien-insn drop ##load-memory new-insn ; +M: ##store-memory-imm new-alien-insn drop ##store-memory new-insn ; : fuse-displacement ( insn -- insn' ) { diff --git a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor index 8bbacd2f29..b92f3038b2 100644 --- a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor +++ b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor @@ -86,27 +86,27 @@ UNION: general-compare-insn scalar-compare-insn ##test-vector ; : rewrite-boolean-comparison ( insn -- insn ) src1>> vreg>insn { - { [ dup ##compare? ] [ >compare< \ ##compare-branch new-insn ] } - { [ dup ##compare-imm? ] [ >compare< \ ##compare-imm-branch new-insn ] } - { [ dup ##compare-integer? ] [ >compare< \ ##compare-integer-branch new-insn ] } - { [ dup ##compare-integer-imm? ] [ >compare< \ ##compare-integer-imm-branch new-insn ] } - { [ dup ##test? ] [ >compare< \ ##test-branch new-insn ] } - { [ dup ##test-imm? ] [ >compare< \ ##test-imm-branch new-insn ] } - { [ dup ##compare-float-unordered? ] [ >compare< \ ##compare-float-unordered-branch new-insn ] } - { [ dup ##compare-float-ordered? ] [ >compare< \ ##compare-float-ordered-branch new-insn ] } - { [ dup ##test-vector? ] [ >test-vector< \ ##test-vector-branch new-insn ] } + { [ dup ##compare? ] [ >compare< ##compare-branch new-insn ] } + { [ dup ##compare-imm? ] [ >compare< ##compare-imm-branch new-insn ] } + { [ dup ##compare-integer? ] [ >compare< ##compare-integer-branch new-insn ] } + { [ dup ##compare-integer-imm? ] [ >compare< ##compare-integer-imm-branch new-insn ] } + { [ dup ##test? ] [ >compare< ##test-branch new-insn ] } + { [ dup ##test-imm? ] [ >compare< ##test-imm-branch new-insn ] } + { [ dup ##compare-float-unordered? ] [ >compare< ##compare-float-unordered-branch new-insn ] } + { [ dup ##compare-float-ordered? ] [ >compare< ##compare-float-ordered-branch new-insn ] } + { [ dup ##test-vector? ] [ >test-vector< ##test-vector-branch new-insn ] } } cond ; : fold-branch ( ? -- insn ) 0 1 ? basic-block get [ nth 1vector ] change-successors drop - \ ##branch new-insn ; + ##branch new-insn ; : fold-compare-imm-branch ( insn -- insn/f ) evaluate-compare-imm fold-branch ; : >test-branch ( insn -- insn ) - [ src1>> ] [ src1>> ] [ cc>> ] tri \ ##test-branch new-insn ; + [ src1>> ] [ src1>> ] [ cc>> ] tri ##test-branch new-insn ; M: ##compare-imm-branch rewrite { @@ -143,12 +143,12 @@ M: ##test-imm-branch rewrite : >compare-imm-branch ( insn swap? -- insn' ) (>compare-imm-branch) [ vreg>literal ] dip - \ ##compare-imm-branch new-insn ; inline + ##compare-imm-branch new-insn ; inline : >compare-integer-imm-branch ( insn swap? -- insn' ) (>compare-imm-branch) [ vreg>integer ] dip - \ ##compare-integer-imm-branch new-insn ; inline + ##compare-integer-imm-branch new-insn ; inline : evaluate-self-compare ( insn -- ? ) cc>> { cc= cc<= cc>= } member-eq? ; @@ -179,15 +179,15 @@ M: ##compare-integer-branch rewrite : >compare-imm ( insn swap? -- insn' ) (>compare-imm) [ vreg>literal ] dip - next-vreg \ ##compare-imm new-insn ; inline + next-vreg ##compare-imm new-insn ; inline : >compare-integer-imm ( insn swap? -- insn' ) (>compare-imm) [ vreg>integer ] dip - next-vreg \ ##compare-integer-imm new-insn ; inline + next-vreg ##compare-integer-imm new-insn ; inline : >boolean-insn ( insn ? -- insn' ) - [ dst>> ] dip \ ##load-reference new-insn ; + [ dst>> ] dip ##load-reference new-insn ; : rewrite-self-compare ( insn -- insn' ) dup evaluate-self-compare >boolean-insn ; @@ -217,14 +217,14 @@ M: ##compare-integer rewrite : rewrite-redundant-comparison ( insn -- insn' ) [ cc>> ] [ dst>> ] [ src1>> vreg>insn ] tri { - { [ dup ##compare? ] [ >compare< next-vreg \ ##compare new-insn ] } - { [ dup ##compare-imm? ] [ >compare< next-vreg \ ##compare-imm new-insn ] } - { [ dup ##compare-integer? ] [ >compare< next-vreg \ ##compare-integer new-insn ] } - { [ dup ##compare-integer-imm? ] [ >compare< next-vreg \ ##compare-integer-imm new-insn ] } - { [ dup ##test? ] [ >compare< next-vreg \ ##test new-insn ] } - { [ dup ##test-imm? ] [ >compare< next-vreg \ ##test-imm new-insn ] } - { [ dup ##compare-float-unordered? ] [ >compare< next-vreg \ ##compare-float-unordered new-insn ] } - { [ dup ##compare-float-ordered? ] [ >compare< next-vreg \ ##compare-float-ordered new-insn ] } + { [ dup ##compare? ] [ >compare< next-vreg ##compare new-insn ] } + { [ dup ##compare-imm? ] [ >compare< next-vreg ##compare-imm new-insn ] } + { [ dup ##compare-integer? ] [ >compare< next-vreg ##compare-integer new-insn ] } + { [ dup ##compare-integer-imm? ] [ >compare< next-vreg ##compare-integer-imm new-insn ] } + { [ dup ##test? ] [ >compare< next-vreg ##test new-insn ] } + { [ dup ##test-imm? ] [ >compare< next-vreg ##test-imm new-insn ] } + { [ dup ##compare-float-unordered? ] [ >compare< next-vreg ##compare-float-unordered new-insn ] } + { [ dup ##compare-float-ordered? ] [ >compare< next-vreg ##compare-float-ordered new-insn ] } } cond swap cc= eq? [ [ negate-cc ] change-cc ] when ; @@ -243,7 +243,7 @@ M: ##compare-imm rewrite : >test ( insn -- insn' ) { [ dst>> ] [ src1>> ] [ src1>> ] [ cc>> ] [ temp>> ] } cleave - \ ##test new-insn ; + ##test new-insn ; M: ##compare-integer-imm rewrite { @@ -265,18 +265,18 @@ M: ##compare-integer-imm rewrite [ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ] [ cc>> ] bi ; inline : simplify-test-imm ( insn -- insn ) - [ dst>> ] [ (simplify-test-imm) ] [ temp>> ] tri \ ##test-imm new-insn ; inline + [ dst>> ] [ (simplify-test-imm) ] [ temp>> ] tri ##test-imm new-insn ; inline : simplify-test-imm-branch ( insn -- insn ) - (simplify-test-imm) \ ##test-imm-branch new-insn ; inline + (simplify-test-imm) ##test-imm-branch new-insn ; inline : >test-imm ( insn ? -- insn' ) (>compare-imm) [ vreg>integer ] dip next-vreg - \ ##test-imm new-insn ; inline + ##test-imm new-insn ; inline : >test-imm-branch ( insn ? -- insn' ) (>compare-imm-branch) [ vreg>integer ] dip - \ ##test-imm-branch new-insn ; inline + ##test-imm-branch new-insn ; inline M: ##test rewrite { diff --git a/basis/compiler/cfg/value-numbering/folding/folding.factor b/basis/compiler/cfg/value-numbering/folding/folding.factor index 4d79ed5655..9172560d78 100644 --- a/basis/compiler/cfg/value-numbering/folding/folding.factor +++ b/basis/compiler/cfg/value-numbering/folding/folding.factor @@ -24,7 +24,7 @@ M: ##shl-imm binary-constant-fold* drop shift ; : binary-constant-fold ( insn -- insn' ) [ dst>> ] [ [ src1>> vreg>integer ] [ src2>> ] [ ] tri binary-constant-fold* ] bi - \ ##load-integer new-insn ; inline + ##load-integer new-insn ; inline : unary-constant-fold? ( insn -- ? ) src>> vreg>insn ##load-integer? ; inline @@ -36,4 +36,4 @@ M: ##neg unary-constant-fold* drop neg ; : unary-constant-fold ( insn -- insn' ) [ dst>> ] [ [ src>> vreg>integer ] [ ] bi unary-constant-fold* ] bi - \ ##load-integer new-insn ; inline + ##load-integer new-insn ; inline diff --git a/basis/compiler/cfg/value-numbering/math/math.factor b/basis/compiler/cfg/value-numbering/math/math.factor index c2f63692ac..027ec6cb25 100644 --- a/basis/compiler/cfg/value-numbering/math/math.factor +++ b/basis/compiler/cfg/value-numbering/math/math.factor @@ -18,8 +18,8 @@ IN: compiler.cfg.value-numbering.math M: ##tagged>integer rewrite [ dst>> ] [ src>> vreg>insn ] bi { - { [ dup ##load-integer? ] [ val>> tag-fixnum \ ##load-integer new-insn ] } - { [ dup f-insn? ] [ drop \ f type-number \ ##load-integer new-insn ] } + { [ dup ##load-integer? ] [ val>> tag-fixnum ##load-integer new-insn ] } + { [ dup f-insn? ] [ drop \ f type-number ##load-integer new-insn ] } [ 2drop f ] } cond ; @@ -76,14 +76,14 @@ M: ##add-imm rewrite { { [ dup src2>> 0 = ] [ identity ] } { [ dup binary-constant-fold? ] [ binary-constant-fold ] } - { [ dup src1>> vreg>insn ##add-imm? ] [ \ ##add-imm reassociate-arithmetic ] } + { [ dup src1>> vreg>insn ##add-imm? ] [ ##add-imm reassociate-arithmetic ] } [ drop f ] } cond ; : sub-imm>add-imm ( insn -- insn' ) [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic? - \ ##add-imm ?new-insn ; + ##add-imm ?new-insn ; M: ##sub-imm rewrite sub-imm>add-imm ; @@ -92,14 +92,14 @@ M: ##sub-imm rewrite sub-imm>add-imm ; src2>> -1 = ; : mul-to-neg ( insn -- insn' ) - [ dst>> ] [ src1>> ] bi \ ##neg new-insn ; + [ dst>> ] [ src1>> ] bi ##neg new-insn ; ! Convert ##mul-imm 2^X => ##shl-imm X : mul-to-shl? ( insn -- ? ) src2>> power-of-2? ; : mul-to-shl ( insn -- insn' ) - [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ; + [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi ##shl-imm new-insn ; ! Distribution converts ! ##+-imm 2 1 X @@ -135,17 +135,17 @@ M: ##mul-imm rewrite { [ dup binary-constant-fold? ] [ binary-constant-fold ] } { [ dup mul-to-neg? ] [ mul-to-neg ] } { [ dup mul-to-shl? ] [ mul-to-shl ] } - { [ dup src1>> vreg>insn ##mul-imm? ] [ \ ##mul-imm reassociate-arithmetic ] } - { [ dup distribute-over-add? ] [ \ ##add-imm \ ##mul-imm distribute ] } - { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##mul-imm distribute ] } + { [ dup src1>> vreg>insn ##mul-imm? ] [ ##mul-imm reassociate-arithmetic ] } + { [ dup distribute-over-add? ] [ \ ##add-imm, \ ##mul-imm, distribute ] } + { [ dup distribute-over-sub? ] [ \ ##sub-imm, \ ##mul-imm, distribute ] } [ drop f ] } cond ; M: ##and-imm rewrite { { [ dup binary-constant-fold? ] [ binary-constant-fold ] } - { [ dup src1>> vreg>insn ##and-imm? ] [ \ ##and-imm reassociate-bitwise ] } - { [ dup src2>> 0 = ] [ dst>> 0 \ ##load-integer new-insn ] } + { [ dup src1>> vreg>insn ##and-imm? ] [ ##and-imm reassociate-bitwise ] } + { [ dup src2>> 0 = ] [ dst>> 0 ##load-integer new-insn ] } { [ dup src2>> -1 = ] [ identity ] } [ drop f ] } cond ; @@ -153,18 +153,18 @@ M: ##and-imm rewrite M: ##or-imm rewrite { { [ dup src2>> 0 = ] [ identity ] } - { [ dup src2>> -1 = ] [ dst>> -1 \ ##load-integer new-insn ] } + { [ dup src2>> -1 = ] [ dst>> -1 ##load-integer new-insn ] } { [ dup binary-constant-fold? ] [ binary-constant-fold ] } - { [ dup src1>> vreg>insn ##or-imm? ] [ \ ##or-imm reassociate-bitwise ] } + { [ dup src1>> vreg>insn ##or-imm? ] [ ##or-imm reassociate-bitwise ] } [ drop f ] } cond ; M: ##xor-imm rewrite { { [ dup src2>> 0 = ] [ identity ] } - { [ dup src2>> -1 = ] [ [ dst>> ] [ src1>> ] bi \ ##not new-insn ] } + { [ dup src2>> -1 = ] [ [ dst>> ] [ src1>> ] bi ##not new-insn ] } { [ dup binary-constant-fold? ] [ binary-constant-fold ] } - { [ dup src1>> vreg>insn ##xor-imm? ] [ \ ##xor-imm reassociate-bitwise ] } + { [ dup src1>> vreg>insn ##xor-imm? ] [ ##xor-imm reassociate-bitwise ] } [ drop f ] } cond ; @@ -172,9 +172,9 @@ M: ##shl-imm rewrite { { [ dup src2>> 0 = ] [ identity ] } { [ dup binary-constant-fold? ] [ binary-constant-fold ] } - { [ dup src1>> vreg>insn ##shl-imm? ] [ \ ##shl-imm reassociate-shift ] } - { [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] } - { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##shl-imm distribute ] } + { [ dup src1>> vreg>insn ##shl-imm? ] [ ##shl-imm reassociate-shift ] } + { [ dup distribute-over-add? ] [ \ ##add-imm, \ ##shl-imm, distribute ] } + { [ dup distribute-over-sub? ] [ \ ##sub-imm, \ ##shl-imm, distribute ] } [ drop f ] } cond ; @@ -182,7 +182,7 @@ M: ##shr-imm rewrite { { [ dup src2>> 0 = ] [ identity ] } { [ dup binary-constant-fold? ] [ binary-constant-fold ] } - { [ dup src1>> vreg>insn ##shr-imm? ] [ \ ##shr-imm reassociate-shift ] } + { [ dup src1>> vreg>insn ##shr-imm? ] [ ##shr-imm reassociate-shift ] } [ drop f ] } cond ; @@ -190,7 +190,7 @@ M: ##sar-imm rewrite { { [ dup src2>> 0 = ] [ identity ] } { [ dup binary-constant-fold? ] [ binary-constant-fold ] } - { [ dup src1>> vreg>insn ##sar-imm? ] [ \ ##sar-imm reassociate-shift ] } + { [ dup src1>> vreg>insn ##sar-imm? ] [ ##sar-imm reassociate-shift ] } [ drop f ] } cond ; @@ -207,8 +207,8 @@ M: ##sar-imm rewrite M: ##add rewrite { - { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##add-imm f insn>imm-insn ] } - { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##add-imm t insn>imm-insn ] } + { [ dup src2>> vreg-immediate-arithmetic? ] [ ##add-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-arithmetic? ] [ ##add-imm t insn>imm-insn ] } [ drop f ] } cond ; @@ -217,7 +217,7 @@ M: ##add rewrite ! ##sub 2 1 1 => ##load-integer 2 0 : rewrite-subtraction-identity ( insn -- insn' ) - dst>> 0 \ ##load-integer new-insn ; + dst>> 0 ##load-integer new-insn ; ! ##load-integer 1 0 ! ##sub 3 1 2 @@ -227,61 +227,61 @@ M: ##add rewrite src1>> vreg>insn zero-insn? ; : sub-to-neg ( ##sub -- insn ) - [ dst>> ] [ src2>> ] bi \ ##neg new-insn ; + [ dst>> ] [ src2>> ] bi ##neg new-insn ; M: ##sub rewrite { { [ dup sub-to-neg? ] [ sub-to-neg ] } { [ dup diagonal? ] [ rewrite-subtraction-identity ] } - { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##sub-imm f insn>imm-insn ] } + { [ dup src2>> vreg-immediate-arithmetic? ] [ ##sub-imm f insn>imm-insn ] } [ drop f ] } cond ; M: ##mul rewrite { - { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##mul-imm f insn>imm-insn ] } - { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##mul-imm t insn>imm-insn ] } + { [ dup src2>> vreg-immediate-arithmetic? ] [ ##mul-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-arithmetic? ] [ ##mul-imm t insn>imm-insn ] } [ drop f ] } cond ; M: ##and rewrite { { [ dup diagonal? ] [ identity ] } - { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##and-imm f insn>imm-insn ] } - { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##and-imm t insn>imm-insn ] } + { [ dup src2>> vreg-immediate-bitwise? ] [ ##and-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-bitwise? ] [ ##and-imm t insn>imm-insn ] } [ drop f ] } cond ; M: ##or rewrite { { [ dup diagonal? ] [ identity ] } - { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##or-imm f insn>imm-insn ] } - { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##or-imm t insn>imm-insn ] } + { [ dup src2>> vreg-immediate-bitwise? ] [ ##or-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-bitwise? ] [ ##or-imm t insn>imm-insn ] } [ drop f ] } cond ; M: ##xor rewrite { - { [ dup diagonal? ] [ dst>> 0 \ ##load-integer new-insn ] } - { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##xor-imm f insn>imm-insn ] } - { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##xor-imm t insn>imm-insn ] } + { [ dup diagonal? ] [ dst>> 0 ##load-integer new-insn ] } + { [ dup src2>> vreg-immediate-bitwise? ] [ ##xor-imm f insn>imm-insn ] } + { [ dup src1>> vreg-immediate-bitwise? ] [ ##xor-imm t insn>imm-insn ] } [ drop f ] } cond ; M: ##shl rewrite { - { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shl-imm f insn>imm-insn ] } + { [ dup src2>> vreg-immediate-bitwise? ] [ ##shl-imm f insn>imm-insn ] } [ drop f ] } cond ; M: ##shr rewrite { - { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shr-imm f insn>imm-insn ] } + { [ dup src2>> vreg-immediate-bitwise? ] [ ##shr-imm f insn>imm-insn ] } [ drop f ] } cond ; M: ##sar rewrite { - { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##sar-imm f insn>imm-insn ] } + { [ dup src2>> vreg-immediate-bitwise? ] [ ##sar-imm f insn>imm-insn ] } [ drop f ] } cond ; diff --git a/basis/compiler/cfg/value-numbering/misc/misc.factor b/basis/compiler/cfg/value-numbering/misc/misc.factor index 2624b29b61..396d4dd38c 100644 --- a/basis/compiler/cfg/value-numbering/misc/misc.factor +++ b/basis/compiler/cfg/value-numbering/misc/misc.factor @@ -10,5 +10,5 @@ M: ##replace rewrite [ loc>> ] [ src>> vreg>insn ] bi dup literal-insn? [ insn>literal dup immediate-store? - [ swap \ ##replace-imm new-insn ] [ 2drop f ] if + [ swap ##replace-imm new-insn ] [ 2drop f ] if ] [ 2drop f ] if ; diff --git a/basis/compiler/cfg/value-numbering/simd/simd.factor b/basis/compiler/cfg/value-numbering/simd/simd.factor index 84acc95859..c0816e8c57 100644 --- a/basis/compiler/cfg/value-numbering/simd/simd.factor +++ b/basis/compiler/cfg/value-numbering/simd/simd.factor @@ -3,7 +3,7 @@ USING: accessors combinators combinators.short-circuit arrays fry kernel layouts math namespaces sequences cpu.architecture math.bitwise math.order classes generalizations -combinators.smart locals make alien.c-types io.binary grouping +locals make alien.c-types io.binary grouping math.vectors.simd.intrinsics compiler.cfg compiler.cfg.registers @@ -26,7 +26,7 @@ IN: compiler.cfg.value-numbering.simd [ [ dst>> ] [ src>> ] bi* ] [ [ shuffle>> ] bi@ nths ] [ drop rep>> ] - 2tri \ ##shuffle-vector-imm new-insn + 2tri ##shuffle-vector-imm new-insn ] [ 2drop f ] if ; : (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' ) @@ -34,7 +34,7 @@ IN: compiler.cfg.value-numbering.simd : fold-shuffle-vector-imm ( outer inner -- insn' ) [ [ dst>> ] [ shuffle>> ] bi ] [ obj>> ] bi* - (fold-shuffle-vector-imm) \ ##load-reference new-insn ; + (fold-shuffle-vector-imm) ##load-reference new-insn ; M: ##shuffle-vector-imm rewrite dup src>> vreg>insn { @@ -53,7 +53,7 @@ M: ##shuffle-vector-imm rewrite : (fold-scalar>vector) ( insn bytes -- insn' ) [ [ dst>> ] [ rep>> rep-length ] bi ] dip concat - \ ##load-reference new-insn ; + ##load-reference new-insn ; : fold-scalar>vector ( outer inner -- insn' ) over rep>> scalar-value (fold-scalar>vector) ; @@ -68,7 +68,7 @@ M: ##scalar>vector rewrite :: fold-gather-vector-2 ( insn src1 src2 -- insn ) insn dst>> src1 src2 [ insn rep>> scalar-value ] bi@ append - \ ##load-reference new-insn ; + ##load-reference new-insn ; : rewrite-gather-vector-2 ( insn -- insn/f ) dup [ src1>> vreg>insn ] [ src2>> vreg>insn ] bi { @@ -84,9 +84,9 @@ M: ##gather-int-vector-2 rewrite rewrite-gather-vector-2 ; insn dst>> [ src1 src2 src3 src4 - [ insn rep>> scalar-value ] 4 napply - ] B{ } append-outputs-as - \ ##load-reference new-insn ; + [ insn rep>> scalar-value % ] 4 napply + ] B{ } make + ##load-reference new-insn ; : rewrite-gather-vector-4 ( insn -- insn/f ) dup { [ src1>> ] [ src2>> ] [ src3>> ] [ src4>> ] } cleave [ vreg>insn ] 4 napply @@ -101,7 +101,7 @@ M: ##gather-int-vector-4 rewrite rewrite-gather-vector-4 ; : fold-shuffle-vector ( insn src1 src2 -- insn ) [ dst>> ] [ obj>> ] [ obj>> ] tri* - swap nths \ ##load-reference new-insn ; + swap nths ##load-reference new-insn ; M: ##shuffle-vector rewrite dup [ src>> vreg>insn ] [ shuffle>> vreg>insn ] bi @@ -112,7 +112,7 @@ M: ##shuffle-vector rewrite M: ##xor-vector rewrite dup diagonal? - [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ; + [ [ dst>> ] [ rep>> ] bi ##zero-vector new-insn ] [ drop f ] if ; : vector-not? ( insn -- ? ) { @@ -139,7 +139,7 @@ M: ##and-vector rewrite [ src1>> vreg>insn vector-not-src ] [ src2>> ] [ rep>> ] - } cleave \ ##andn-vector new-insn + } cleave ##andn-vector new-insn ] } { [ dup src2>> vreg>insn vector-not? ] [ { @@ -147,7 +147,7 @@ M: ##and-vector rewrite [ src2>> vreg>insn vector-not-src ] [ src1>> ] [ rep>> ] - } cleave \ ##andn-vector new-insn + } cleave ##andn-vector new-insn ] } [ drop f ] } cond ; @@ -159,5 +159,5 @@ M: ##andn-vector rewrite [ src1>> vreg>insn vector-not-src ] [ src2>> ] [ rep>> ] - } cleave \ ##and-vector new-insn + } cleave ##and-vector new-insn ] [ drop f ] if ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 015368cf98..0ed93e4cb5 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -119,12 +119,12 @@ cpu x86.64? [ ! Boundary case [ { - T{ ##load-integer f 0 HEX: 7fffffff } + T{ ##load-integer f 0 0x7fffffff } T{ ##replace f 0 D 0 } } ] [ { - T{ ##load-integer f 0 HEX: 7fffffff } + T{ ##load-integer f 0 0x7fffffff } T{ ##replace f 0 D 0 } } value-numbering-step ] unit-test @@ -1613,7 +1613,7 @@ cpu x86? [ ] unit-test ! Distributive law -2 \ vreg-counter set-global +2 vreg-counter set-global [ { @@ -2024,7 +2024,7 @@ cell 8 = [ { T{ ##peek f 0 D 0 } T{ ##load-integer f 1 -1 } - T{ ##load-integer f 3 HEX: ffffffffffff } + T{ ##load-integer f 3 0xffffffffffff } } ] [ { @@ -2080,21 +2080,24 @@ cell 8 = [ } value-numbering-step ] unit-test - [ - { - T{ ##peek f 0 D 0 } - T{ ##load-integer f 2 2147483647 } - T{ ##add-imm f 3 0 2147483647 } - T{ ##add-imm f 4 3 2147483647 } - } - ] [ - { - T{ ##peek f 0 D 0 } - T{ ##load-integer f 2 2147483647 } - T{ ##add f 3 0 2 } - T{ ##add f 4 3 2 } - } value-numbering-step - ] unit-test + ! PPC ADDI can't hold immediates this big. + cpu ppc? [ + [ + { + T{ ##peek f 0 D 0 } + T{ ##load-integer f 2 2147483647 } + T{ ##add-imm f 3 0 2147483647 } + T{ ##add-imm f 4 3 2147483647 } + } + ] [ + { + T{ ##peek f 0 D 0 } + T{ ##load-integer f 2 2147483647 } + T{ ##add f 3 0 2 } + T{ ##add f 4 3 2 } + } value-numbering-step + ] unit-test + ] unless ] when [ diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor index a02462dc08..c81164bff2 100644 --- a/basis/compiler/codegen/codegen-tests.factor +++ b/basis/compiler/codegen/codegen-tests.factor @@ -1,5 +1,6 @@ -USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make -compiler.constants words ; +USING: compiler.codegen compiler.codegen.labels +compiler.codegen.relocation tools.test cpu.architecture math +kernel make compiler.constants words ; IN: compiler.codegen.tests [ ] [ [ ] with-fixup drop ] unit-test diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 6e7e2e0fab..3d6ab00d49 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -1,10 +1,11 @@ -! Copyright (C) 2008, 2010 Slava Pestov. +! Copyright (C) 2008, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces make math math.order math.parser sequences -accessors kernel layouts assocs words summary arrays combinators -classes.algebra sets continuations.private fry cpu.architecture -classes classes.struct locals slots parser generic.parser -strings quotations hashtables +USING: byte-arrays namespaces make math math.order math.parser +sequences accessors kernel layouts assocs words summary arrays +combinators sets continuations.private fry +cpu.architecture classes classes.struct locals slots parser +generic.parser strings quotations hashtables +sequences.generalizations compiler.constants compiler.cfg compiler.cfg.linearization @@ -13,7 +14,9 @@ compiler.cfg.comparisons compiler.cfg.stack-frame compiler.cfg.registers compiler.cfg.builder -compiler.codegen.fixup +compiler.codegen.gc-maps +compiler.codegen.labels +compiler.codegen.relocation compiler.utilities ; FROM: namespaces => set ; IN: compiler.codegen @@ -75,12 +78,38 @@ M: ##dispatch generate-insn [ lookup-label resolve-label ] [ instructions>> [ - [ class insn-counts get inc-at ] + [ class-of insn-counts get-global inc-at ] [ generate-insn ] bi ] each ] tri ; +: init-fixup ( -- ) + V{ } clone label-table set + V{ } clone binary-literal-table set ; + +: check-fixup ( seq -- ) + length data-alignment get mod 0 assert= ; + +: with-fixup ( quot -- code ) + '[ + init-relocation + init-gc-maps + init-fixup + [ + @ + emit-binary-literals + emit-gc-maps + label-table [ compute-labels ] change + parameter-table get >array + literal-table get >array + relocation-table get >byte-array + label-table get + ] B{ } make + dup check-fixup + cfg get [ stack-frame>> [ total-size>> ] [ 0 ] if* ] [ 0 ] if* + ] call 6 narray ; inline + : generate ( cfg -- code ) [ H{ } clone labels set @@ -133,6 +162,7 @@ CODEGEN: ##inc-r %inc-r CODEGEN: ##call %call CODEGEN: ##jump %jump CODEGEN: ##return %return +CODEGEN: ##safepoint %safepoint CODEGEN: ##slot %slot CODEGEN: ##slot-imm %slot-imm CODEGEN: ##set-slot %set-slot @@ -195,6 +225,7 @@ CODEGEN: ##unpack-vector-tail %unpack-vector-tail CODEGEN: ##integer>float-vector %integer>float-vector CODEGEN: ##float>integer-vector %float>integer-vector CODEGEN: ##compare-vector %compare-vector +CODEGEN: ##move-vector-mask %move-vector-mask CODEGEN: ##test-vector %test-vector CODEGEN: ##add-vector %add-vector CODEGEN: ##saturated-add-vector %saturated-add-vector diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor deleted file mode 100644 index b4ef317b67..0000000000 --- a/basis/compiler/codegen/fixup/fixup.factor +++ /dev/null @@ -1,238 +0,0 @@ -! Copyright (C) 2007, 2010 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays bit-arrays byte-arrays byte-vectors generic assocs -hashtables io.binary kernel kernel.private math namespaces make -sequences words quotations strings alien.accessors alien.strings -layouts system combinators math.bitwise math.order -combinators.short-circuit combinators.smart accessors growable -fry memoize compiler.constants compiler.cfg.instructions -cpu.architecture ; -IN: compiler.codegen.fixup - -! Utilities -: push-uint ( value vector -- ) - [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri - swap set-alien-unsigned-4 ; - -! Parameter table -SYMBOL: parameter-table - -: add-parameter ( obj -- ) parameter-table get push ; - -! Literal table -SYMBOL: literal-table - -: add-literal ( obj -- ) literal-table get push ; - -! Labels -SYMBOL: label-table - -TUPLE: label offset ; - -: