diff --git a/Makefile b/Makefile old mode 100644 new mode 100755 index db99120a77..18cb7d15c7 --- a/Makefile +++ b/Makefile @@ -1,4 +1,5 @@ CC = gcc +CPP = g++ AR = ar LD = ld @@ -10,14 +11,15 @@ VERSION = 0.92 BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib CFLAGS = -Wall -FFI_TEST_CFLAGS = -fPIC ifdef DEBUG - CFLAGS += -g + CFLAGS += -g -DFACTOR_DEBUG else - CFLAGS += -O3 $(SITE_CFLAGS) + CFLAGS += -O3 endif +CFLAGS += $(SITE_CFLAGS) + ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) ifdef CONFIG @@ -26,25 +28,36 @@ endif DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/alien.o \ + vm/arrays.o \ vm/bignum.o \ + vm/booleans.o \ + vm/byte_arrays.o \ vm/callstack.o \ vm/code_block.o \ vm/code_gc.o \ vm/code_heap.o \ + vm/contexts.o \ vm/data_gc.o \ vm/data_heap.o \ vm/debug.o \ + vm/dispatch.o \ vm/errors.o \ vm/factor.o \ vm/image.o \ + vm/inline_cache.o \ vm/io.o \ + vm/jit.o \ + vm/local_roots.o \ vm/math.o \ vm/primitives.o \ vm/profiler.o \ vm/quotations.o \ vm/run.o \ - vm/types.o \ - vm/utilities.o + vm/strings.o \ + vm/tuples.o \ + vm/utilities.o \ + vm/words.o \ + vm/write_barrier.o EXE_OBJS = $(PLAF_EXE_OBJS) @@ -152,12 +165,12 @@ macosx.app: factor $(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS) - $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ + $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) $(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS) - $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ + $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS) $(TEST_LIBRARY): vm/ffi_test.o @@ -165,7 +178,13 @@ $(TEST_LIBRARY): vm/ffi_test.o clean: rm -f vm/*.o - rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib + rm -f factor.dll + rm -f libfactor.* + rm -f libfactor-ffi-test.* + rm -f Factor.app/Contents/Frameworks/libfactor.dylib + +tags: + etags vm/*.{cpp,hpp,mm,S,c} vm/resources.o: $(WINDRES) vm/factor.rs vm/resources.o @@ -176,10 +195,15 @@ vm/ffi_test.o: vm/ffi_test.c .c.o: $(CC) -c $(CFLAGS) -o $@ $< +.cpp.o: + $(CPP) -c $(CFLAGS) -o $@ $< + .S.o: $(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $< -.m.o: - $(CC) -c $(CFLAGS) -o $@ $< - -.PHONY: factor +.mm.o: + $(CPP) -c $(CFLAGS) -o $@ $< + +.PHONY: factor tags clean + +.SUFFIXES: .mm diff --git a/README.txt b/README.txt index c0d56dfa09..a33a85b218 100755 --- a/README.txt +++ b/README.txt @@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself. * Compiling the Factor VM -The Factor runtime is written in GNU C99, and is built with GNU make and -gcc. - Factor supports various platforms. For an up-to-date list, see . -Factor requires gcc 3.4 or later. - -On x86, Factor /will not/ build using gcc 3.3 or earlier. - -If you are using gcc 4.3, you might get an unusable Factor binary unless -you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line -arguments for make. +The Factor VM is written in C++ and uses GNU extensions. When compiling +with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor +uses std::tr1::unordered_map which is shipped as part of GCC. Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. * Bootstrapping the Factor image -Once you have compiled the Factor runtime, you must bootstrap the Factor +Once you have compiled the Factor VM, you must bootstrap the Factor system using the image that corresponds to your CPU architecture. Boot images can be obtained from . @@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter: Then bootstrap with the following switches: - ./factor -i=boot..image -ui-backend=x11 -ui-text-backend=pango + ./factor -i=boot..image -ui-backend=x11 Now if $DISPLAY is set, running ./factor will start the UI. @@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener: The Factor source tree is organized as follows: build-support/ - scripts used for compiling Factor - vm/ - sources for the Factor VM, written in C + vm/ - Factor VM core/ - Factor core library basis/ - Factor basis library, compiler, tools extra/ - more libraries and applications diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor index 9cc05b4159..f9fdce806f 100644 --- a/basis/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ; ] when* ; : init-alarms ( -- ) - alarms global [ cancel-alarms ] change-at + alarms [ cancel-alarms ] change-global [ alarm-thread-loop t ] "Alarms" spawn-server alarm-thread set-global ; diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index 6a182f8dbf..15e67bf0fe 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays alien.c-types alien.structs -sequences math kernel namespaces fry libc cpu.architecture ; +USING: alien alien.strings alien.c-types alien.accessors alien.structs +arrays words sequences math kernel namespaces fry libc cpu.architecture +io.encodings.utf8 io.encodings.utf16n ; IN: alien.arrays UNION: value-type array struct-type ; @@ -38,3 +39,61 @@ M: value-type c-type-getter M: value-type c-type-setter ( type -- quot ) [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri '[ @ swap @ _ memcpy ] ; + +PREDICATE: string-type < pair + first2 [ "char*" = ] [ word? ] bi* and ; + +M: string-type c-type ; + +M: string-type c-type-class + drop object ; + +M: string-type heap-size + drop "void*" heap-size ; + +M: string-type c-type-align + drop "void*" c-type-align ; + +M: string-type c-type-stack-align? + drop "void*" c-type-stack-align? ; + +M: string-type unbox-parameter + drop "void*" unbox-parameter ; + +M: string-type unbox-return + drop "void*" unbox-return ; + +M: string-type box-parameter + drop "void*" box-parameter ; + +M: string-type box-return + drop "void*" box-return ; + +M: string-type stack-size + drop "void*" stack-size ; + +M: string-type c-type-reg-class + drop int-regs ; + +M: string-type c-type-boxer + drop "void*" c-type-boxer ; + +M: string-type c-type-unboxer + drop "void*" c-type-unboxer ; + +M: string-type c-type-boxer-quot + second '[ _ alien>string ] ; + +M: string-type c-type-unboxer-quot + second '[ _ string>alien ] ; + +M: string-type c-type-getter + drop [ alien-cell ] ; + +M: string-type c-type-setter + drop [ set-alien-cell ] ; + +{ "char*" utf8 } "char*" typedef +"char*" "uchar*" typedef +{ "char*" utf16n } "wchar_t*" typedef + diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index 46afc05e2d..c9c1ecd0e5 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ IN: alien.c-types USING: alien help.syntax help.markup libc kernel.private -byte-arrays math strings hashtables alien.syntax -debugger destructors ; +byte-arrays math strings hashtables alien.syntax alien.strings sequences +io.encodings.string debugger destructors ; HELP: { $values { "type" hashtable } } @@ -114,6 +114,38 @@ HELP: define-out { $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." } ; +{ string>alien alien>string malloc-string } related-words + +HELP: malloc-string +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } } +{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." } +{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } +{ $errors "Throws an error if one of the following conditions occurs:" + { $list + "the string contains null code points" + "the string contains characters not representable using the encoding specified" + "memory allocation fails" + } +} ; + +ARTICLE: "c-strings" "C strings" +"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." +$nl +"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function." +$nl +"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." +$nl +"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array." +$nl +"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" +{ $subsection string>alien } +{ $subsection malloc-string } +"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." +$nl +"A word to read strings from arbitrary addresses:" +{ $subsection alien>string } +"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; + ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector" "The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data." $nl diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index dc35f8bbb0..6067c90f2d 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -2,9 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting -math.parser cpu.architecture alien alien.accessors quotations -layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations fry classes ; +math.parser 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 ; IN: alien.c-types DEFER: @@ -213,6 +214,15 @@ M: f byte-length drop 0 ; : memory>byte-array ( alien len -- byte-array ) [ nip (byte-array) dup ] 2keep memcpy ; +: 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 ; + : byte-array>memory ( byte-array base -- ) swap dup byte-length memcpy ; @@ -399,10 +409,10 @@ CONSTANT: primitive-types "uchar" define-primitive-type - [ alien-unsigned-4 zero? not ] >>getter - [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter - 4 >>size - 4 >>align + [ alien-unsigned-1 zero? not ] >>getter + [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter + 1 >>size + 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer "bool" define-primitive-type diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor old mode 100644 new mode 100755 index c555061e58..eac7655c38 --- a/basis/alien/libraries/libraries-docs.factor +++ b/basis/alien/libraries/libraries-docs.factor @@ -15,7 +15,7 @@ HELP: libraries { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ; HELP: library -{ $values { "name" "a string" } { "library" "a hashtable" } } +{ $values { "name" "a string" } { "library" assoc } } { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:" { $list { { $snippet "name" } " - the full path of the C library binary" } diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor old mode 100644 new mode 100755 index 3fcc15974c..0b39bedadd --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -1,8 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien assocs io.backend kernel namespaces ; +USING: accessors alien alien.strings assocs io.backend kernel namespaces ; IN: alien.libraries +: dlopen ( path -- dll ) native-string>alien (dlopen) ; + +: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ; + SYMBOL: libraries libraries [ H{ } clone ] initialize @@ -18,4 +22,4 @@ TUPLE: library path abi dll ; library dup [ dll>> ] when ; : add-library ( name path abi -- ) - swap libraries get set-at ; + swap libraries get set-at ; \ No newline at end of file diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 4da06ec4c9..b72c79e478 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -15,7 +15,7 @@ IN: alien.remote-control "void" { "long" } "cdecl" [ sleep ] alien-callback ; : ?callback ( word -- alien ) - dup optimized>> [ execute ] [ drop f ] if ; inline + dup optimized? [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) \ eval-callback ?callback 16 setenv diff --git a/basis/alien/strings/strings-docs.factor b/basis/alien/strings/strings-docs.factor deleted file mode 100644 index 19c29e613e..0000000000 --- a/basis/alien/strings/strings-docs.factor +++ /dev/null @@ -1,52 +0,0 @@ -USING: help.markup help.syntax strings byte-arrays alien libc -debugger io.encodings.string sequences ; -IN: alien.strings - -HELP: string>alien -{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } -{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." } -{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ; - -{ string>alien alien>string malloc-string } related-words - -HELP: alien>string -{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } } -{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ; - -HELP: malloc-string -{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } } -{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." } -{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if one of the following conditions occurs:" - { $list - "the string contains null code points" - "the string contains characters not representable using the encoding specified" - "memory allocation fails" - } -} ; - -HELP: string>symbol -{ $values { "str" string } { "alien" alien } } -{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory." -$nl -"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ; - -ARTICLE: "c-strings" "C strings" -"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." -$nl -"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function." -$nl -"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." -$nl -"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array." -$nl -"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" -{ $subsection string>alien } -{ $subsection malloc-string } -"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." -$nl -"A word to read strings from arbitrary addresses:" -{ $subsection alien>string } -"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; - -ABOUT: "c-strings" diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor deleted file mode 100644 index e9053cd5c1..0000000000 --- a/basis/alien/strings/strings.factor +++ /dev/null @@ -1,109 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays sequences kernel accessors math alien.accessors -alien.c-types byte-arrays words io io.encodings -io.encodings.utf8 io.streams.byte-array io.streams.memory system -alien strings cpu.architecture fry vocabs.loader combinators ; -IN: alien.strings - -GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) - -M: c-ptr alien>string - [ ] [ ] bi* - "\0" swap stream-read-until drop ; - -M: f alien>string - drop ; - -ERROR: invalid-c-string string ; - -: check-string ( string -- ) - 0 over memq? [ invalid-c-string ] [ drop ] if ; - -GENERIC# string>alien 1 ( string encoding -- byte-array ) - -M: c-ptr string>alien drop ; - -M: string string>alien - over check-string - - [ stream-write ] - [ 0 swap stream-write1 ] - [ stream>> >byte-array ] - tri ; - -: malloc-string ( string encoding -- alien ) - string>alien malloc-byte-array ; - -PREDICATE: string-type < pair - first2 [ "char*" = ] [ word? ] bi* and ; - -M: string-type c-type ; - -M: string-type c-type-class - drop object ; - -M: string-type heap-size - drop "void*" heap-size ; - -M: string-type c-type-align - drop "void*" c-type-align ; - -M: string-type c-type-stack-align? - drop "void*" c-type-stack-align? ; - -M: string-type unbox-parameter - drop "void*" unbox-parameter ; - -M: string-type unbox-return - drop "void*" unbox-return ; - -M: string-type box-parameter - drop "void*" box-parameter ; - -M: string-type box-return - drop "void*" box-return ; - -M: string-type stack-size - drop "void*" stack-size ; - -M: string-type c-type-reg-class - drop int-regs ; - -M: string-type c-type-boxer - drop "void*" c-type-boxer ; - -M: string-type c-type-unboxer - drop "void*" c-type-unboxer ; - -M: string-type c-type-boxer-quot - second '[ _ alien>string ] ; - -M: string-type c-type-unboxer-quot - second '[ _ string>alien ] ; - -M: string-type c-type-getter - drop [ alien-cell ] ; - -M: string-type c-type-setter - drop [ set-alien-cell ] ; - -HOOK: alien>native-string os ( alien -- string ) - -HOOK: native-string>alien os ( string -- alien ) - -: dll-path ( dll -- string ) - path>> alien>native-string ; - -: string>symbol ( str -- alien ) - dup string? - [ native-string>alien ] - [ [ native-string>alien ] map ] if ; - -{ "char*" utf8 } "char*" typedef -"char*" "uchar*" typedef - -{ - { [ os windows? ] [ "alien.strings.windows" require ] } - { [ os unix? ] [ "alien.strings.unix" require ] } -} cond diff --git a/basis/alien/strings/unix/summary.txt b/basis/alien/strings/unix/summary.txt deleted file mode 100644 index 27e7f4cfb1..0000000000 --- a/basis/alien/strings/unix/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Default string encoding on Unix diff --git a/basis/alien/strings/unix/unix.factor b/basis/alien/strings/unix/unix.factor deleted file mode 100644 index a7b1467344..0000000000 --- a/basis/alien/strings/unix/unix.factor +++ /dev/null @@ -1,8 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.strings io.encodings.utf8 system ; -IN: alien.strings.unix - -M: unix alien>native-string utf8 alien>string ; - -M: unix native-string>alien utf8 string>alien ; diff --git a/basis/alien/strings/windows/summary.txt b/basis/alien/strings/windows/summary.txt deleted file mode 100644 index 42bffbb300..0000000000 --- a/basis/alien/strings/windows/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Default string encoding on Windows diff --git a/basis/alien/strings/windows/windows.factor b/basis/alien/strings/windows/windows.factor deleted file mode 100644 index 55c69246de..0000000000 --- a/basis/alien/strings/windows/windows.factor +++ /dev/null @@ -1,13 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.strings alien.c-types io.encodings.utf8 -io.encodings.utf16n system ; -IN: alien.strings.windows - -M: windows alien>native-string utf16n alien>string ; - -M: wince native-string>alien utf16n string>alien ; - -M: winnt native-string>alien utf8 string>alien ; - -{ "char*" utf16n } "wchar_t*" typedef diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor old mode 100644 new mode 100755 index 89a0ed86fe..3aefdec29f --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -5,7 +5,7 @@ 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 -io.encodings.string libc splitting math.parser +io.encodings.string libc splitting math.parser memory compiler.units math.order compiler.tree.builder compiler.tree.optimizer compiler.cfg.optimizer ; IN: bootstrap.compiler @@ -23,10 +23,13 @@ IN: bootstrap.compiler "cpu." cpu name>> append require -enable-compiler +enable-optimizer + +! Push all tuple layouts to tenured space to improve method caching +gc : compile-unoptimized ( words -- ) - [ optimized>> not ] filter compile ; + [ optimized? not ] filter compile ; nl "Compiling..." write flush @@ -38,7 +41,7 @@ nl ! which are also quick to compile are replaced by ! compiled definitions as soon as possible. { - roll -roll declare not + not array? hashtable? vector? tuple? sbuf? tombstone? diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 504afae018..92d75604e0 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -3,14 +3,13 @@ USING: alien arrays byte-arrays generic assocs hashtables assocs hashtables.private io io.binary io.files io.encodings.binary io.pathnames kernel kernel.private math namespaces make parser -prettyprint sequences sequences.private strings sbufs -vectors words quotations assocs system layouts splitting -grouping growable classes classes.builtin classes.tuple -classes.tuple.private words.private vocabs -vocabs.loader source-files definitions debugger -quotations.private sequences.private combinators -math.order math.private accessors -slots.private compiler.units fry ; +prettyprint sequences sequences.private strings sbufs vectors words +quotations assocs system layouts splitting grouping growable classes +classes.builtin classes.tuple classes.tuple.private vocabs +vocabs.loader source-files definitions debugger quotations.private +sequences.private combinators math.order math.private accessors +slots.private generic.single.private compiler.units compiler.constants +fry bootstrap.image.syntax ; IN: bootstrap.image : arch ( os cpu -- arch ) @@ -53,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? ) M: integer (eql?) = ; +M: float (eql?) + over float? [ fp-bitwise= ] [ 2drop f ] if ; + M: sequence (eql?) over sequence? [ 2dup [ length ] bi@ = @@ -94,13 +96,25 @@ CONSTANT: -1-offset 9 SYMBOL: sub-primitives -: make-jit ( quot rc rt offset -- quad ) - [ [ call( -- ) ] { } make ] 3dip 4array ; +SYMBOL: jit-relocations -: jit-define ( quot rc rt offset name -- ) +: compute-offset ( rc -- offset ) + [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ; + +: jit-rel ( rc rt -- ) + over compute-offset 3array jit-relocations get push-all ; + +: make-jit ( quot -- jit-data ) + [ + V{ } clone jit-relocations set + call( -- ) + jit-relocations get >array + ] B{ } make prefix ; + +: jit-define ( quot name -- ) [ make-jit ] dip set ; -: define-sub-primitive ( quot rc rt offset word -- ) +: define-sub-primitive ( quot word -- ) [ make-jit ] dip sub-primitives get set-at ; ! The image being constructed; a vector of word-size integers @@ -112,72 +126,59 @@ SYMBOL: big-endian ! Bootstrap architecture name SYMBOL: architecture -! Bootstrap global namesapce -SYMBOL: bootstrap-global +RESET ! Boot quotation, set in stage1.factor -SYMBOL: bootstrap-boot-quot +USERENV: bootstrap-boot-quot 20 + +! Bootstrap global namesapce +USERENV: bootstrap-global 21 ! JIT parameters -SYMBOL: jit-code-format -SYMBOL: jit-prolog -SYMBOL: jit-primitive-word -SYMBOL: jit-primitive -SYMBOL: jit-word-jump -SYMBOL: jit-word-call -SYMBOL: jit-push-immediate -SYMBOL: jit-if-word -SYMBOL: jit-if-1 -SYMBOL: jit-if-2 -SYMBOL: jit-dispatch-word -SYMBOL: jit-dispatch -SYMBOL: jit-dip-word -SYMBOL: jit-dip -SYMBOL: jit-2dip-word -SYMBOL: jit-2dip -SYMBOL: jit-3dip-word -SYMBOL: jit-3dip -SYMBOL: jit-epilog -SYMBOL: jit-return -SYMBOL: jit-profiling -SYMBOL: jit-declare-word -SYMBOL: jit-save-stack +USERENV: jit-prolog 23 +USERENV: jit-primitive-word 24 +USERENV: jit-primitive 25 +USERENV: jit-word-jump 26 +USERENV: jit-word-call 27 +USERENV: jit-word-special 28 +USERENV: jit-if-word 29 +USERENV: jit-if 30 +USERENV: jit-epilog 31 +USERENV: jit-return 32 +USERENV: jit-profiling 33 +USERENV: jit-push-immediate 34 +USERENV: jit-dip-word 35 +USERENV: jit-dip 36 +USERENV: jit-2dip-word 37 +USERENV: jit-2dip 38 +USERENV: jit-3dip-word 39 +USERENV: jit-3dip 40 +USERENV: jit-execute-word 41 +USERENV: jit-execute-jump 42 +USERENV: jit-execute-call 43 + +! PIC stubs +USERENV: pic-load 47 +USERENV: pic-tag 48 +USERENV: pic-hi-tag 49 +USERENV: pic-tuple 50 +USERENV: pic-hi-tag-tuple 51 +USERENV: pic-check-tag 52 +USERENV: pic-check 53 +USERENV: pic-hit 54 +USERENV: pic-miss-word 55 +USERENV: pic-miss-tail-word 56 + +! Megamorphic dispatch +USERENV: mega-lookup 57 +USERENV: mega-lookup-word 58 +USERENV: mega-miss-word 59 ! Default definition for undefined words -SYMBOL: undefined-quot - -: userenvs ( -- assoc ) - H{ - { bootstrap-boot-quot 20 } - { bootstrap-global 21 } - { jit-code-format 22 } - { jit-prolog 23 } - { jit-primitive-word 24 } - { jit-primitive 25 } - { jit-word-jump 26 } - { jit-word-call 27 } - { jit-if-word 28 } - { jit-if-1 29 } - { jit-if-2 30 } - { jit-dispatch-word 31 } - { jit-dispatch 32 } - { jit-epilog 33 } - { jit-return 34 } - { jit-profiling 35 } - { jit-push-immediate 36 } - { jit-declare-word 42 } - { jit-save-stack 43 } - { jit-dip-word 44 } - { jit-dip 45 } - { jit-2dip-word 46 } - { jit-2dip 47 } - { jit-3dip-word 48 } - { jit-3dip 49 } - { undefined-quot 60 } - } ; inline +USERENV: undefined-quot 60 : userenv-offset ( symbol -- n ) - userenvs at header-size + ; + userenvs get at header-size + ; : emit ( cell -- ) image get push ; @@ -205,8 +206,8 @@ SYMBOL: undefined-quot : emit-fixnum ( n -- ) tag-fixnum emit ; -: emit-object ( header tag quot -- addr ) - swap here-as [ swap tag-fixnum emit call align-here ] dip ; +: emit-object ( class quot -- addr ) + over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ; inline ! Write an object to the image. @@ -251,7 +252,7 @@ GENERIC: ' ( obj -- ptr ) M: bignum ' [ - bignum tag-number dup [ emit-bignum ] emit-object + bignum [ emit-bignum ] emit-object ] cache-object ; ! Fixnums @@ -274,7 +275,7 @@ M: fake-bignum ' n>> tag-fixnum ; M: float ' [ - float tag-number dup [ + float [ align-here double>bits emit-64 ] emit-object ] cache-object ; @@ -309,7 +310,8 @@ M: f ' [ vocabulary>> , ] [ def>> , ] [ props>> , ] - [ drop f , ] + [ pic-def>> , ] + [ pic-tail-def>> , ] [ drop 0 , ] ! count [ word-sub-primitive , ] [ drop 0 , ] ! xt @@ -318,8 +320,7 @@ M: f ' } cleave ] { } make [ ' ] map ] bi - \ word type-number object tag-number - [ emit-seq ] emit-object + \ word [ emit-seq ] emit-object ] keep put-object ; : word-error ( word msg -- * ) @@ -340,8 +341,7 @@ M: word ' ; ! Wrappers M: wrapper ' - wrapped>> ' wrapper type-number object tag-number - [ emit ] emit-object ; + wrapped>> ' wrapper [ emit ] emit-object ; ! Strings : native> ( object -- object ) @@ -370,7 +370,7 @@ M: wrapper ' : emit-string ( string -- ptr ) [ length ] [ extended-part ' ] [ ] tri - string type-number object tag-number [ + string [ [ emit-fixnum ] [ emit ] [ f ' emit ascii-part pad-bytes emit-bytes ] @@ -387,12 +387,11 @@ M: string ' : emit-dummy-array ( obj type -- ptr ) [ assert-empty ] [ - type-number object tag-number [ 0 emit-fixnum ] emit-object ] bi* ; M: byte-array ' - byte-array type-number object tag-number [ + byte-array [ dup length emit-fixnum pad-bytes emit-bytes ] emit-object ; @@ -406,7 +405,7 @@ ERROR: tuple-removed class ; : (emit-tuple) ( tuple -- pointer ) [ tuple-slots ] [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map - tuple type-number dup [ emit-seq ] emit-object ; + tuple [ emit-seq ] emit-object ; : emit-tuple ( tuple -- pointer ) dup class name>> "tombstone" = @@ -421,8 +420,7 @@ M: tombstone ' ! Arrays : emit-array ( array -- offset ) - [ ' ] map array type-number object tag-number - [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; + [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ; M: array ' emit-array ; @@ -448,7 +446,7 @@ M: tuple-layout-array ' M: quotation ' [ array>> ' - quotation type-number object tag-number [ + quotation [ emit ! array f ' emit ! compiled f ' emit ! cached-effect @@ -472,47 +470,23 @@ M: quotation ' 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 - bootstrap-global set - bootstrap-global emit-userenv ; - -: emit-boot-quot ( -- ) - bootstrap-boot-quot emit-userenv ; + bootstrap-global set ; : emit-jit-data ( -- ) \ if jit-if-word set - \ dispatch jit-dispatch-word set \ do-primitive jit-primitive-word set - \ declare jit-declare-word set \ dip jit-dip-word set \ 2dip jit-2dip-word set \ 3dip jit-3dip-word set - [ undefined ] undefined-quot set - { - jit-code-format - jit-prolog - jit-primitive-word - jit-primitive - jit-word-jump - jit-word-call - jit-push-immediate - jit-if-word - jit-if-1 - jit-if-2 - jit-dispatch-word - jit-dispatch - jit-dip-word - jit-dip - jit-2dip-word - jit-2dip - jit-3dip-word - jit-3dip - jit-epilog - jit-return - jit-profiling - jit-declare-word - jit-save-stack - undefined-quot - } [ emit-userenv ] each ; + \ (execute) jit-execute-word set + \ inline-cache-miss \ pic-miss-word set + \ inline-cache-miss-tail \ pic-miss-tail-word set + \ mega-cache-lookup \ mega-lookup-word set + \ mega-cache-miss \ mega-miss-word set + [ undefined ] undefined-quot set ; + +: emit-userenvs ( -- ) + userenvs get keys [ emit-userenv ] each ; : fixup-header ( -- ) heap-size data-heap-size-offset fixup ; @@ -529,8 +503,8 @@ M: quotation ' emit-jit-data "Serializing global namespace..." print flush emit-global - "Serializing boot quotation..." print flush - emit-boot-quot + "Serializing user environment..." print flush + emit-userenvs "Performing word fixups..." print flush fixup-words "Performing header fixups..." print flush diff --git a/basis/bootstrap/image/syntax/authors.txt b/basis/bootstrap/image/syntax/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/bootstrap/image/syntax/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/bootstrap/image/syntax/syntax.factor b/basis/bootstrap/image/syntax/syntax.factor new file mode 100644 index 0000000000..29dc09717a --- /dev/null +++ b/basis/bootstrap/image/syntax/syntax.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel namespaces assocs words.symbol ; +IN: bootstrap.image.syntax + +SYMBOL: userenvs + +SYNTAX: RESET H{ } clone userenvs set-global ; + +SYNTAX: USERENV: + CREATE-WORD scan-word + [ swap userenvs get set-at ] + [ drop define-symbol ] + 2bi ; \ No newline at end of file diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index cc853e4842..9d19e4a231 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -35,10 +35,6 @@ SYMBOL: bootstrap-time "Core bootstrap completed in " write core-bootstrap-time get print-time "Bootstrap completed in " write bootstrap-time get print-time - [ optimized>> ] count-words " compiled words" print - [ symbol? ] count-words " symbol words" print - [ ] count-words " words total" print - "Bootstrapping is complete." print "Now, you can run Factor:" print vm write " -i=" write "output-image" get print flush ; @@ -69,7 +65,6 @@ SYMBOL: bootstrap-time "stage2: deployment mode" print ] [ "debugger" require - "alien.prettyprint" require "inspector" require "tools.errors" require "listener" require diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index cb0792ee1e..6017469925 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -14,7 +14,8 @@ IN: bootstrap.tools "tools.test" "tools.time" "tools.threads" - "tools.vocabs" - "tools.vocabs.monitor" + "vocabs.hierarchy" + "vocabs.refresh" + "vocabs.refresh.monitor" "editors" } [ require ] each diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor index 508cbb0a49..caab530a23 100644 --- a/basis/calendar/windows/windows.factor +++ b/basis/calendar/windows/windows.factor @@ -1,5 +1,5 @@ -USING: calendar namespaces alien.c-types system windows -windows.kernel32 kernel math combinators ; +USING: calendar namespaces alien.c-types system +windows.kernel32 kernel math combinators windows.errors ; IN: calendar.windows M: windows gmt-offset ( -- hours minutes seconds ) diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor index 0ae4328446..76675f9413 100644 --- a/basis/checksums/common/common.factor +++ b/basis/checksums/common/common.factor @@ -9,6 +9,9 @@ SYMBOL: bytes-read : calculate-pad-length ( length -- length' ) [ 56 < 55 119 ? ] keep - ; +: calculate-pad-length-long ( length -- length' ) + [ 120 < 119 247 ? ] keep - ; + : pad-last-block ( str big-endian? length -- str ) [ [ % ] 2dip HEX: 80 , diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 2f4e3c51c4..c14ea5a98d 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -1,7 +1,42 @@ -USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ; -[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test -[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test -[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test -[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test -[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test -[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test +USING: arrays kernel math namespaces sequences tools.test +checksums.sha2 checksums ; +IN: checksums.sha2.tests + +: test-checksum ( text identifier -- checksum ) + checksum-bytes hex-string ; + +[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ] +[ + "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + sha-224 test-checksum +] unit-test + +[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] +[ "" sha-256 test-checksum ] unit-test + +[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] +[ "abc" sha-256 test-checksum ] unit-test + +[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] +[ "message digest" sha-256 test-checksum ] unit-test + +[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] +[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test + +[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] +[ + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" + sha-256 test-checksum +] unit-test + +[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] +[ + "12345678901234567890123456789012345678901234567890123456789012345678901234567890" + sha-256 test-checksum +] unit-test + + + + +! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] +! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 3b092a78de..12e32f6c69 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -2,12 +2,27 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel splitting grouping math sequences namespaces make io.binary math.bitwise checksums checksums.common -sbufs strings ; +sbufs strings combinators.smart math.ranges fry combinators +accessors locals ; IN: checksums.sha2 - ] map block-size get 0 pad-tail - dup 16 64 dup [ - process-M-256 - ] with each ; - -: ch ( x y z -- x' ) - [ bitxor bitand ] keep bitxor ; - -: maj ( x y z -- x' ) - [ [ bitand ] 2keep bitor ] dip bitand bitor ; + [ + [ -17 bitroll-32 ] + [ -19 bitroll-32 ] + [ -10 shift ] tri + ] [ bitxor ] reduce-outputs ; inline : S0-256 ( x -- x' ) - [ -2 bitroll-32 ] keep - [ -13 bitroll-32 ] keep - -22 bitroll-32 bitxor bitxor ; inline + [ + [ -2 bitroll-32 ] + [ -13 bitroll-32 ] + [ -22 bitroll-32 ] tri + ] [ bitxor ] reduce-outputs ; inline : S1-256 ( x -- x' ) - [ -6 bitroll-32 ] keep - [ -11 bitroll-32 ] keep - -25 bitroll-32 bitxor bitxor ; inline + [ + [ -6 bitroll-32 ] + [ -11 bitroll-32 ] + [ -25 bitroll-32 ] tri + ] [ bitxor ] reduce-outputs ; inline -: slice3 ( n seq -- a b c ) [ dup 3 + ] dip first3 ; inline +: s0-512 ( x -- x' ) + [ + [ -1 bitroll-64 ] + [ -8 bitroll-64 ] + [ -7 shift ] tri + ] [ bitxor ] reduce-outputs ; inline -: T1 ( W n -- T1 ) - [ swap nth ] keep - K get nth + - e vars get slice3 ch + - e vars get nth S1-256 + - h vars get nth w+ ; +: s1-512 ( x -- x' ) + [ + [ -19 bitroll-64 ] + [ -61 bitroll-64 ] + [ -6 shift ] tri + ] [ bitxor ] reduce-outputs ; inline -: T2 ( -- T2 ) - a vars get nth S0-256 - a vars get slice3 maj w+ ; +: S0-512 ( x -- x' ) + [ + [ -28 bitroll-64 ] + [ -34 bitroll-64 ] + [ -39 bitroll-64 ] tri + ] [ bitxor ] reduce-outputs ; inline -: update-vars ( T1 T2 -- ) - vars get +: S1-512 ( x -- x' ) + [ + [ -14 bitroll-64 ] + [ -18 bitroll-64 ] + [ -41 bitroll-64 ] tri + ] [ bitxor ] reduce-outputs ; inline + +: process-M-256 ( n seq -- ) + { + [ [ 16 - ] dip nth ] + [ [ 15 - ] dip nth s0-256 ] + [ [ 7 - ] dip nth ] + [ [ 2 - ] dip nth s1-256 w+ w+ w+ ] + [ ] + } 2cleave set-nth ; inline + +: process-M-512 ( n seq -- ) + { + [ [ 16 - ] dip nth ] + [ [ 15 - ] dip nth s0-512 ] + [ [ 7 - ] dip nth ] + [ [ 2 - ] dip nth s1-512 w+ w+ w+ ] + [ ] + } 2cleave set-nth ; inline + +: ch ( x y z -- x' ) + [ bitxor bitand ] keep bitxor ; inline + +: maj ( x y z -- x' ) + [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline + +: slice3 ( n seq -- a b c ) + [ dup 3 + ] dip first3 ; inline + +GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) + +M: sha2-short pad-initial-bytes ( string sha2 -- padded-string ) + drop + dup [ + HEX: 80 , + length + [ 64 mod calculate-pad-length 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) + drop dup [ + HEX: 80 , + length + [ 128 mod calculate-pad-length-long 0 % ] + [ 3 shift 8 >be % ] bi + ] "" make append ; + +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; + +:: T1-256 ( n M H sha2 -- T1 ) + n M nth + n sha2 K>> nth + + e H slice3 ch w+ + e H nth S1-256 w+ + h H nth w+ ; inline + +: T2-256 ( H -- T2 ) + [ a swap nth S0-256 ] + [ a swap slice3 maj w+ ] bi ; inline + +:: T1-512 ( n M H sha2 -- T1 ) + n M nth + n sha2 K>> nth + + e H slice3 ch w+ + e H nth S1-512 w+ + h H nth w+ ; inline + +: T2-512 ( H -- T2 ) + [ a swap nth S0-512 ] + [ a swap slice3 maj w+ ] bi ; inline + +: update-H ( T1 T2 H -- ) h g pick exchange g f pick exchange f e pick exchange @@ -105,42 +251,56 @@ CONSTANT: h 7 d c pick exchange c b pick exchange b a pick exchange - [ w+ a ] dip set-nth ; + [ w+ a ] dip set-nth ; inline -: process-chunk ( M -- ) - H get clone vars set - prepare-message-schedule block-size get [ - T1 T2 update-vars - ] with each vars get H get [ w+ ] 2map H set ; +: prepare-message-schedule ( seq sha2 -- w-seq ) + [ word-size>> [ be> ] map ] + [ + block-size>> [ 0 pad-tail 16 ] keep [a,b) over + '[ _ process-M-256 ] each + ] bi ; inline -: seq>byte-array ( n seq -- string ) - [ swap [ >be % ] curry each ] B{ } make ; +:: process-chunk ( M block-size cloned-H sha2 -- ) + block-size [ + M cloned-H sha2 T1-256 + cloned-H T2-256 + cloned-H update-H + ] each + cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline -: preprocess-plaintext ( string big-endian? -- padded-string ) - #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits - [ >sbuf ] dip over [ - HEX: 80 , - dup length HEX: 3f bitand - calculate-pad-length 0 % - length 3 shift 8 rot [ >be ] [ >le ] if % - ] "" make over push-all ; +: sha2-steps ( sliced-groups state -- ) + '[ + _ + [ prepare-message-schedule ] + [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi + ] each ; -: byte-array>sha2 ( byte-array -- string ) - t preprocess-plaintext - block-size get group [ process-chunk ] each - 4 H get seq>byte-array ; +: byte-array>sha2 ( bytes state -- ) + [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi ] + [ sha2-steps ] bi ; + +: ( -- sha2-state ) + sha-224-state new + K-256 >>K + initial-H-224 >>H + 4 >>word-size + 64 >>block-size ; + +: ( -- sha2-state ) + sha-256-state new + K-256 >>K + initial-H-256 >>H + 4 >>word-size + 64 >>block-size ; PRIVATE> -SINGLETON: sha-256 - -INSTANCE: sha-256 checksum +M: sha-224 checksum-bytes + drop + [ byte-array>sha2 ] + [ H>> 7 head 4 seq>byte-array ] bi ; M: sha-256 checksum-bytes - drop [ - K-256 K set - initial-H-256 H set - 4 word-size set - 64 block-size set - byte-array>sha2 - ] with-scope ; + drop + [ byte-array>sha2 ] + [ H>> 4 seq>byte-array ] bi ; diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor index 8b33986fc2..66093645c1 100644 --- a/basis/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel NSApplicationDelegateReplyFailure ; : with-autorelease-pool ( quot -- ) - NSAutoreleasePool -> new slip -> release ; inline + NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline : NSApp ( -- app ) NSApplication -> sharedApplication ; diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 69d698f9b1..b78bb020d0 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006 Slava Pestov +! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: compiler io kernel cocoa.runtime cocoa.subclassing cocoa.messages cocoa.types sequences words vocabs parser @@ -7,7 +7,7 @@ compiler.units lexer init ; IN: cocoa : (remember-send) ( selector variable -- ) - global [ dupd ?set-at ] change-at ; + [ dupd ?set-at ] change-global ; SYMBOL: sent-messages @@ -27,22 +27,16 @@ SYMBOL: frameworks frameworks [ V{ } clone ] initialize -[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook +[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; SYNTAX: IMPORT: scan [ ] import-objc-class ; -"Compiling Objective C bridge..." print +"Importing Cocoa classes..." print "cocoa.classes" create-vocab drop -{ - "cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing" -} [ words ] map concat compile - -"Importing Cocoa classes..." print - [ { "NSApplication" diff --git a/basis/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor index 84a1ad46a3..7761286127 100644 --- a/basis/cocoa/dialogs/dialogs.factor +++ b/basis/cocoa/dialogs/dialogs.factor @@ -12,6 +12,9 @@ IN: cocoa.dialogs dup 1 -> setResolvesAliases: dup 1 -> setAllowsMultipleSelection: ; +: ( -- panel ) + dup 1 -> setCanChooseDirectories: ; + : ( -- panel ) NSSavePanel -> savePanel dup 1 -> setCanChooseFiles: @@ -21,10 +24,12 @@ IN: cocoa.dialogs CONSTANT: NSOKButton 1 CONSTANT: NSCancelButton 0 -: open-panel ( -- paths ) - +: (open-panel) ( panel -- paths ) dup -> runModal NSOKButton = [ -> filenames CF>string-array ] [ drop f ] if ; + +: open-panel ( -- paths ) (open-panel) ; +: open-dir-panel ( -- paths ) (open-panel) ; : split-path ( path -- dir file ) "/" split1-last [ ] bi@ ; diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index 31b59a6eac..ceb097bb3a 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -4,7 +4,7 @@ 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 words core-foundation +combinators alien.c-types words core-foundation quotations core-foundation.data core-foundation.utilities ; IN: cocoa.plists @@ -41,10 +41,16 @@ DEFER: plist> *void* [ -> release "read-plist failed" throw ] when* ; MACRO: objc-class-case ( alist -- quot ) - [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ; + [ + dup callable? + [ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ] + unless + ] map '[ _ cond ] ; PRIVATE> +ERROR: invalid-plist-object object ; + : plist> ( plist -- value ) { { NSString [ (plist-NSString>) ] } @@ -53,6 +59,7 @@ PRIVATE> { NSArray [ (plist-NSArray>) ] } { NSDictionary [ (plist-NSDictionary>) ] } { NSObject [ ] } + [ invalid-plist-object ] } objc-class-case ; : read-plist ( path -- assoc ) diff --git a/basis/cocoa/views/views-docs.factor b/basis/cocoa/views/views-docs.factor index 3b533f98c3..871326fcd4 100644 --- a/basis/cocoa/views/views-docs.factor +++ b/basis/cocoa/views/views-docs.factor @@ -1,13 +1,9 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup ui.pixel-formats ; IN: cocoa.views -HELP: -{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } } -{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ; - HELP: -{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "view" "a new " { $snippet "NSOpenGLView" } } } -{ $description "Creates a new instance of the specified class, giving it a default pixel format and the given size." } ; +{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "pixel-format" pixel-format } { "view" "a new " { $snippet "NSOpenGLView" } } } +{ $description "Creates a new instance of the specified class, giving it the specified pixel format and size." } ; HELP: view-dim { $values { "view" "an " { $snippet "NSView" } } { "dim" "a pair of real numbers" } } @@ -18,7 +14,6 @@ HELP: mouse-location { $description "Outputs the current mouse location." } ; ARTICLE: "cocoa-view-utils" "Cocoa view utilities" -{ $subsection } { $subsection } { $subsection view-dim } { $subsection mouse-location } ; diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index 3c60a6a7c1..f65fddac58 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -42,39 +42,10 @@ CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96 CONSTANT: NSOpenGLPFAVirtualScreenCount 128 CONSTANT: NSOpenGLCPSwapInterval 222 - - -: with-software-renderer ( quot -- ) - [ t software-renderer? ] dip with-variable ; inline - -: with-multisample ( quot -- ) - [ t multisample? ] dip with-variable ; inline - -: ( attributes -- pixelfmt ) - NSOpenGLPixelFormat -> alloc swap [ - % - NSOpenGLPFADepthSize , 16 , - software-renderer? get [ - NSOpenGLPFARendererID , kCGLRendererGenericFloatID , - ] when - multisample? get [ - NSOpenGLPFASupersample , - NSOpenGLPFASampleBuffers , 1 , - NSOpenGLPFASamples , 8 , - ] when - 0 , - ] int-array{ } make - -> initWithAttributes: - -> autorelease ; - -: ( class dim -- view ) - [ -> alloc 0 0 ] dip first2 - NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array +: ( class dim pixel-format -- view ) + [ -> alloc ] + [ [ 0 0 ] dip first2 ] + [ handle>> ] tri* -> initWithFrame:pixelFormat: dup 1 -> setPostsBoundsChangedNotifications: dup 1 -> setPostsFrameChangedNotifications: ; diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index aa7960539c..9519847810 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -18,6 +18,10 @@ MACRO: input> ] keep '[ _ firstn @ ] ; +MACRO: input> ] keep + '[ _ firstn-unsafe @ ] ; + MACRO: reduce-outputs ( quot operation -- newquot ) [ dup infer out>> 1 [-] ] dip n*quot compose ; diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index 3d06bd97b7..5aeb49d6f2 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -1,5 +1,4 @@ -USING: help.markup help.syntax parser vocabs.loader strings -command-line.private ; +USING: help.markup help.syntax parser vocabs.loader strings ; IN: command-line HELP: run-bootstrap-init @@ -53,6 +52,7 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM" { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" } { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" } { { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" } + { { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 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 runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ; diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 56d7fbd207..f2da4ebdf5 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! 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 ; +sequences strings system splitting vocabs.loader alien.strings ; IN: command-line SYMBOL: script SYMBOL: command-line -: (command-line) ( -- args ) 10 getenv sift ; +: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ; : rc-path ( name -- path ) os windows? [ "." prepend ] unless diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 3a4c702bc5..938dbbccbf 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot [ tuple ##set-slots ] [ ds-push drop ] 2bi ] [ drop emit-primitive ] if ; -: store-length ( len reg -- ) - [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ; +: store-length ( len reg class -- ) + [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ; -: store-initial-element ( elt reg len -- ) - [ 2 + object tag-number ##set-slot-imm ] with with each ; +:: store-initial-element ( len reg elt class -- ) + len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ; : expand-? ( obj -- ? ) dup integer? [ 0 8 between? ] [ drop f ] if ; @@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot [let | elt [ ds-pop ] reg [ len ^^allot-array ] | ds-drop - len reg store-length - elt reg len store-initial-element + len reg array store-length + len reg elt array store-initial-element reg ds-push ] ] [ node emit-primitive ] if @@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot : emit-allot-byte-array ( len -- dst ) ds-drop dup ^^allot-byte-array - [ store-length ] [ ds-push ] [ ] tri ; + [ byte-array store-length ] [ ds-push ] [ ] tri ; : emit-(byte-array) ( node -- ) dup node-input-infos first literal>> dup expand-? [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; -: emit- ( node -- ) - dup node-input-infos first literal>> dup expand-? [ - nip - [ 0 ^^load-literal ] dip - [ emit-allot-byte-array ] keep - bytes>cells store-initial-element - ] [ drop emit-primitive ] if ; +:: emit- ( node -- ) + node node-input-infos first literal>> dup expand-? [ + :> len + 0 ^^load-literal :> elt + len emit-allot-byte-array :> reg + len reg elt byte-array store-initial-element + ] [ drop node emit-primitive ] if ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 3d0a7bec9c..ec819f9440 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics arrays: byte-arrays: byte-arrays:(byte-array) - math.private: - math.private: kernel: alien.accessors:alien-unsigned-1 alien.accessors:set-alien-unsigned-1 @@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics { \ arrays: [ emit- iterate-next ] } { \ byte-arrays: [ emit- iterate-next ] } { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] } - { \ math.private: [ emit-simple-allot iterate-next ] } - { \ math.private: [ emit-simple-allot iterate-next ] } { \ kernel: [ emit-simple-allot iterate-next ] } { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] } { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] } diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index ac9603522e..abd2720817 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -92,7 +92,7 @@ sequences ; T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } - T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } + T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= } T{ ##replace f V int-regs 6 D 0 } } value-numbering trim-temps ] unit-test @@ -110,7 +110,7 @@ sequences ; T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } - T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } + T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= } T{ ##replace f V int-regs 6 D 0 } } value-numbering trim-temps ] unit-test @@ -132,7 +132,7 @@ sequences ; T{ ##unbox-float f V double-float-regs 10 V int-regs 8 } T{ ##unbox-float f V double-float-regs 11 V int-regs 9 } T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< } - T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= } + T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= } T{ ##replace f V int-regs 14 D 0 } } value-numbering trim-temps ] unit-test @@ -149,6 +149,6 @@ sequences ; T{ ##peek f V int-regs 29 D -1 } T{ ##peek f V int-regs 30 D -2 } T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= } - T{ ##compare-imm-branch f V int-regs 33 7 cc/= } + T{ ##compare-imm-branch f V int-regs 33 5 cc/= } } value-numbering trim-temps ] unit-test diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 2a0456e3b7..c7b67b72b4 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -3,7 +3,7 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs -alien.strings alien.arrays alien.complex sets libc alien.libraries +alien.strings alien.arrays alien.complex alien.libraries sets libc continuations.private fry cpu.architecture source-files.errors compiler.errors @@ -44,7 +44,7 @@ SYMBOL: calls SYMBOL: compiling-word -: compiled-stack-traces? ( -- ? ) 59 getenv ; +: compiled-stack-traces? ( -- ? ) 67 getenv ; ! Mapping _label IDs to label instances SYMBOL: labels @@ -88,7 +88,7 @@ M: ##call generate-insn word>> dup sub-primitive>> [ first % ] [ [ add-call ] [ %call ] bi ] ?if ; -M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ; +M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ; M: ##return generate-insn drop %return ; @@ -444,8 +444,7 @@ TUPLE: callback-context ; : do-callback ( quot token -- ) init-catchstack - dup 2 setenv - slip + [ 2 setenv call ] keep wait-to-return ; inline : callback-return-quot ( ctype -- quot ) diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 3a047a8d39..d0c874feb0 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -3,15 +3,13 @@ USING: 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 words.private math.order +system combinators math.bitwise math.order accessors growable cpu.architecture compiler.constants ; IN: compiler.codegen.fixup GENERIC: fixup* ( obj -- ) -: code-format ( -- n ) 22 getenv ; - -: compiled-offset ( -- n ) building get length code-format * ; +: compiled-offset ( -- n ) building get length ; SYMBOL: relocation-table SYMBOL: label-table @@ -25,7 +23,7 @@ TUPLE: label-fixup label class ; M: label-fixup fixup* dup class>> rc-absolute? [ "Absolute labels not supported" throw ] when - [ label>> ] [ class>> ] bi compiled-offset 4 - rot + [ class>> ] [ label>> ] bi compiled-offset 4 - swap 3array label-table get push ; TUPLE: rel-fixup class type ; @@ -58,6 +56,12 @@ SYMBOL: literal-table : rel-word ( word class -- ) [ add-literal ] dip rt-xt rel-fixup ; +: rel-word-pic ( word class -- ) + [ add-literal ] dip rt-xt-pic rel-fixup ; + +: rel-word-pic-tail ( word class -- ) + [ add-literal ] dip rt-xt-pic-tail rel-fixup ; + : rel-primitive ( word class -- ) [ def>> first add-literal ] dip rt-primitive rel-fixup ; @@ -88,4 +92,4 @@ SYMBOL: literal-table literal-table get >array relocation-table get >byte-array label-table get resolve-labels - ] { } make 4array ; + ] B{ } make 4array ; diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index b96d5e573a..306ab515a8 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -1,19 +1,19 @@ USING: assocs compiler.cfg.builder compiler.cfg.optimizer compiler.errors compiler.tree.builder compiler.tree.optimizer compiler.units help.markup help.syntax io parser quotations -sequences words words.private ; +sequences words ; IN: compiler -HELP: enable-compiler +HELP: enable-optimizer { $description "Enables the optimizing compiler." } ; -HELP: disable-compiler +HELP: disable-optimizer { $description "Disable the optimizing compiler." } ; ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically. This can be changed:" -{ $subsection disable-compiler } -{ $subsection enable-compiler } +{ $subsection disable-optimizer } +{ $subsection enable-optimizer } "Removing a word's optimized definition:" { $subsection decompile } "Compiling a single quotation:" diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index ee91d04b3d..01e58461ff 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,19 +2,20 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io source-files.errors -stack-checker stack-checker.state stack-checker.inlining -stack-checker.errors combinators.short-circuit compiler.errors -compiler.units compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization -compiler.cfg.two-operand compiler.cfg.linear-scan -compiler.cfg.stack-frame compiler.codegen compiler.utilities ; +generic.single combinators deques search-deques macros io +source-files.errors stack-checker stack-checker.state +stack-checker.inlining stack-checker.errors combinators.short-circuit +compiler.errors compiler.units compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer +compiler.cfg.linearization compiler.cfg.two-operand +compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen +compiler.utilities ; IN: compiler SYMBOL: compile-queue SYMBOL: compiled -: queue-compile? ( word -- ? ) +: compile? ( word -- ? ) #! Don't attempt to compile certain words. { [ "forgotten" word-prop ] @@ -24,7 +25,7 @@ SYMBOL: compiled } 1|| not ; : queue-compile ( word -- ) - dup queue-compile? [ compile-queue get push-front ] [ drop ] if ; + dup compile? [ compile-queue get push-front ] [ drop ] if ; : recompile-callers? ( word -- ? ) changed-effects get key? ; @@ -41,6 +42,14 @@ SYMBOL: compiled H{ } clone generic-dependencies set clear-compiler-error ; +GENERIC: no-compile? ( word -- ? ) + +M: word no-compile? "no-compile" word-prop ; + +M: method-body no-compile? "method-generic" word-prop no-compile? ; + +M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; + : ignore-error? ( word error -- ? ) #! Ignore some errors on inline combinators, macros, and special #! words such as 'call'. @@ -48,8 +57,8 @@ SYMBOL: compiled { [ macro? ] [ inline? ] + [ no-compile? ] [ "special" word-prop ] - [ "no-compile" word-prop ] } 1|| ] [ { @@ -80,32 +89,45 @@ SYMBOL: compiled : not-compiled-def ( word error -- def ) '[ _ _ not-compiled ] [ ] like ; +: ignore-error ( word error -- * ) + drop + [ clear-compiler-error ] + [ dup def>> deoptimize-with ] + bi ; + +: remember-error ( word error -- * ) + [ swap compiler-error ] + [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ] + 2bi ; + : deoptimize ( word error -- * ) #! If the error is ignorable, compile the word with the #! non-optimizing compiler, using its definition. Otherwise, #! if the compiler error is not ignorable, use a dummy #! definition from 'not-compiled-def' which throws an error. - 2dup ignore-error? [ - drop - [ dup def>> deoptimize-with ] - [ clear-compiler-error ] - bi - ] [ - [ swap compiler-error ] - [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ] - 2bi - ] if ; + { + { [ dup inference-error? not ] [ rethrow ] } + { [ 2dup ignore-error? ] [ ignore-error ] } + [ remember-error ] + } cond ; + +: optimize? ( word -- ? ) + { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ; + +: contains-breakpoints? ( -- ? ) + dependencies get keys [ "break?" word-prop ] any? ; : frontend ( word -- nodes ) #! If the word contains breakpoints, don't optimize it, since #! the walker does not support this. - dup contains-breakpoints? [ dup def>> deoptimize-with ] [ - [ build-tree ] [ deoptimize ] recover optimize-tree - ] if ; + dup optimize? [ + [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep + contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if + ] [ dup def>> deoptimize-with ] if ; : compile-dependency ( word -- ) #! If a word calls an unoptimized word, try to compile the callee. - dup optimized>> [ drop ] [ queue-compile ] if ; + dup optimized? [ drop ] [ queue-compile ] if ; ! Only switch this off for debugging. SYMBOL: compile-dependencies? @@ -161,15 +183,21 @@ M: optimizing-compiler recompile ( words -- alist ) [ compile-queue set H{ } clone compiled set - [ queue-compile ] each + [ + [ queue-compile ] + [ subwords [ compile-dependency ] each ] bi + ] each compile-queue get compile-loop compiled get >alist ] with-scope ; -: enable-compiler ( -- ) +: with-optimizer ( quot -- ) + [ optimizing-compiler compiler-impl ] dip with-variable ; inline + +: enable-optimizer ( -- ) optimizing-compiler compiler-impl set-global ; -: disable-compiler ( -- ) +: disable-optimizer ( -- ) f compiler-impl set-global ; : recompile-all ( -- ) diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index b3757bf008..6b383388ef 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math kernel layouts system strings ; +USING: math kernel layouts system strings words quotations byte-arrays +alien arrays literals sequences ; IN: compiler.constants ! These constants must match vm/memory.h @@ -11,43 +12,44 @@ CONSTANT: deck-bits 18 ! These constants must match vm/layouts.h : header-offset ( -- n ) object tag-number neg ; inline : float-offset ( -- n ) 8 float tag-number - ; inline -: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline +: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline -: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline -: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline -: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline -: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline +: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline +: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline +: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline +: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline -: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline -: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline -: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline -: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline -: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline -: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline +: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline +: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline +: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline +: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline +: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline ! Relocation classes -CONSTANT: rc-absolute-cell 0 -CONSTANT: rc-absolute 1 -CONSTANT: rc-relative 2 +CONSTANT: rc-absolute-cell 0 +CONSTANT: rc-absolute 1 +CONSTANT: rc-relative 2 CONSTANT: rc-absolute-ppc-2/2 3 -CONSTANT: rc-relative-ppc-2 4 -CONSTANT: rc-relative-ppc-3 5 -CONSTANT: rc-relative-arm-3 6 -CONSTANT: rc-indirect-arm 7 -CONSTANT: rc-indirect-arm-pc 8 +CONSTANT: rc-absolute-ppc-2 4 +CONSTANT: rc-relative-ppc-2 5 +CONSTANT: rc-relative-ppc-3 6 +CONSTANT: rc-relative-arm-3 7 +CONSTANT: rc-indirect-arm 8 +CONSTANT: rc-indirect-arm-pc 9 ! Relocation types -CONSTANT: rt-primitive 0 -CONSTANT: rt-dlsym 1 -CONSTANT: rt-dispatch 2 -CONSTANT: rt-xt 3 -CONSTANT: rt-here 4 -CONSTANT: rt-this 5 -CONSTANT: rt-immediate 6 -CONSTANT: rt-stack-chain 7 +CONSTANT: rt-primitive 0 +CONSTANT: rt-dlsym 1 +CONSTANT: rt-dispatch 2 +CONSTANT: rt-xt 3 +CONSTANT: rt-xt-pic 4 +CONSTANT: rt-xt-pic-tail 5 +CONSTANT: rt-here 6 +CONSTANT: rt-this 7 +CONSTANT: rt-immediate 8 +CONSTANT: rt-stack-chain 9 +CONSTANT: rt-untagged 10 +CONSTANT: rt-megamorphic-cache-hits 11 : rc-absolute? ( n -- ? ) - [ rc-absolute-ppc-2/2 = ] - [ rc-absolute-cell = ] - [ rc-absolute = ] - tri or or ; + ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 42ed90d64a..f7f24433d7 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; C{ 1.0 2.0 } C{ 1.5 1.0 } ffi_test_47 ] unit-test + +! Reported by jedahu +C-STRUCT: bool-field-test + { "char*" "name" } + { "bool" "on" } + { "short" "parents" } ; + +FUNCTION: short ffi_test_48 ( bool-field-test x ) ; + +[ 123 ] [ + "bool-field-test" 123 over set-bool-field-test-parents + ffi_test_48 +] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/call-effect.factor b/basis/compiler/tests/call-effect.factor new file mode 100644 index 0000000000..a9fd313d64 --- /dev/null +++ b/basis/compiler/tests/call-effect.factor @@ -0,0 +1,14 @@ +IN: compiler.tests.call-effect +USING: tools.test combinators generic.single sequences kernel ; + +: execute-ic-test ( a b -- c ) execute( a -- c ) ; + +! VM type check error +[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with + +: call-test ( q -- ) call( -- ) ; + +[ ] [ [ ] call-test ] unit-test +[ ] [ f [ drop ] curry call-test ] unit-test +[ ] [ [ ] [ ] compose call-test ] unit-test +[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with \ No newline at end of file diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index c746fdfb45..8fbe13ce51 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -26,7 +26,7 @@ IN: compiler.tests.codegen [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test -[ { 1 2 3 } { 1 4 3 } 3 3 ] +[ { 1 2 3 } { 1 4 3 } 2 2 ] [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ] unit-test @@ -37,7 +37,7 @@ unit-test : foo ( -- ) ; -[ 5 5 ] +[ 3 3 ] [ 1.2 [ tag [ foo ] keep ] compile-call ] unit-test @@ -211,7 +211,7 @@ TUPLE: my-tuple ; { tuple vector } 3 slot { word } declare dup 1 slot 0 fixnum-bitand { [ ] } dispatch ; -[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test +[ t ] [ \ dispatch-alignment-regression optimized? ] unit-test [ vector ] [ dispatch-alignment-regression ] unit-test diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index 32611ba87a..b541e19f34 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -33,7 +33,7 @@ IN: compiler.tests.curry ] unit-test : foobar ( quot: ( -- ) -- ) - dup slip swap [ foobar ] [ drop ] if ; inline recursive + [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive [ ] [ [ [ f ] foobar ] compile-call ] unit-test diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 1a604dbd8e..7074b73845 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -9,7 +9,7 @@ math.private tools.test math.floats.private ; [ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test -[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test +[ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test [ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test diff --git a/basis/compiler/tests/generic.factor b/basis/compiler/tests/generic.factor new file mode 100644 index 0000000000..6b0ef2d439 --- /dev/null +++ b/basis/compiler/tests/generic.factor @@ -0,0 +1,11 @@ +IN: compiler.tests.generic +USING: tools.test math kernel compiler.units definitions ; + +GENERIC: bad ( -- ) +M: integer bad ; +M: object bad ; + +[ 0 bad ] must-fail +[ "" bad ] must-fail + +[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index a6e827ea33..5ca0f3f109 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -342,12 +342,12 @@ cell 8 = [ ] unit-test [ 1 2 ] [ - 1 2 [ ] compile-call + 1 2 [ complex boa ] compile-call dup real-part swap imaginary-part ] unit-test [ 1 2 ] [ - 1 2 [ ] compile-call dup numerator swap denominator + 1 2 [ ratio boa ] compile-call dup numerator swap denominator ] unit-test [ \ + ] [ \ + [ ] compile-call ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index bd7008f909..fa1248435b 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -4,13 +4,13 @@ sbufs strings tools.test vectors words sequences.private quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors compiler.tree.builder compiler.tree.optimizer sequences.deep -compiler ; +compiler definitions ; IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; -[ t ] [ \ xyz optimized>> ] unit-test +[ t ] [ M\ array xyz optimized? ] unit-test ! Test predicate inlining : pred-test-1 ( a -- b c ) @@ -95,7 +95,7 @@ TUPLE: pred-test ; ! regression GENERIC: void-generic ( obj -- * ) : breakage ( -- * ) "hi" void-generic ; -[ t ] [ \ breakage optimized>> ] unit-test +[ t ] [ \ breakage optimized? ] unit-test [ breakage ] must-fail ! regression @@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * ) ! compiling with a non-literal class failed : -regression ( class -- tuple ) ; -[ t ] [ \ -regression optimized>> ] unit-test +[ t ] [ \ -regression optimized? ] unit-test GENERIC: foozul ( a -- b ) M: reversed foozul ; @@ -229,7 +229,7 @@ USE: binary-search.private : node-successor-f-bug ( x -- * ) [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; -[ t ] [ \ node-successor-f-bug optimized>> ] unit-test +[ t ] [ \ node-successor-f-bug optimized? ] unit-test [ ] [ [ new ] build-tree optimize-tree drop ] unit-test @@ -243,7 +243,7 @@ USE: binary-search.private ] if ] if ; -[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test +[ t ] [ \ lift-throw-tail-regression optimized? ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test @@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ; : recursive-inline-hang-1 ( -- a ) { } recursive-inline-hang ; -[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test +[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test DEFER: recursive-inline-hang-3 @@ -325,7 +325,7 @@ PREDICATE: list < improper-list dup "a" get { array-capacity } declare >= [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ; -[ t ] [ \ interval-inference-bug optimized>> ] unit-test +[ t ] [ \ interval-inference-bug optimized? ] unit-test [ ] [ 1 "a" set 2 "b" set ] unit-test [ 2 3 ] [ 2 interval-inference-bug ] unit-test @@ -384,3 +384,15 @@ DEFER: loop-bbb 1 >bignum 2 >bignum [ { bignum integer } declare [ shift ] keep 1+ ] compile-call ] unit-test + +: broken-declaration ( -- ) \ + declare ; + +[ f ] [ \ broken-declaration optimized? ] unit-test + +[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test + +! Modular arithmetic bug +: modular-arithmetic-bug ( a -- b ) >integer 256 mod ; + +[ 1 ] [ 257 modular-arithmetic-bug ] unit-test +[ -10 ] [ -10 modular-arithmetic-bug ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor index e107135305..95d454fed1 100644 --- a/basis/compiler/tests/peg-regression.factor +++ b/basis/compiler/tests/peg-regression.factor @@ -4,7 +4,7 @@ ! optimization, which would batch generic word updates at the ! end of a compilation unit. -USING: kernel accessors peg.ebnf ; +USING: kernel accessors peg.ebnf words ; IN: compiler.tests.peg-regression TUPLE: pipeline-expr background ; @@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]] USE: tools.test -[ t ] [ \ expr optimized>> ] unit-test -[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test +[ t ] [ \ expr optimized? ] unit-test +[ t ] [ \ ast>pipeline-expr optimized? ] unit-test diff --git a/basis/compiler/tests/pic-problem-1.factor b/basis/compiler/tests/pic-problem-1.factor new file mode 100644 index 0000000000..4adf0b36b9 --- /dev/null +++ b/basis/compiler/tests/pic-problem-1.factor @@ -0,0 +1,14 @@ +IN: compiler.tests.pic-problem-1 +USING: kernel sequences prettyprint memory tools.test ; + +TUPLE: x ; + +M: x length drop 0 ; + +INSTANCE: x sequence + +<< gc >> + +CONSTANT: blah T{ x } + +[ T{ x } ] [ blah ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/redefine14.factor b/basis/compiler/tests/redefine14.factor index 807f3ed2c7..a72db4833c 100644 --- a/basis/compiler/tests/redefine14.factor +++ b/basis/compiler/tests/redefine14.factor @@ -1,8 +1,8 @@ USING: compiler.units definitions tools.test sequences ; IN: compiler.tests.redefine14 -! TUPLE: bad ; -! -! M: bad length 1 2 3 ; -! -! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test +TUPLE: bad ; + +M: bad length 1 2 3 ; + +[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tests/redefine17.factor b/basis/compiler/tests/redefine17.factor new file mode 100644 index 0000000000..4ed3e36f4d --- /dev/null +++ b/basis/compiler/tests/redefine17.factor @@ -0,0 +1,49 @@ +IN: compiler.tests.redefine17 +USING: tools.test classes.mixin compiler.units arrays kernel.private +strings sequences vocabs definitions kernel ; + +<< "compiler.tests.redefine17" words forget-all >> + +GENERIC: bong ( a -- b ) + +M: array bong ; + +M: string bong length ; + +MIXIN: mixin + +INSTANCE: array mixin + +: blah ( a -- b ) { mixin } declare bong ; + +[ { } ] [ { } blah ] unit-test + +[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test + +[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test + +[ 0 ] [ "" blah ] unit-test + +MIXIN: mixin1 + +INSTANCE: string mixin1 + +MIXIN: mixin2 + +GENERIC: billy ( a -- b ) + +M: mixin2 billy ; + +M: array billy drop "BILLY" ; + +INSTANCE: string mixin2 + +: bully ( a -- b ) { mixin1 } declare billy ; + +[ "" ] [ "" bully ] unit-test + +[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test + +[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test + +[ "BILLY" ] [ { } bully ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 51ce33c1bd..0a5eb84579 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ; : sheeple-test ( -- string ) { } sheeple ; [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test optimized>> ] unit-test +[ t ] [ \ sheeple-test optimized? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test @@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ; [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test optimized>> ] unit-test +[ t ] [ \ sheeple-test optimized? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 82cc97e0f6..da021412fe 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -60,8 +60,8 @@ IN: compiler.tests.simple ! Make sure error reporting works -[ [ dup ] compile-call ] must-fail -[ [ drop ] compile-call ] must-fail +! [ [ dup ] compile-call ] must-fail +! [ [ drop ] compile-call ] must-fail ! Regression @@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ; 10 [ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ t ] [ - "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj ) + "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj ) ] unit-test ] times diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index 2ec6fbde95..e518ff8df2 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -1,5 +1,5 @@ USING: math.private kernel combinators accessors arrays -generalizations tools.test ; +generalizations tools.test words ; IN: compiler.tests.spilling : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) @@ -47,7 +47,7 @@ IN: compiler.tests.spilling [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ] [ 1.0 float-spill-bug ] unit-test -[ t ] [ \ float-spill-bug optimized>> ] unit-test +[ t ] [ \ float-spill-bug optimized? ] unit-test : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object ) { @@ -132,7 +132,7 @@ IN: compiler.tests.spilling [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ] [ 1.0 float-fixnum-spill-bug ] unit-test -[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test +[ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test : resolve-spill-bug ( a b -- c ) [ 1 fixnum+fast ] bi@ dup 10 fixnum< [ @@ -159,7 +159,7 @@ IN: compiler.tests.spilling 16 narray ] if ; -[ t ] [ \ resolve-spill-bug optimized>> ] unit-test +[ t ] [ \ resolve-spill-bug optimized? ] unit-test [ 4 ] [ 1 1 resolve-spill-bug ] unit-test diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 7f760650e7..00325f5a72 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -54,15 +54,14 @@ PRIVATE> #! This slows down compiler.tree.propagation.inlining since then every #! inlined usage of a method has an inline-dependency on the mixin, and #! not the more specific type at the call site. - specialize-method? off - [ - #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d - { - { [ dup not ] [ ] } - { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } - [ in-d #call out-d>> #copy suffix ] - } cond - ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ; + f specialize-method? [ + [ + #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d + { + { [ dup not ] [ ] } + { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } + [ in-d #call out-d>> #copy suffix ] + } cond + ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover + ] with-variable ; -: contains-breakpoints? ( word -- ? ) - def>> [ word? ] filter [ "break?" word-prop ] any? ; diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index b1dc04082e..60cab92843 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -153,7 +153,7 @@ SYMBOL: node-count [ 1+ ] dip dup #call? [ word>> { - { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] } + { [ dup "intrinsic" word-prop ] [ intrinsics-called ] } { [ dup generic? ] [ generics-called ] } { [ dup method-body? ] [ methods-called ] } [ words-called ] diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor index 333b3fa636..ed253ad89b 100644 --- a/basis/compiler/tree/escape-analysis/check/check.factor +++ b/basis/compiler/tree/escape-analysis/check/check.factor @@ -12,7 +12,6 @@ M: #push run-escape-analysis* M: #call run-escape-analysis* { - { [ dup word>> \ eq? ] [ t ] } { [ dup immutable-tuple-boa? ] [ t ] } [ f ] } cond nip ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index bcb8b2f80a..3d9d77ae56 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -17,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n ) out-d>> first escaping-allocation? [ 1+ ] unless ; M: #call count-unboxed-allocations* - dup [ immutable-tuple-boa? ] [ word>> \ eq? ] bi or + dup immutable-tuple-boa? [ (count-unboxed-allocations) ] [ drop ] if ; M: #push count-unboxed-allocations* @@ -291,7 +291,7 @@ C: ro-box [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test -[ 1 ] [ [ >rect ] count-unboxed-allocations ] unit-test +[ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test [ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test @@ -302,7 +302,7 @@ C: ro-box [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test : impeach-node ( quot: ( node -- ) -- ) - dup slip impeach-node ; inline recursive + [ call ] keep impeach-node ; inline recursive : bleach-node ( quot: ( node -- ) -- ) [ bleach-node ] curry [ ] compose impeach-node ; inline recursive diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index fe1e60dbc2..729d6a0490 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -47,9 +47,6 @@ M: #push escape-analysis* [ record-unknown-allocation ] if ; -: record-complex-allocation ( #call -- ) - [ in-d>> ] [ out-d>> first ] bi record-allocation ; - : slot-offset ( #call -- n/f ) dup in-d>> [ first node-value-info class>> ] @@ -71,7 +68,6 @@ M: #push escape-analysis* M: #call escape-analysis* dup word>> { { \ [ record-tuple-allocation ] } - { \ [ record-complex-allocation ] } { \ slot [ record-slot-call ] } [ drop record-unknown-allocation ] } case ; diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 5d6a9cdea1..6e1c32d89d 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ; ] { mod fixnum-mod } inlined? ] unit-test - [ f ] [ [ 256 mod ] { mod fixnum-mod } inlined? ] unit-test +[ f ] [ + [ + >fixnum 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + [ f ] [ [ dup 0 >= [ 256 mod ] when @@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ; { integer } declare [ 256 rem ] map ] { mod fixnum-mod rem } inlined? ] unit-test + +[ [ >fixnum 255 fixnum-bitand ] ] +[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index de2600f691..31939a0d22 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math math.partial-dispatch namespaces sequences sets accessors assocs words kernel memoize fry combinators +combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.def-use @@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes ) : optimize->fixnum ( #call -- nodes ) dup redundant->fixnum? [ drop f ] when ; +: optimize->integer ( #call -- nodes ) + dup out-d>> first actually-used-by dup length 1 = [ + first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&& + [ drop { } ] when + ] [ drop ] if ; + MEMO: fixnum-coercion ( flags -- nodes ) [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ; @@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes ) M: #call optimize-modular-arithmetic* dup word>> { { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] } + { [ dup \ >integer eq? ] [ drop optimize->integer ] } { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] } [ drop ] } cond ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index a22b7aa172..4d4b22218d 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -59,29 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval } : ( -- info ) \ value-info new ; -: read-only-slots ( values class -- slots ) - all-slots - [ read-only>> [ drop f ] unless ] 2map - f prefix ; - DEFER: +: tuple-slot-infos ( tuple -- slots ) + [ tuple-slots ] [ class all-slots ] bi + [ read-only>> [ ] [ drop f ] if ] 2map + f prefix ; + : init-literal-info ( info -- info ) dup literal>> class >>class dup literal>> dup real? [ [a,a] >>interval ] [ [ [-inf,inf] >>interval ] dip - { - { [ dup complex? ] [ - [ real-part ] - [ imaginary-part ] bi - 2array >>slots - ] } - { [ dup tuple? ] [ - [ tuple-slots [ ] map ] [ class ] bi - read-only-slots >>slots - ] } - [ drop ] - } cond + dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if ] if ; inline : init-value-info ( info -- info ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index aa66b2f6d7..ee9abf00ec 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel arrays sequences math math.order -math.partial-dispatch generic generic.standard generic.math +math.partial-dispatch generic generic.standard generic.single generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart hints locals @@ -157,11 +157,7 @@ DEFER: (flat-length) ] sum-outputs ; : should-inline? ( #call word -- ? ) - { - { [ dup contains-breakpoints? ] [ 2drop f ] } - { [ dup "inline" word-prop ] [ 2drop t ] } - [ inlining-rank 5 >= ] - } cond ; + dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ; SYMBOL: history @@ -188,9 +184,7 @@ SYMBOL: history { curry compose } memq? ; : never-inline-word? ( word -- ? ) - [ deferred? ] - [ "default" word-prop ] - [ { call execute } memq? ] tri or or ; + [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ; : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index b91a1157f7..2f5c166ac5 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b] comparison-ops [ dup '[ _ define-comparison-constraints ] each-derived-op ] each -! generic-comparison-ops [ -! dup specific-comparison define-comparison-constraints -! ] each - ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) [ [ interval>> ] bi@ ] dip interval-comparison { @@ -217,6 +213,8 @@ generic-comparison-ops [ { >float float } { fixnum>float float } { bignum>float float } + + { >integer integer } } [ '[ _ @@ -228,19 +226,26 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each +: rem-custom-inlining ( #call -- quot/f ) + second value-info literal>> dup integer? + [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + { mod-integer-integer mod-integer-fixnum mod-fixnum-integer fixnum-mod - rem } [ [ - in-d>> second value-info >literal< - [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when + in-d>> dup first value-info interval>> [0,inf] interval-subset? + [ rem-custom-inlining ] [ drop f ] if ] "custom-inlining" set-word-prop ] each +\ rem [ + in-d>> rem-custom-inlining +] "custom-inlining" set-word-prop + { bitand-integer-integer bitand-integer-fixnum diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index f6308ac40a..aba8dc9eda 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays.double system sorting math.libm -math.intervals ; +math.intervals quotations ; IN: compiler.tree.propagation.tests [ V{ } ] [ [ ] final-classes ] unit-test @@ -357,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ; ] unit-test [ V{ complex } ] [ - [ ] final-classes + [ complex boa ] final-classes ] unit-test [ V{ complex } ] [ @@ -375,7 +375,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ; [ V{ complex } ] [ [ { float float object } declare - [ "Oops" throw ] [ ] if + [ "Oops" throw ] [ complex boa ] if ] final-classes ] unit-test @@ -590,7 +590,7 @@ MIXIN: empty-mixin [ V{ float } ] [ [ - [ { float float } declare ] + [ { float float } declare complex boa ] [ 2drop C{ 0.0 0.0 } ] if real-part ] final-classes @@ -686,3 +686,11 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test [ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test + +! Mutable tuples with circularity should not cause problems +TUPLE: circle me ; + +[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test + +! Joe found an oversight +[ V{ integer } ] [ [ >integer ] final-classes ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 9937c6b9c4..5837d59ef9 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -109,7 +109,7 @@ M: #declare propagate-before : output-value-infos ( #call word -- infos ) { - { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] } + { [ dup \ eq? ] [ drop propagate- ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } { [ dup predicate? ] [ propagate-predicate ] } { [ dup "outputs" word-prop ] [ call-outputs-quot ] } diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 8192b1c520..86114772f7 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry assocs arrays byte-arrays strings accessors sequences kernel slots classes.algebra classes.tuple classes.tuple.private @@ -8,9 +8,6 @@ IN: compiler.tree.propagation.slots ! Propagation of immutable slots and array lengths -! Revisit this code when delegation is removed and when complex -! numbers become tuples. - UNION: fixed-length-sequence array byte-array string ; : sequence-constructor? ( word -- ? ) @@ -29,33 +26,26 @@ UNION: fixed-length-sequence array byte-array string ; [ constructor-output-class ] bi* value-info-intersect 1array ; -: tuple-constructor? ( word -- ? ) - { } memq? ; - : fold- ( values class -- info ) [ [ literal>> ] map ] dip prefix >tuple ; +: read-only-slots ( values class -- slots ) + all-slots + [ read-only>> [ value-info ] [ drop f ] if ] 2map + f prefix ; + : (propagate-tuple-constructor) ( values class -- info ) - [ [ value-info ] map ] dip [ read-only-slots ] keep + [ read-only-slots ] keep over rest-slice [ dup [ literal?>> ] when ] all? [ [ rest-slice ] dip fold- ] [ ] if ; -: propagate- ( #call -- info ) +: propagate- ( #call -- infos ) in-d>> unclip-last - value-info literal>> first (propagate-tuple-constructor) ; - -: propagate- ( #call -- info ) - in-d>> [ value-info ] map complex ; - -: propagate-tuple-constructor ( #call word -- infos ) - { - { \ [ propagate- ] } - { \ [ propagate- ] } - } case 1array ; + value-info literal>> first (propagate-tuple-constructor) 1array ; : read-only-slot? ( n class -- ? ) all-slots [ offset>> = ] with find nip diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 8654a6f983..0d5f05fab0 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -32,7 +32,6 @@ TUPLE: empty-tuple ; [ dup [ drop f ] [ "A" throw ] if ] [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ] [ [ ] [ ] curry curry call ] - [ dup 1 slot drop 2 slot drop ] [ 1 cons boa over [ "A" throw ] when car>> ] [ [ <=> ] sort ] [ [ <=> ] with search ] @@ -40,7 +39,7 @@ TUPLE: empty-tuple ; ! A more complicated example : impeach-node ( quot: ( node -- ) -- ) - dup slip impeach-node ; inline recursive + [ call ] keep impeach-node ; inline recursive : bleach-node ( quot: ( node -- ) -- ) [ bleach-node ] curry [ ] compose impeach-node ; inline recursive diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 1e00efa835..107ea59902 100755 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes ) : unbox- ( #call -- nodes ) dup unbox-output? [ in-d>> 1 tail* #drop ] when ; -: unbox- ( #call -- nodes ) - dup unbox-output? [ drop { } ] when ; - : (flatten-values) ( values accum -- ) dup '[ dup unboxed-allocation @@ -70,7 +67,6 @@ M: #push unbox-tuples* ( #push -- nodes ) M: #call unbox-tuples* dup word>> { { \ [ unbox- ] } - { \ [ unbox- ] } { \ slot [ unbox-slot-access ] } [ drop ] } case ; diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 46f6639ab8..1956cd9c20 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks \ event-stream-counter counter ; [ - event-stream-callbacks global - [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at + event-stream-callbacks + [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global ] "core-foundation" add-init-hook : add-event-source-callback ( quot -- id ) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 5e95e2e36e..924f7130f0 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ; +FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ; + +FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ; +FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ; + +FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ; + +FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ; + be % ; : a-insn ( d a b c xo rc opcode -- ) [ { 0 1 6 11 16 21 } bitfield ] dip insn ; @@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ; GENERIC# (B) 2 ( dest aa lk -- ) M: integer (B) 18 i-insn ; -M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ; -M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; GENERIC: BC ( a b c -- ) M: integer BC 0 0 16 b-insn ; -M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ; -M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; : CREATE-B ( -- word ) scan "B" prepend create-in ; SYNTAX: BC: CREATE-B scan-word scan-word - [ rot BC ] 2curry (( c -- )) define-declared ; + '[ [ _ _ ] dip BC ] (( c -- )) define-declared ; SYNTAX: B: CREATE-B scan-word scan-word scan-word scan-word scan-word - [ b-insn ] curry curry curry curry curry - (( bo -- )) define-declared ; + '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 1431d471c1..b09938f4b9 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -2,17 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system cpu.ppc.assembler compiler.codegen.fixup compiler.units -compiler.constants math math.private layouts words words.private +compiler.constants math math.private layouts words vocabs slots.private locals.backend ; IN: bootstrap.ppc 4 \ cell set big-endian on -4 jit-code-format set - -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 : factor-area-size ( -- n ) 4 bootstrap-cells ; @@ -23,73 +21,57 @@ CONSTANT: rs-reg 30 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ; [ - 0 6 LOAD32 - 11 6 profile-count-offset LWZ + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 11 3 profile-count-offset LWZ 11 11 1 tag-fixnum ADDI - 11 6 profile-count-offset STW - 11 6 word-code-offset LWZ + 11 3 profile-count-offset STW + 11 3 word-code-offset LWZ 11 11 compiled-header-size ADDI 11 MTCTR BCTR -] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define +] jit-profiling jit-define [ - 0 6 LOAD32 + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel 0 MFLR 1 1 stack-frame SUBI - 6 1 xt-save STW - stack-frame 6 LI - 6 1 next-save STW + 3 1 xt-save STW + stack-frame 3 LI + 3 1 next-save STW 0 1 lr-save stack-frame + STW -] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define +] jit-prolog jit-define [ - 0 6 LOAD32 - 6 ds-reg 4 STWU -] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 3 ds-reg 4 STWU +] jit-push-immediate jit-define [ - 0 6 LOAD32 - 7 6 0 LWZ - 1 7 0 STW -] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define - -[ - 0 6 LOAD32 - 6 MTCTR + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel + 4 3 0 LWZ + 1 4 0 STW + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel + 3 MTCTR BCTR -] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define +] jit-primitive jit-define -[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define +[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define -[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define +[ + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel + 0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel +] jit-word-jump jit-define + +[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI 0 3 \ f tag-number CMPI 2 BEQ - 0 B -] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define - -[ - 0 B -] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define - -: jit-jump-quot ( -- ) - 4 3 quot-xt-offset LWZ - 4 MTCTR - BCTR ; - -[ - 0 3 LOAD32 - 6 ds-reg 0 LWZ - 6 6 1 SRAWI - 3 3 6 ADD - 3 3 array-start-offset LWZ - ds-reg dup 4 SUBI - jit-jump-quot -] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define + 0 B rc-relative-ppc-3 rt-xt jit-rel + 0 B rc-relative-ppc-3 rt-xt jit-rel +] jit-if jit-define : jit->r ( -- ) 4 ds-reg 0 LWZ @@ -139,46 +121,142 @@ CONSTANT: rs-reg 30 [ jit->r - 0 BL + 0 BL rc-relative-ppc-3 rt-xt jit-rel jit-r> -] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define +] jit-dip jit-define [ jit-2>r - 0 BL + 0 BL rc-relative-ppc-3 rt-xt jit-rel jit-2r> -] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define +] jit-2dip jit-define [ jit-3>r - 0 BL + 0 BL rc-relative-ppc-3 rt-xt jit-rel jit-3r> -] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define +] jit-3dip jit-define + +: prepare-(execute) ( -- operand ) + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 4 3 word-xt-offset LWZ + 4 ; + +[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define + +[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define [ 0 1 lr-save stack-frame + LWZ 1 1 stack-frame ADDI 0 MTLR -] f f f jit-epilog jit-define +] jit-epilog jit-define -[ BLR ] f f f jit-return jit-define +[ BLR ] jit-return jit-define -! Sub-primitives +! ! ! Polymorphic inline caches + +! Don't touch r6 here; it's used to pass the tail call site +! address for tail PICs + +! Load a value from a stack position +[ + 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel +] pic-load jit-define + +! Tag +: load-tag ( -- ) + 4 4 tag-mask get ANDI + 4 4 tag-bits get SLWI ; + +[ load-tag ] pic-tag jit-define + +! Hi-tag +[ + 3 4 MR + load-tag + 0 4 object tag-number tag-fixnum CMPI + 2 BNE + 4 3 object tag-number neg LWZ +] pic-hi-tag jit-define + +! Tuple +[ + 3 4 MR + load-tag + 0 4 tuple tag-number tag-fixnum CMPI + 2 BNE + 4 3 tuple tag-number neg bootstrap-cell + LWZ +] pic-tuple jit-define + +! Hi-tag and tuple +[ + 3 4 MR + load-tag + ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) + 0 4 BIN: 110 tag-fixnum CMPI + 5 BLT + ! Untag r3 + 3 3 0 0 31 tag-bits get - RLWINM + ! Set r4 to 0 for objects, and bootstrap-cell for tuples + 4 4 1 tag-fixnum ANDI + 4 4 1 SRAWI + ! Load header cell or tuple layout cell + 4 4 3 LWZX +] pic-hi-tag-tuple jit-define + +[ + 0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel +] pic-check-tag jit-define + +[ + 0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 4 0 5 CMP +] pic-check jit-define + +[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define + +! ! ! Megamorphic caches + +[ + ! cache = ... + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + ! key = class + 5 4 MR + ! key &= cache.length - 1 + 5 5 mega-cache-size get 1- bootstrap-cell * ANDI + ! cache += array-start-offset + 3 3 array-start-offset ADDI + ! cache += key + 3 3 5 ADD + ! if(get(cache) == class) + 6 3 0 LWZ + 6 0 4 CMP + 10 BNE + ! megamorphic_cache_hits++ + 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel + 5 4 0 LWZ + 5 5 1 ADDI + 5 4 0 STW + ! ... goto get(cache + bootstrap-cell) + 3 3 4 LWZ + 3 3 word-xt-offset LWZ + 3 MTCTR + BCTR + ! fall-through on miss +] mega-lookup jit-define + +! ! ! Sub-primitives ! Quotations and words [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - jit-jump-quot -] f f f \ (call) define-sub-primitive - -[ - 3 ds-reg 0 LWZ - ds-reg dup 4 SUBI - 4 3 word-xt-offset LWZ + 4 3 quot-xt-offset LWZ 4 MTCTR BCTR -] f f f \ (execute) define-sub-primitive +] \ (call) define-sub-primitive ! Objects [ @@ -186,7 +264,7 @@ CONSTANT: rs-reg 30 3 3 tag-mask get ANDI 3 3 tag-bits get SLWI 3 ds-reg 0 STW -] f f f \ tag define-sub-primitive +] \ tag define-sub-primitive [ 3 ds-reg 0 LWZ @@ -195,25 +273,25 @@ CONSTANT: rs-reg 30 4 4 0 0 31 tag-bits get - RLWINM 4 3 3 LWZX 3 ds-reg 0 STW -] f f f \ slot define-sub-primitive +] \ slot define-sub-primitive ! Shufflers [ ds-reg dup 4 SUBI -] f f f \ drop define-sub-primitive +] \ drop define-sub-primitive [ ds-reg dup 8 SUBI -] f f f \ 2drop define-sub-primitive +] \ 2drop define-sub-primitive [ ds-reg dup 12 SUBI -] f f f \ 3drop define-sub-primitive +] \ 3drop define-sub-primitive [ 3 ds-reg 0 LWZ 3 ds-reg 4 STWU -] f f f \ dup define-sub-primitive +] \ dup define-sub-primitive [ 3 ds-reg 0 LWZ @@ -221,7 +299,7 @@ CONSTANT: rs-reg 30 ds-reg dup 8 ADDI 3 ds-reg 0 STW 4 ds-reg -4 STW -] f f f \ 2dup define-sub-primitive +] \ 2dup define-sub-primitive [ 3 ds-reg 0 LWZ @@ -231,36 +309,36 @@ CONSTANT: rs-reg 30 3 ds-reg 0 STW 4 ds-reg -4 STW 5 ds-reg -8 STW -] f f f \ 3dup define-sub-primitive +] \ 3dup define-sub-primitive [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI 3 ds-reg 0 STW -] f f f \ nip define-sub-primitive +] \ nip define-sub-primitive [ 3 ds-reg 0 LWZ ds-reg dup 8 SUBI 3 ds-reg 0 STW -] f f f \ 2nip define-sub-primitive +] \ 2nip define-sub-primitive [ 3 ds-reg -4 LWZ 3 ds-reg 4 STWU -] f f f \ over define-sub-primitive +] \ over define-sub-primitive [ 3 ds-reg -8 LWZ 3 ds-reg 4 STWU -] f f f \ pick define-sub-primitive +] \ pick define-sub-primitive [ 3 ds-reg 0 LWZ 4 ds-reg -4 LWZ 4 ds-reg 0 STW 3 ds-reg 4 STWU -] f f f \ dupd define-sub-primitive +] \ dupd define-sub-primitive [ 3 ds-reg 0 LWZ @@ -268,21 +346,21 @@ CONSTANT: rs-reg 30 3 ds-reg 4 STWU 4 ds-reg -4 STW 3 ds-reg -8 STW -] f f f \ tuck define-sub-primitive +] \ tuck define-sub-primitive [ 3 ds-reg 0 LWZ 4 ds-reg -4 LWZ 3 ds-reg -4 STW 4 ds-reg 0 STW -] f f f \ swap define-sub-primitive +] \ swap define-sub-primitive [ 3 ds-reg -4 LWZ 4 ds-reg -8 LWZ 3 ds-reg -8 STW 4 ds-reg -4 STW -] f f f \ swapd define-sub-primitive +] \ swapd define-sub-primitive [ 3 ds-reg 0 LWZ @@ -291,7 +369,7 @@ CONSTANT: rs-reg 30 4 ds-reg -8 STW 3 ds-reg -4 STW 5 ds-reg 0 STW -] f f f \ rot define-sub-primitive +] \ rot define-sub-primitive [ 3 ds-reg 0 LWZ @@ -300,13 +378,13 @@ CONSTANT: rs-reg 30 3 ds-reg -8 STW 5 ds-reg -4 STW 4 ds-reg 0 STW -] f f f \ -rot define-sub-primitive +] \ -rot define-sub-primitive -[ jit->r ] f f f \ load-local define-sub-primitive +[ jit->r ] \ load-local define-sub-primitive ! Comparisons : jit-compare ( insn -- ) - 0 3 LOAD32 + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel 4 ds-reg 0 LWZ 5 ds-reg -4 LWZU 5 0 4 CMP @@ -315,8 +393,7 @@ CONSTANT: rs-reg 30 3 ds-reg 0 STW ; : define-jit-compare ( insn word -- ) - [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip - define-sub-primitive ; + [ [ jit-compare ] curry ] dip define-sub-primitive ; \ BEQ \ eq? define-jit-compare \ BGE \ fixnum>= define-jit-compare @@ -336,7 +413,7 @@ CONSTANT: rs-reg 30 2 BNE 1 tag-fixnum 4 LI 4 ds-reg 0 STW -] f f f \ both-fixnums? define-sub-primitive +] \ both-fixnums? define-sub-primitive : jit-math ( insn -- ) 3 ds-reg 0 LWZ @@ -344,9 +421,9 @@ CONSTANT: rs-reg 30 [ 5 3 4 ] dip execute( dst src1 src2 -- ) 5 ds-reg 0 STW ; -[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive +[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive -[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive +[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive [ 3 ds-reg 0 LWZ @@ -354,20 +431,20 @@ CONSTANT: rs-reg 30 4 4 tag-bits get SRAWI 5 3 4 MULLW 5 ds-reg 0 STW -] f f f \ fixnum*fast define-sub-primitive +] \ fixnum*fast define-sub-primitive -[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive +[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive -[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive +[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive -[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive +[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive [ 3 ds-reg 0 LWZ 3 3 NOT 3 3 tag-mask get XORI 3 ds-reg 0 STW -] f f f \ fixnum-bitnot define-sub-primitive +] \ fixnum-bitnot define-sub-primitive [ 3 ds-reg 0 LWZ @@ -382,7 +459,7 @@ CONSTANT: rs-reg 30 2 BGT 5 7 MR 5 ds-reg 0 STW -] f f f \ fixnum-shift-fast define-sub-primitive +] \ fixnum-shift-fast define-sub-primitive [ 3 ds-reg 0 LWZ @@ -392,7 +469,7 @@ CONSTANT: rs-reg 30 6 5 3 MULLW 7 6 4 SUBF 7 ds-reg 0 STW -] f f f \ fixnum-mod define-sub-primitive +] \ fixnum-mod define-sub-primitive [ 3 ds-reg 0 LWZ @@ -401,7 +478,7 @@ CONSTANT: rs-reg 30 5 4 3 DIVW 5 5 tag-bits get SLWI 5 ds-reg 0 STW -] f f f \ fixnum/i-fast define-sub-primitive +] \ fixnum/i-fast define-sub-primitive [ 3 ds-reg 0 LWZ @@ -412,20 +489,20 @@ CONSTANT: rs-reg 30 5 5 tag-bits get SLWI 5 ds-reg -4 STW 7 ds-reg 0 STW -] f f f \ fixnum/mod-fast define-sub-primitive +] \ fixnum/mod-fast define-sub-primitive [ 3 ds-reg 0 LWZ 3 3 1 SRAWI rs-reg 3 3 LWZX 3 ds-reg 0 STW -] f f f \ get-local define-sub-primitive +] \ get-local define-sub-primitive [ 3 ds-reg 0 LWZ ds-reg ds-reg 4 SUBI 3 3 1 SRAWI rs-reg 3 rs-reg SUBF -] f f f \ drop-locals define-sub-primitive +] \ drop-locals define-sub-primitive [ "bootstrap.ppc" forget-vocab ] with-compilation-unit diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 85bf188bb8..442dd8e7ea 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,33 +1,39 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words -alien alien.c-types cpu.architecture cpu.ppc.assembler -compiler.cfg.registers compiler.cfg.instructions -compiler.constants compiler.codegen compiler.codegen.fixup -compiler.cfg.intrinsics compiler.cfg.stack-frame ; +alien alien.c-types literals cpu.architecture cpu.ppc.assembler +cpu.ppc.assembler.backend literals compiler.cfg.registers +compiler.cfg.instructions compiler.constants compiler.codegen +compiler.codegen.fixup compiler.cfg.intrinsics +compiler.cfg.stack-frame ; IN: cpu.ppc ! PowerPC register assignments: -! r2-r27: integer vregs -! r28: integer scratch -! r29: data stack -! r30: retain stack +! r2-r12: integer vregs +! r15-r29 +! r30: integer scratch ! f0-f29: float vregs -! f30, f31: float scratch +! f30: float scratch + +! Add some methods to the assembler that are useful to us +M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; +M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; enable-float-intrinsics -<< \ ##integer>float t frame-required? set-word-prop -\ ##float>integer t frame-required? set-word-prop >> +<< +\ ##integer>float t frame-required? set-word-prop +\ ##float>integer t frame-required? set-word-prop +>> M: ppc machine-registers { - { int-regs T{ range f 2 26 1 } } - { double-float-regs T{ range f 0 29 1 } } + { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] } + { double-float-regs $[ 0 29 [a,b] ] } } ; -CONSTANT: scratch-reg 28 +CONSTANT: scratch-reg 30 CONSTANT: fp-scratch-reg 30 M: ppc two-operand? f ; @@ -40,8 +46,8 @@ M: ppc %load-reference ( reg obj -- ) M: ppc %alien-global ( register symbol dll -- ) [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ; -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 GENERIC: loc-reg ( loc -- reg ) @@ -108,7 +114,12 @@ M: ppc stack-frame-size ( stack-frame -- i ) factor-area-size + 4 cells align ; -M: ppc %call ( label -- ) BL ; +M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; + +M: ppc %jump ( word -- ) + 0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here + 0 B rc-relative-ppc-3 rel-word-pic-tail ; + M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; @@ -120,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- ) BCTR ; M: ppc %dispatch-label ( word -- ) - 0 , rc-absolute-cell rel-word ; + B{ 0 0 0 0 } % rc-absolute-cell rel-word ; :: (%slot) ( obj slot tag temp -- reg offset ) temp slot obj ADD @@ -641,10 +652,10 @@ M: ppc %alien-callback ( quot -- ) M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - 13 3 MR ; + 15 3 MR ; M: ppc %alien-indirect ( -- ) - 13 MTLR BLRL ; + 15 MTLR BLRL ; M: ppc %callback-value ( ctype -- ) ! Save top of data stack @@ -702,3 +713,4 @@ USE: vocabs.loader } cond "complex-double" c-type t >>return-in-registers? drop +"bool" c-type 4 >>size 4 >>align drop \ No newline at end of file diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index b280afc01e..0a0ac4a53e 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- ) M: x86.32 param-reg-1 EAX ; M: x86.32 param-reg-2 EDX ; +M: x86.32 pic-tail-reg EBX ; + M: x86.32 reserved-area-size 0 ; -M: x86.32 %alien-invoke (CALL) rel-dlsym ; +M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; -M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; +M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ; M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type @@ -309,7 +311,7 @@ FUNCTION: bool check_sse2 ( ) ; check_sse2 ; "-no-sse2" (command-line) member? [ - optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable + [ { check_sse2 } compile ] with-optimizer "Checking if your CPU supports SSE2..." print flush sse2? [ diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 5d88f699b8..490d37ccbc 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants ; @@ -22,13 +22,13 @@ IN: bootstrap.x86 : rex-length ( -- n ) 0 ; [ - temp0 0 [] MOV ! load stack_chain - temp0 [] stack-reg MOV ! save stack pointer -] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define - -[ - (JMP) drop -] rc-relative rt-primitive 1 jit-primitive jit-define + ! load stack_chain + temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel + ! save stack pointer + temp0 [] stack-reg MOV + ! call the primitive + 0 JMP rc-relative rt-primitive jit-rel +] jit-primitive jit-define << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8cc69958a4..ad1b487e44 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ; M: x86.64 param-reg-2 int-regs param-regs second ; : param-reg-3 ( -- reg ) int-regs param-regs third ; inline +M: x86.64 pic-tail-reg RBX ; + M: int-regs return-reg drop RAX ; M: float-regs return-reg drop XMM0 ; diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index ddf5791009..c5c7e63dbc 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants math ; @@ -20,15 +20,16 @@ IN: bootstrap.x86 : rex-length ( -- n ) 1 ; [ - temp0 0 MOV ! load stack_chain + ! load stack_chain + temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel temp0 temp0 [] MOV - temp0 [] stack-reg MOV ! save stack pointer -] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define - -[ - temp1 0 MOV ! load XT - temp1 JMP ! go -] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define + ! save stack pointer + temp0 [] stack-reg MOV + ! load XT + temp1 0 MOV rc-absolute-cell rt-primitive jit-rel + ! go + temp1 JMP +] jit-primitive jit-define << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> call diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 49b0961819..203edf956e 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -62,3 +62,5 @@ IN: cpu.x86.assembler.tests [ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test [ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test + +[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 3a98d47416..2b40aa2053 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,12 +1,11 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays cpu.architecture compiler.constants -compiler.codegen.fixup io.binary kernel combinators -kernel.private math namespaces make sequences words system -layouts math.order accessors cpu.x86.assembler.syntax ; +USING: arrays io.binary kernel combinators +kernel.private math namespaces make sequences words system layouts +math.order accessors cpu.x86.assembler.syntax ; IN: cpu.x86.assembler -! A postfix assembler for x86 and AMD64. +! A postfix assembler for x86-32 and x86-64. ! In 32-bit mode, { 1234 } is absolute indirect addressing. ! In 64-bit mode, { 1234 } is RIP-relative. @@ -296,35 +295,23 @@ M: operand (MOV-I) { BIN: 000 t HEX: c6 } pick byte? [ immediate-1 ] [ immediate-4 ] if ; -PREDICATE: callable < word register? not ; - GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; -M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ; M: operand MOV HEX: 88 2-operand ; : LEA ( dst src -- ) swap HEX: 8d 2-operand ; ! Control flow GENERIC: JMP ( op -- ) -: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ; -M: f JMP (JMP) 2drop ; -M: callable JMP (JMP) rel-word ; -M: label JMP (JMP) label-fixup ; +M: integer JMP HEX: e9 , 4, ; M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) -: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; -M: f CALL (CALL) 2drop ; -M: callable CALL (CALL) rel-word ; -M: label CALL (CALL) label-fixup ; +M: integer CALL HEX: e8 , 4, ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) -: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ; -M: f JUMPcc nip (JUMPcc) drop ; -M: callable JUMPcc (JUMPcc) rel-word ; -M: label JUMPcc (JUMPcc) label-fixup ; +M: integer JUMPcc extended-opcode, 4, ; : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; @@ -382,6 +369,10 @@ GENERIC: CMP ( dst src -- ) M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ; M: operand CMP OCT: 070 2-operand ; +GENERIC: TEST ( dst src -- ) +M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ; +M: operand TEST OCT: 204 2-operand ; + : XCHG ( dst src -- ) OCT: 207 2-operand ; : BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index b63d31364b..474ce2ea46 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -1,18 +1,16 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel kernel.private namespaces system cpu.x86.assembler layouts compiler.units math math.private compiler.constants vocabs slots.private words -words.private locals.backend ; +locals.backend make sequences combinators arrays ; IN: bootstrap.x86 big-endian off -1 jit-code-format set - [ ! Load word - temp0 0 MOV + temp0 0 MOV rc-absolute-cell rt-immediate jit-rel ! Bump profiling counter temp0 profile-count-offset [+] 1 tag-fixnum ADD ! Load word->code @@ -21,35 +19,40 @@ big-endian off temp0 compiled-header-size ADD ! Jump to XT temp0 JMP -] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define +] jit-profiling jit-define [ ! load XT - temp0 0 MOV + temp0 0 MOV rc-absolute-cell rt-this jit-rel ! save stack frame size stack-frame-size PUSH ! push XT temp0 PUSH ! alignment stack-reg stack-frame-size 3 bootstrap-cells - SUB -] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define +] jit-prolog jit-define [ ! load literal - temp0 0 MOV + temp0 0 MOV rc-absolute-cell rt-immediate jit-rel ! increment datastack pointer ds-reg bootstrap-cell ADD ! store literal on datastack ds-reg [] temp0 MOV -] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define +] jit-push-immediate jit-define [ - f JMP -] rc-relative rt-xt 1 jit-word-jump jit-define + temp3 0 MOV rc-absolute-cell rt-here jit-rel + 0 JMP rc-relative rt-xt-pic-tail jit-rel +] jit-word-jump jit-define [ - f CALL -] rc-relative rt-xt 1 jit-word-call jit-define + 0 CALL rc-relative rt-xt-pic jit-rel +] jit-word-call jit-define + +[ + 0 JMP rc-relative rt-xt jit-rel +] jit-word-special jit-define [ ! load boolean @@ -59,31 +62,10 @@ big-endian off ! compare boolean with f temp0 \ f tag-number CMP ! jump to true branch if not equal - f JNE -] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define - -[ + 0 JNE rc-relative rt-xt jit-rel ! jump to false branch if equal - f JMP -] rc-relative rt-xt 1 jit-if-2 jit-define - -[ - ! load dispatch table - temp1 0 MOV - ! load index - temp0 ds-reg [] MOV - ! turn it into an array offset - fixnum>slot@ - ! pop index - ds-reg bootstrap-cell SUB - ! compute quotation location - temp0 temp1 ADD - ! load quotation - arg temp0 array-start-offset [+] MOV - ! execute branch. the quot must be in arg, since it might - ! not be compiled yet - arg quot-xt-offset [+] JMP -] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define + 0 JMP rc-relative rt-xt jit-rel +] jit-if jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD @@ -135,30 +117,133 @@ big-endian off [ jit->r - f CALL + 0 CALL rc-relative rt-xt jit-rel jit-r> -] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define +] jit-dip jit-define [ jit-2>r - f CALL + 0 CALL rc-relative rt-xt jit-rel jit-2r> -] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define +] jit-2dip jit-define [ jit-3>r - f CALL + 0 CALL rc-relative rt-xt jit-rel jit-3r> -] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define +] jit-3dip jit-define + +: prepare-(execute) ( -- operand ) + ! load from stack + temp0 ds-reg [] MOV + ! pop stack + ds-reg bootstrap-cell SUB + ! execute word + temp0 word-xt-offset [+] ; + +[ prepare-(execute) JMP ] jit-execute-jump jit-define + +[ prepare-(execute) CALL ] jit-execute-call jit-define [ ! unwind stack frame stack-reg stack-frame-size bootstrap-cell - ADD -] f f f jit-epilog jit-define +] jit-epilog jit-define -[ 0 RET ] f f f jit-return jit-define +[ 0 RET ] jit-return jit-define -! Sub-primitives +! ! ! Polymorphic inline caches + +! The PIC and megamorphic code stubs are not permitted to touch temp3. + +! Load a value from a stack position +[ + temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel +] pic-load jit-define + +! Tag +: load-tag ( -- ) + temp1 tag-mask get AND + temp1 tag-bits get SHL ; + +[ load-tag ] pic-tag jit-define + +! The 'make' trick lets us compute the jump distance for the +! conditional branches there + +! Hi-tag +[ + temp0 temp1 MOV + load-tag + temp1 object tag-number tag-fixnum CMP + [ temp1 temp0 object tag-number neg [+] MOV ] { } make + [ length JNE ] [ % ] bi +] pic-hi-tag jit-define + +! Tuple +[ + temp0 temp1 MOV + load-tag + temp1 tuple tag-number tag-fixnum CMP + [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make + [ length JNE ] [ % ] bi +] pic-tuple jit-define + +! Hi-tag and tuple +[ + temp0 temp1 MOV + load-tag + ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) + temp1 BIN: 110 tag-fixnum CMP + [ + ! Untag temp0 + temp0 tag-mask get bitnot AND + ! Set temp1 to 0 for objects, and bootstrap-cell for tuples + temp1 1 tag-fixnum AND + bootstrap-cell 4 = [ temp1 1 SHR ] when + ! Load header cell or tuple layout cell + temp1 temp0 temp1 [+] MOV + ] [ ] make [ length JL ] [ % ] bi +] pic-hi-tag-tuple jit-define + +[ + temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel +] pic-check-tag jit-define + +[ + temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel + temp1 temp2 CMP +] pic-check jit-define + +[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define + +! ! ! Megamorphic caches + +[ + ! cache = ... + temp0 0 MOV rc-absolute-cell rt-immediate jit-rel + ! key = class + temp2 temp1 MOV + bootstrap-cell 8 = [ temp2 1 SHL ] when + ! key &= cache.length - 1 + temp2 mega-cache-size get 1- bootstrap-cell * AND + ! cache += array-start-offset + temp0 array-start-offset ADD + ! cache += key + temp0 temp2 ADD + ! if(get(cache) == class) + temp0 [] temp1 CMP + bootstrap-cell 4 = 14 22 ? JNE ! Yuck! + ! megamorphic_cache_hits++ + temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel + temp1 [] 1 ADD + ! goto get(cache + bootstrap-cell) + temp0 temp0 bootstrap-cell [+] MOV + temp0 word-xt-offset [+] JMP + ! fall-through on miss +] mega-lookup jit-define + +! ! ! Sub-primitives ! Quotations and words [ @@ -168,16 +253,7 @@ big-endian off ds-reg bootstrap-cell SUB ! call quotation arg quot-xt-offset [+] JMP -] f f f \ (call) define-sub-primitive - -[ - ! load from stack - temp0 ds-reg [] MOV - ! pop stack - ds-reg bootstrap-cell SUB - ! execute word - temp0 word-xt-offset [+] JMP -] f f f \ (execute) define-sub-primitive +] \ (call) define-sub-primitive ! Objects [ @@ -189,7 +265,7 @@ big-endian off temp0 tag-bits get SHL ! push to stack ds-reg [] temp0 MOV -] f f f \ tag define-sub-primitive +] \ tag define-sub-primitive [ ! load slot number @@ -207,26 +283,26 @@ big-endian off temp0 temp1 temp0 [+] MOV ! push to stack ds-reg [] temp0 MOV -] f f f \ slot define-sub-primitive +] \ slot define-sub-primitive ! Shufflers [ ds-reg bootstrap-cell SUB -] f f f \ drop define-sub-primitive +] \ drop define-sub-primitive [ ds-reg 2 bootstrap-cells SUB -] f f f \ 2drop define-sub-primitive +] \ 2drop define-sub-primitive [ ds-reg 3 bootstrap-cells SUB -] f f f \ 3drop define-sub-primitive +] \ 3drop define-sub-primitive [ temp0 ds-reg [] MOV ds-reg bootstrap-cell ADD ds-reg [] temp0 MOV -] f f f \ dup define-sub-primitive +] \ dup define-sub-primitive [ temp0 ds-reg [] MOV @@ -234,7 +310,7 @@ big-endian off ds-reg 2 bootstrap-cells ADD ds-reg [] temp0 MOV ds-reg bootstrap-cell neg [+] temp1 MOV -] f f f \ 2dup define-sub-primitive +] \ 2dup define-sub-primitive [ temp0 ds-reg [] MOV @@ -244,31 +320,31 @@ big-endian off ds-reg [] temp0 MOV ds-reg -1 bootstrap-cells [+] temp1 MOV ds-reg -2 bootstrap-cells [+] temp3 MOV -] f f f \ 3dup define-sub-primitive +] \ 3dup define-sub-primitive [ temp0 ds-reg [] MOV ds-reg bootstrap-cell SUB ds-reg [] temp0 MOV -] f f f \ nip define-sub-primitive +] \ nip define-sub-primitive [ temp0 ds-reg [] MOV ds-reg 2 bootstrap-cells SUB ds-reg [] temp0 MOV -] f f f \ 2nip define-sub-primitive +] \ 2nip define-sub-primitive [ temp0 ds-reg -1 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD ds-reg [] temp0 MOV -] f f f \ over define-sub-primitive +] \ over define-sub-primitive [ temp0 ds-reg -2 bootstrap-cells [+] MOV ds-reg bootstrap-cell ADD ds-reg [] temp0 MOV -] f f f \ pick define-sub-primitive +] \ pick define-sub-primitive [ temp0 ds-reg [] MOV @@ -276,7 +352,7 @@ big-endian off ds-reg [] temp1 MOV ds-reg bootstrap-cell ADD ds-reg [] temp0 MOV -] f f f \ dupd define-sub-primitive +] \ dupd define-sub-primitive [ temp0 ds-reg [] MOV @@ -285,21 +361,21 @@ big-endian off ds-reg [] temp0 MOV ds-reg -1 bootstrap-cells [+] temp1 MOV ds-reg -2 bootstrap-cells [+] temp0 MOV -] f f f \ tuck define-sub-primitive +] \ tuck define-sub-primitive [ temp0 ds-reg [] MOV temp1 ds-reg bootstrap-cell neg [+] MOV ds-reg bootstrap-cell neg [+] temp0 MOV ds-reg [] temp1 MOV -] f f f \ swap define-sub-primitive +] \ swap define-sub-primitive [ temp0 ds-reg -1 bootstrap-cells [+] MOV temp1 ds-reg -2 bootstrap-cells [+] MOV ds-reg -2 bootstrap-cells [+] temp0 MOV ds-reg -1 bootstrap-cells [+] temp1 MOV -] f f f \ swapd define-sub-primitive +] \ swapd define-sub-primitive [ temp0 ds-reg [] MOV @@ -308,7 +384,7 @@ big-endian off ds-reg -2 bootstrap-cells [+] temp1 MOV ds-reg -1 bootstrap-cells [+] temp0 MOV ds-reg [] temp3 MOV -] f f f \ rot define-sub-primitive +] \ rot define-sub-primitive [ temp0 ds-reg [] MOV @@ -317,14 +393,14 @@ big-endian off ds-reg -2 bootstrap-cells [+] temp0 MOV ds-reg -1 bootstrap-cells [+] temp3 MOV ds-reg [] temp1 MOV -] f f f \ -rot define-sub-primitive +] \ -rot define-sub-primitive -[ jit->r ] f f f \ load-local define-sub-primitive +[ jit->r ] \ load-local define-sub-primitive ! Comparisons : jit-compare ( insn -- ) ! load t - temp3 0 MOV + temp3 0 MOV rc-absolute-cell rt-immediate jit-rel ! load f temp1 \ f tag-number MOV ! load first value @@ -339,8 +415,7 @@ big-endian off ds-reg [] temp1 MOV ; : define-jit-compare ( insn word -- ) - [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip - define-sub-primitive ; + [ [ jit-compare ] curry ] dip define-sub-primitive ; \ CMOVE \ eq? define-jit-compare \ CMOVGE \ fixnum>= define-jit-compare @@ -357,9 +432,9 @@ big-endian off ! compute result [ ds-reg [] temp0 ] dip execute( dst src -- ) ; -[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive +[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive -[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive +[ \ SUB jit-math ] \ fixnum-fast define-sub-primitive [ ! load second input @@ -374,20 +449,20 @@ big-endian off temp0 temp1 IMUL2 ! push result ds-reg [] temp1 MOV -] f f f \ fixnum*fast define-sub-primitive +] \ fixnum*fast define-sub-primitive -[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive +[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive -[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive +[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive -[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive +[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive [ ! complement ds-reg [] NOT ! clear tag bits ds-reg [] tag-mask get XOR -] f f f \ fixnum-bitnot define-sub-primitive +] \ fixnum-bitnot define-sub-primitive [ ! load shift count @@ -411,7 +486,7 @@ big-endian off temp1 temp3 CMOVGE ! push to stack ds-reg [] temp1 MOV -] f f f \ fixnum-shift-fast define-sub-primitive +] \ fixnum-shift-fast define-sub-primitive : jit-fixnum-/mod ( -- ) ! load second parameter @@ -431,7 +506,7 @@ big-endian off ds-reg bootstrap-cell SUB ! push to stack ds-reg [] mod-arg MOV -] f f f \ fixnum-mod define-sub-primitive +] \ fixnum-mod define-sub-primitive [ jit-fixnum-/mod @@ -441,7 +516,7 @@ big-endian off div-arg tag-bits get SHL ! push to stack ds-reg [] div-arg MOV -] f f f \ fixnum/i-fast define-sub-primitive +] \ fixnum/i-fast define-sub-primitive [ jit-fixnum-/mod @@ -450,7 +525,7 @@ big-endian off ! push to stack ds-reg [] mod-arg MOV ds-reg bootstrap-cell neg [+] div-arg MOV -] f f f \ fixnum/mod-fast define-sub-primitive +] \ fixnum/mod-fast define-sub-primitive [ temp0 ds-reg [] MOV @@ -461,7 +536,7 @@ big-endian off temp1 1 tag-fixnum MOV temp0 temp1 CMOVE ds-reg [] temp0 MOV -] f f f \ both-fixnums? define-sub-primitive +] \ both-fixnums? define-sub-primitive [ ! load local number @@ -472,7 +547,7 @@ big-endian off temp0 rs-reg temp0 [+] MOV ! push to stack ds-reg [] temp0 MOV -] f f f \ get-local define-sub-primitive +] \ get-local define-sub-primitive [ ! load local count @@ -483,6 +558,6 @@ big-endian off fixnum>slot@ ! decrement retain stack pointer rs-reg temp0 SUB -] f f f \ drop-locals define-sub-primitive +] \ drop-locals define-sub-primitive [ "bootstrap.x86" forget-vocab ] with-compilation-unit diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 2859e71be2..e12cec9738 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -11,6 +11,10 @@ IN: cpu.x86 << enable-fixnum-log2 >> +! Add some methods to the assembler to be more useful to the backend +M: label JMP 0 JMP rc-relative label-fixup ; +M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ; + M: x86 two-operand? t ; HOOK: temp-reg-1 cpu ( -- reg ) @@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg ) HOOK: param-reg-1 cpu ( -- reg ) HOOK: param-reg-2 cpu ( -- reg ) +HOOK: pic-tail-reg cpu ( -- reg ) + M: x86 %load-immediate MOV ; M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ; @@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i ) reserved-area-size + align-stack ; -M: x86 %call ( label -- ) CALL ; -M: x86 %jump-label ( label -- ) JMP ; +M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; + +: xt-tail-pic-offset ( -- n ) + #! See the comment in vm/cpu-x86.hpp + cell 4 + 1 + ; inline + +M: x86 %jump ( word -- ) + pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here + 0 JMP rc-relative rel-word-pic-tail ; + +M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; + M: x86 %return ( -- ) 0 RET ; : code-alignment ( align -- n ) diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index ff5869efab..ff9986432c 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -1,6 +1,6 @@ USING: alien arrays generic generic.math help.markup help.syntax kernel math memory strings sbufs vectors io io.files classes -help generic.standard continuations io.files.private listener +help generic.single continuations io.files.private listener alien.libraries ; IN: debugger diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index d8ebd5bbf9..bb0268f048 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: slots arrays definitions generic hashtables summary io -kernel math namespaces make prettyprint prettyprint.config -sequences assocs sequences.private strings io.styles -io.pathnames vectors words system splitting math.parser -classes.mixin classes.tuple continuations continuations.private -combinators generic.math classes.builtin classes compiler.units -generic.standard vocabs init kernel.private io.encodings -accessors math.order destructors source-files parser -classes.tuple.parser effects.parser lexer +USING: slots arrays definitions generic hashtables summary io kernel +math namespaces make prettyprint prettyprint.config sequences assocs +sequences.private strings io.styles io.pathnames vectors words system +splitting math.parser classes.mixin classes.tuple continuations +continuations.private combinators generic.math classes.builtin classes +compiler.units generic.standard generic.single vocabs init +kernel.private io.encodings accessors math.order destructors +source-files parser classes.tuple.parser effects.parser lexer generic.parser strings.parser vocabs.loader vocabs.parser see source-files.errors ; IN: debugger @@ -17,6 +16,7 @@ GENERIC: error. ( error -- ) GENERIC: error-help ( error -- topic ) M: object error. . ; + M: object error-help drop f ; M: tuple error-help class ; @@ -77,7 +77,7 @@ M: string error. print ; "Object did not survive image save/load: " write third . ; : io-error. ( error -- ) - "I/O error: " write third print ; + "I/O error #" write third . ; : type-check-error. ( obj -- ) "Type check error" print @@ -98,9 +98,7 @@ HOOK: signal-error. os ( obj -- ) "Cannot convert to C string: " write third . ; : ffi-error. ( obj -- ) - "FFI: " write - dup third [ write ": " write ] when* - fourth print ; + "FFI error" print drop ; : heap-scan-error. ( obj -- ) "Cannot do next-object outside begin/end-scan" print drop ; diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 42b727852e..42e770aa75 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -24,7 +24,7 @@ HELP: CONSULT: HELP: SLOT-PROTOCOL: { $syntax "SLOT-PROTOCOL: protocol-name slots... ;" } -{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ; +{ $description "Defines a protocol consisting of reader and writer words for the listed slot names." } ; { define-protocol POSTPONE: PROTOCOL: } related-words diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index f6a40d8dc8..9f9aca8702 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,6 +1,6 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string -accessors eval multiline generic.standard delegate.protocols +accessors eval multiline generic.single delegate.protocols delegate.private assocs see ; IN: delegate.tests diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 12e39746c7..e210ad35ce 100755 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -15,6 +15,7 @@ $nl "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } +{ $subsection dlist-filter } { $subsection dlist-any? } "Deleting a node matching a predicate:" { $subsection delete-node-if* } @@ -40,6 +41,11 @@ HELP: dlist-find "This operation is O(n)." } ; +HELP: dlist-filter +{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } } +{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." } +{ $side-effects { "dlist" } } ; + HELP: dlist-any? { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 3689680157..8072c93753 100755 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -79,3 +79,8 @@ IN: dlists.tests [ V{ f 3 1 f } ] [ 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test [ V{ } ] [ dlist>seq ] unit-test + +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 3d7224ed16..89675c6469 100755 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-next drop + next>> f over set-prev-when ] change-front drop ] keep @@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-prev drop + prev>> f over set-next-when ] change-back drop ] keep @@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- ) : 1dlist ( obj -- dlist ) [ push-front ] keep ; +: dlist-filter ( dlist quot -- dlist ) + over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline + M: dlist clone [ '[ _ push-back ] dlist-each ] keep ; diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor index f485f1bec1..0776f8f158 100644 --- a/basis/documents/elements/elements.factor +++ b/basis/documents/elements/elements.factor @@ -79,6 +79,13 @@ M: one-word-elt next-elt drop [ f next-word ] modify-col ; +SINGLETON: word-start-elt + +M: word-start-elt prev-elt + drop one-word-elt prev-elt ; + +M: word-start-elt next-elt 2drop ; + SINGLETON: word-elt M: word-elt prev-elt diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 6088400bd8..d5b4b909e3 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser lexer kernel namespaces sequences definitions io.files -io.backend io.pathnames io summary continuations tools.crossref -tools.vocabs prettyprint source-files source-files.errors assocs -vocabs vocabs.loader splitting accessors debugger prettyprint -help.topics ; +USING: parser lexer kernel namespaces sequences definitions +io.files io.backend io.pathnames io summary continuations +tools.crossref vocabs.hierarchy prettyprint source-files +source-files.errors assocs vocabs vocabs.loader splitting +accessors debugger prettyprint help.topics ; IN: editors TUPLE: no-edit-hook ; diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index ac0b0850b4..5a517e4ac4 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -4,7 +4,7 @@ USING: accessors arrays ascii assocs calendar combinators fry kernel generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations -sequences splitting strings unicode.case vectors ; +sequences splitting strings unicode.case vectors combinators.smart ; IN: formatting @@ -113,7 +113,6 @@ MACRO: printf ( format-string -- ) : sprintf ( format-string -- result ) [ printf ] with-string-writer ; inline - string 2 CHAR: 0 pad-head ; inline @@ -129,12 +128,15 @@ MACRO: printf ( format-string -- ) [ pad-00 ] map "/" join ; inline : >datetime ( timestamp -- string ) - { [ day-of-week day-abbreviation3 ] - [ month>> month-abbreviation ] - [ day>> pad-00 ] - [ >time ] - [ year>> number>string ] - } cleave 5 narray " " join ; inline + [ + { + [ day-of-week day-abbreviation3 ] + [ month>> month-abbreviation ] + [ day>> pad-00 ] + [ >time ] + [ year>> number>string ] + } cleave + ] output>array " " join ; inline : (week-of-year) ( timestamp day -- n ) [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when @@ -187,5 +189,3 @@ PRIVATE> MACRO: strftime ( format-string -- ) parse-strftime [ length ] keep [ ] join '[ _ @ reverse concat nip ] ; - - diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 5d750775e5..32ad856d00 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -57,7 +57,6 @@ $nl "Here are some built-in combinators rewritten in terms of fried quotations:" { $table { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } - { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } } { { $link curry } { $snippet ": curry '[ _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } } diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index 14877110d3..9d51ba259e 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -66,7 +66,7 @@ ERROR: ftp-error got expected ; : list ( url -- ftp-response ) utf8 open-passive-client ftp-list - lines + stream-lines swap >>strings read-response 226 ftp-assert parse-list ; diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 37ec1d3e15..03bd21e58c 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -63,7 +63,44 @@ WHERE [ 4 ] [ 1 3 blah ] unit-test -GENERIC: some-generic ( a -- b ) +<< + +FUNCTOR: symbol-test ( W -- ) + +W DEFINES ${W} + +WHERE + +SYMBOL: W + +;FUNCTOR + +"blorgh" symbol-test + +>> + +[ blorgh ] [ blorgh ] unit-test + +<< + +FUNCTOR: generic-test ( W -- ) + +W DEFINES ${W} + +WHERE + +GENERIC: W ( a -- b ) +M: object W ; +M: integer W 1 + ; + +;FUNCTOR + +"snurv" generic-test + +>> + +[ 2 ] [ 1 snurv ] unit-test +[ 3.0 ] [ 3.0 snurv ] unit-test ! Does replacing an ordinary word with a functor-generated one work? [ [ ] ] [ @@ -71,17 +108,21 @@ GENERIC: some-generic ( a -- b ) TUPLE: some-tuple ; : some-word ( -- ) ; + GENERIC: some-generic ( a -- b ) M: some-tuple some-generic ; + SYMBOL: some-symbol "> "functors-test" parse-stream ] unit-test : test-redefinition ( -- ) [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test + [ t ] [ "some-generic" "functors.tests" lookup >boolean ] unit-test [ t ] [ "some-tuple" "functors.tests" lookup "some-generic" "functors.tests" lookup method >boolean ] unit-test ; + [ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test test-redefinition @@ -89,13 +130,16 @@ FUNCTOR: redefine-test ( W -- ) W-word DEFINES ${W}-word W-tuple DEFINES-CLASS ${W}-tuple -W-generic IS ${W}-generic +W-generic DEFINES ${W}-generic +W-symbol DEFINES ${W}-symbol WHERE TUPLE: W-tuple ; : W-word ( -- ) ; +GENERIC: W-generic ( a -- b ) M: W-tuple W-generic ; +SYMBOL: W-symbol ;FUNCTOR @@ -105,4 +149,5 @@ M: W-tuple W-generic ; "> "functors-test" parse-stream ] unit-test -test-redefinition \ No newline at end of file +test-redefinition + diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 309154fb49..edd4932c66 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel quotations classes.tuple make combinators generic -words interpolate namespaces sequences io.streams.string fry -classes.mixin effects lexer parser classes.tuple.parser -effects.parser locals.types locals.parser generic.parser -locals.rewrite.closures vocabs.parser classes.parser -arrays accessors ; +USING: accessors arrays classes.mixin classes.parser +classes.tuple classes.tuple.parser combinators effects +effects.parser fry generic generic.parser generic.standard +interpolate io.streams.string kernel lexer locals.parser +locals.rewrite.closures locals.types make namespaces parser +quotations sequences vocabs.parser words words.symbol ; IN: functors ! This is a hack @@ -18,6 +18,10 @@ IN: functors : define-declared* ( word def effect -- ) pick set-word define-declared ; +: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ; + +TUPLE: fake-call-next-method ; + TUPLE: fake-quotation seq ; GENERIC: >fake-quotations ( quot -- fake ) @@ -29,17 +33,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ; M: object >fake-quotations ; -GENERIC: fake-quotations> ( fake -- quot ) +GENERIC: (fake-quotations>) ( fake -- ) -M: fake-quotation fake-quotations> - seq>> [ fake-quotations> ] [ ] map-as ; +: fake-quotations> ( fake -- quot ) + [ (fake-quotations>) ] [ ] make ; -M: array fake-quotations> [ fake-quotations> ] map ; +M: fake-quotation (fake-quotations>) + [ seq>> [ (fake-quotations>) ] each ] [ ] make , ; -M: object fake-quotations> ; +M: array (fake-quotations>) + [ [ (fake-quotations>) ] each ] { } make , ; + +M: fake-call-next-method (fake-quotations>) + drop method-body get literalize , \ (call-next-method) , ; + +M: object (fake-quotations>) , ; : parse-definition* ( accum -- accum ) - parse-definition >fake-quotations parsed \ fake-quotations> parsed ; + parse-definition >fake-quotations parsed + [ fake-quotations> first ] over push-all ; : parse-declared* ( accum -- accum ) complete-effect @@ -64,7 +76,7 @@ SYNTAX: `TUPLE: SYNTAX: `M: scan-param parsed scan-param parsed - \ create-method-in parsed + [ create-method-in dup method-body set ] over push-all parse-definition* \ define* parsed ; @@ -80,6 +92,10 @@ SYNTAX: `: parse-declared* \ define-declared* parsed ; +SYNTAX: `SYMBOL: + scan-param parsed + \ define-symbol parsed ; + SYNTAX: `SYNTAX: scan-param parsed parse-definition* @@ -90,8 +106,15 @@ SYNTAX: `INSTANCE: scan-param parsed \ add-mixin-instance parsed ; +SYNTAX: `GENERIC: + scan-param parsed + complete-effect parsed + \ define-simple-generic* parsed ; + SYNTAX: `inline [ word make-inline ] over push-all ; +SYNTAX: `call-next-method T{ fake-call-next-method } parsed ; + : (INTERPOLATE) ( accum quot -- accum ) [ scan interpolate-locals ] dip '[ _ with-string-writer @ ] parsed ; @@ -114,9 +137,12 @@ DEFER: ;FUNCTOR delimiter { "M:" POSTPONE: `M: } { "C:" POSTPONE: `C: } { ":" POSTPONE: `: } + { "GENERIC:" POSTPONE: `GENERIC: } { "INSTANCE:" POSTPONE: `INSTANCE: } { "SYNTAX:" POSTPONE: `SYNTAX: } + { "SYMBOL:" POSTPONE: `SYMBOL: } { "inline" POSTPONE: `inline } + { "call-next-method" POSTPONE: `call-next-method } } ; : push-functor-words ( -- ) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 3671511194..d6a3aa948a 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -161,22 +161,6 @@ HELP: ndip } } ; -HELP: nslip -{ $values { "n" integer } } -{ $description "A generalization of " { $link slip } " that can work " -"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " -"removed from the stack, the quotation called, and the items restored." -} -{ $examples - { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" } - "Some core words expressed in terms of " { $link nslip } ":" - { $table - { { $link slip } { $snippet "1 nslip" } } - { { $link 2slip } { $snippet "2 nslip" } } - { { $link 3slip } { $snippet "3 nslip" } } - } -} ; - HELP: nkeep { $values { "quot" quotation } { "n" integer } } { $description "A generalization of " { $link keep } " that can work " @@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words" ARTICLE: "combinator-generalizations" "Generalized combinators" { $subsection ndip } -{ $subsection nslip } { $subsection nkeep } { $subsection napply } { $subsection ncleave } diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 7ede271d01..d0f614f9cd 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -26,8 +26,6 @@ IN: generalizations.tests [ [ 1 ] 5 ndip ] must-infer [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test -[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer -{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index edee44acc6..397166a418 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -26,11 +26,14 @@ MACRO: narray ( n -- ) MACRO: nsum ( n -- ) 1- [ + ] n*quot ; +MACRO: firstn-unsafe ( n -- ) + [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ; + MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ - [ [ '[ [ _ ] dip nth-unsafe ] ] map ] - [ 1- '[ [ _ ] dip bounds-check 2drop ] ] - bi prefix '[ _ cleave ] + [ 1- swap bounds-check 2drop ] + [ firstn-unsafe ] + bi-curry '[ _ _ bi ] ] if ; MACRO: npick ( n -- ) @@ -57,9 +60,6 @@ MACRO: ntuck ( n -- ) MACRO: ndip ( quot n -- ) [ '[ _ dip ] ] times ; -MACRO: nslip ( n -- ) - '[ [ call ] _ ndip ] ; - MACRO: nkeep ( quot n -- ) tuck '[ _ ndup _ _ ndip ] ; diff --git a/basis/help/apropos/apropos.factor b/basis/help/apropos/apropos.factor index b241db4c0e..63cbcb3f1e 100644 --- a/basis/help/apropos/apropos.factor +++ b/basis/help/apropos/apropos.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs fry help.markup help.topics io kernel make math math.parser namespaces sequences sorting -summary tools.completion tools.vocabs help.vocabs +summary tools.completion vocabs.hierarchy help.vocabs vocabs words unicode.case help ; IN: help.apropos diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 262c46bbc3..b83fb22ccf 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -281,7 +281,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $heading "Workflow" } { $subsection "listener" } { $subsection "editor" } -{ $subsection "tools.vocabs" } +{ $subsection "vocabs.refresh" } { $subsection "tools.test" } { $subsection "help" } { $heading "Debugging" } @@ -292,6 +292,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $heading "Browsing" } { $subsection "see" } { $subsection "tools.crossref" } +{ $subsection "vocabs.hierarchy" } { $heading "Performance" } { $subsection "timing" } { $subsection "profiling" } diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index f4a8742486..348fcbbbfb 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -3,7 +3,7 @@ USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs -tools.vocabs help.vocabs namespaces prettyprint io +vocabs.hierarchy help.vocabs namespaces prettyprint io vocabs.loader serialize fry memoize ascii unicode.case math.order sorting debugger html xml.syntax xml.writer math.parser ; IN: help.html diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 42f29bc8b7..7a5b482270 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs continuations fry help help.lint.checks help.topics io kernel namespaces parser sequences -source-files.errors tools.vocabs vocabs words classes +source-files.errors vocabs.hierarchy vocabs words classes locals tools.errors ; FROM: help.lint.checks => all-vocabs ; IN: help.lint @@ -87,7 +87,7 @@ PRIVATE> : help-lint-all ( -- ) "" help-lint ; -: :lint-failures ( -- ) lint-failures get errors. ; +: :lint-failures ( -- ) lint-failures get values errors. ; : unlinked-words ( words -- seq ) all-word-help [ article-parent not ] filter ; diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index 2ed18b7cd5..7686022b70 100644 --- a/basis/help/tutorial/tutorial.factor +++ b/basis/help/tutorial/tutorial.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax ui.commands ui.operations editors vocabs.loader kernel sequences prettyprint tools.test -tools.vocabs strings unicode.categories unicode.case +vocabs.refresh strings unicode.categories unicode.case ui.tools.browser ui.tools.common ; IN: help.tutorial diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index a8c93feee4..b23143e572 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -6,7 +6,8 @@ classes.singleton classes.tuple classes.union combinators definitions effects fry generic help help.markup help.stylesheet help.topics io io.files io.pathnames io.styles kernel macros make namespaces prettyprint sequences sets sorting summary -tools.vocabs vocabs vocabs.loader words words.symbol definitions.icons ; +vocabs vocabs.files vocabs.hierarchy vocabs.loader +vocabs.metadata words words.symbol definitions.icons ; IN: help.vocabs : about ( vocab -- ) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d445bf72ad..db04033275 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs byte-arrays byte-vectors io.binary io.streams.string splitting math -math.parser generic generic.standard generic.standard.engines classes +math.parser generic generic.single generic.standard classes hashtables namespaces ; IN: hints @@ -42,13 +42,13 @@ SYMBOL: specialize-method? t specialize-method? set-global +: method-declaration ( method -- quot ) + [ "method-generic" word-prop dispatch# object ] + [ "method-class" word-prop ] + bi prefix [ declare ] curry [ ] like ; + : specialize-method ( quot method -- quot' ) - [ - specialize-method? get [ - [ "method-class" word-prop ] [ "method-generic" word-prop ] bi - method-declaration prepend - ] [ drop ] if - ] + [ specialize-method? get [ method-declaration prepend ] [ drop ] if ] [ "method-generic" word-prop "specializer" word-prop ] bi [ specialize-quot ] when* ; @@ -71,7 +71,7 @@ t specialize-method? set-global SYNTAX: HINTS: scan-object [ changed-definition ] - [ parse-definition "specializer" set-word-prop ] bi ; + [ parse-definition { } like "specializer" set-word-prop ] bi ; ! Default specializers { first first2 first3 first4 } diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 0d7f7851e2..e00f8e2263 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -1,6 +1,7 @@ USING: http help.markup help.syntax io.pathnames io.streams.string io.encodings.8-bit io.encodings.binary kernel strings urls -urls.encoding byte-arrays strings assocs sequences destructors ; +urls.encoding byte-arrays strings assocs sequences destructors +http.client.post-data.private ; IN: http.client HELP: download-failed @@ -71,7 +72,7 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client" { $subsection with-http-get } { $subsection with-http-request } ; -ARTICLE: "http.client.post-data" "HTTP client submission data" +ARTICLE: "http.client.post-data" "HTTP client post data" "HTTP POST and PUT request words take a post data parameter, which can be one of the following:" { $list { "a " { $link byte-array } ": the data is sent the server without further encoding" } @@ -85,7 +86,9 @@ ARTICLE: "http.client.post-data" "HTTP client submission data" { $code "\"my-large-post-request.txt\" ascii " "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal" -} ; +} +"An internal word used to convert objects to " { $link post-data } " instances:" +{ $subsection >post-data } ; ARTICLE: "http.client.post" "POST requests with the HTTP client" "Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:" diff --git a/basis/http/client/post-data/post-data-docs.factor b/basis/http/client/post-data/post-data-docs.factor new file mode 100644 index 0000000000..24325e9ebd --- /dev/null +++ b/basis/http/client/post-data/post-data-docs.factor @@ -0,0 +1,6 @@ +IN: http.client.post-data +USING: http http.client.post-data.private help.markup help.syntax kernel ; + +HELP: >post-data +{ $values { "object" object } { "post-data" { $maybe post-data } } } +{ $description "Converts an object into a " { $link post-data } " tuple instance." } ; diff --git a/basis/http/server/server-docs.factor b/basis/http/server/server-docs.factor index 29f61416fa..daf0305972 100644 --- a/basis/http/server/server-docs.factor +++ b/basis/http/server/server-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io.streams.string quotations strings urls http tools.vocabs math io.servers.connection ; +USING: help.markup help.syntax io.streams.string quotations strings urls http vocabs.refresh math io.servers.connection ; IN: http.server HELP: trivial-responder diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 8b22b9a885..3beb730499 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations -combinators tools.vocabs tools.time math math.parser present +combinators vocabs.refresh tools.time math math.parser present io vectors io.sockets io.sockets.secure diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 6bf1ea2ff1..27dc25de73 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.encodings.utf8 io.files kernel math math.bitwise math.order math.parser pack prettyprint sequences -strings math.vectors specialized-arrays.float ; +strings math.vectors specialized-arrays.float locals ; IN: images.tiff TUPLE: tiff-image < image ; @@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation software date-time photoshop exif-ifd sub-ifd inter-color-profile xmp iptc fill-order document-name page-number page-name x-position y-position host-computer copyright artist -min-sample-value max-sample-value make model cell-width cell-length +min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length gray-response-unit gray-response-curve color-map threshholding image-description free-offsets free-byte-counts tile-width tile-length matteing data-type image-depth tile-depth @@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ; ERROR: no-tag class ; -: find-tag ( idf class -- tag ) - swap processed-tags>> ?at [ no-tag ] unless ; +: find-tag* ( ifd class -- tag/class ? ) + swap processed-tags>> ?at ; -: tag? ( idf class -- tag ) +: find-tag ( ifd class -- tag ) + find-tag* [ no-tag ] unless ; + +: tag? ( ifd class -- tag ) swap processed-tags>> key? ; : read-strips ( ifd -- ifd ) @@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ; { 266 [ fill-order ] } { 269 [ ascii decode document-name ] } { 270 [ ascii decode image-description ] } - { 271 [ ascii decode make ] } - { 272 [ ascii decode model ] } + { 271 [ ascii decode tiff-make ] } + { 272 [ ascii decode tiff-model ] } { 273 [ strip-offsets ] } { 274 [ orientation ] } { 277 [ samples-per-pixel ] } @@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ; { 281 [ max-sample-value ] } { 282 [ first x-resolution ] } { 283 [ first y-resolution ] } - { 284 [ planar-configuration ] } + { 284 [ lookup-planar-configuration planar-configuration ] } { 285 [ page-name ] } { 286 [ x-position ] } { 287 [ y-position ] } @@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ; [ samples-per-pixel find-tag ] tri [ * ] keep '[ - _ group [ _ group [ rest ] [ first ] bi - [ v+ ] accumulate swap suffix concat ] map + _ group + [ _ group unclip [ v+ ] accumulate swap suffix concat ] map concat >byte-array ] change-bitmap ; @@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ; ] with-tiff-endianness ] with-file-reader ; -: process-tif-ifds ( parsed-tiff -- parsed-tiff ) - dup ifds>> [ - read-strips - uncompress-strips - strips>bitmap - fix-bitmap-endianness - strips-predictor - dup extra-samples tag? [ handle-alpha-data ] when - drop - ] each ; +: process-chunky-ifd ( ifd -- ) + read-strips + uncompress-strips + strips>bitmap + fix-bitmap-endianness + strips-predictor + dup extra-samples tag? [ handle-alpha-data ] when + drop ; + +: process-planar-ifd ( ifd -- ) + "planar ifd not supported" throw ; + +: dispatch-planar-configuration ( ifd planar-configuration -- ) + { + { planar-configuration-chunky [ process-chunky-ifd ] } + { planar-configuration-planar [ process-planar-ifd ] } + } case ; + +: process-ifd ( ifd -- ) + dup planar-configuration find-tag* [ + dispatch-planar-configuration + ] [ + drop "no planar configuration" throw + ] if ; + +: process-tif-ifds ( parsed-tiff -- ) + ifds>> [ process-ifd ] each ; : load-tiff ( path -- parsed-tiff ) - [ load-tiff-ifds ] [ - binary [ - [ process-tif-ifds ] with-tiff-endianness - ] with-file-reader - ] bi ; + [ load-tiff-ifds dup ] keep + binary [ + [ process-tif-ifds ] with-tiff-endianness + ] with-file-reader ; ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) diff --git a/basis/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor index 75e1198658..51ab6f27d9 100644 --- a/basis/inverse/inverse-tests.factor +++ b/basis/inverse/inverse-tests.factor @@ -1,5 +1,7 @@ +! Copyright (C) 2007, 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. USING: inverse tools.test arrays math kernel sequences -math.functions math.constants continuations ; +math.functions math.constants continuations combinators.smart ; IN: inverse-tests [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test @@ -69,7 +71,7 @@ C: nil [ t ] [ pi [ pi ] matches? ] unit-test [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test -[ ] [ 3 [ _ ] undo ] unit-test +[ ] [ 3 [ __ ] undo ] unit-test [ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test [ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test @@ -88,4 +90,7 @@ TUPLE: funny-tuple ; : ( -- funny-tuple ) \ funny-tuple boa ; : funny-tuple ( -- ) "OOPS" throw ; -[ ] [ [ ] [undo] drop ] unit-test \ No newline at end of file +[ ] [ [ ] [undo] drop ] unit-test + +[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test +[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input __ +sequences.private combinators mirrors splitting combinators.smart +combinators.short-circuit fry words.symbol generalizations +classes ; IN: inverse ERROR: fail ; @@ -14,7 +14,7 @@ M: fail summary drop "Matching failed" ; : assure ( ? -- ) [ fail ] unless ; inline -: =/fail ( obj1 obj2 -- ) = assure ; +: =/fail ( obj1 obj2 -- ) = assure ; inline ! Inverse of a quotation @@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ; \ pick [ [ pick ] dip =/fail ] define-inverse \ tuck [ swapd [ =/fail ] keep ] define-inverse +\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse +\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse +\ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse +\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse + \ not define-involution -\ >boolean [ { t f } memq? assure ] define-inverse +\ >boolean [ dup { t f } memq? assure ] define-inverse \ tuple>array \ >tuple define-dual \ reverse define-involution -\ undo 1 [ [ call ] curry ] define-pop-inverse -\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse +\ undo 1 [ ] define-pop-inverse +\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse \ exp \ log define-dual \ sq \ sqrt define-dual @@ -173,16 +178,13 @@ ERROR: missing-literal ; 2curry ] define-pop-inverse -DEFER: _ -\ _ [ drop ] define-inverse +DEFER: __ +\ __ [ drop ] define-inverse : both ( object object -- object ) dupd assert= ; \ both [ dup ] define-inverse -: assure-length ( seq length -- seq ) - over length =/fail ; - { { >array array? } { >vector vector? } @@ -194,14 +196,23 @@ DEFER: _ { >string string? } { >sbuf sbuf? } { >quotation quotation? } -} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each +} [ '[ dup _ execute assure ] define-inverse ] assoc-each -! These actually work on all seqs--should they? -\ 1array [ 1 assure-length first ] define-inverse -\ 2array [ 2 assure-length first2 ] define-inverse -\ 3array [ 3 assure-length first3 ] define-inverse -\ 4array [ 4 assure-length first4 ] define-inverse -\ narray 1 [ [ firstn ] curry ] define-pop-inverse +: assure-length ( seq length -- ) + swap length =/fail ; inline + +: assure-array ( array -- array ) + dup array? assure ; inline + +: undo-narray ( array n -- ... ) + [ assure-array ] dip + [ assure-length ] [ firstn ] 2bi ; inline + +\ 1array [ 1 undo-narray ] define-inverse +\ 2array [ 2 undo-narray ] define-inverse +\ 3array [ 3 undo-narray ] define-inverse +\ 4array [ 4 undo-narray ] define-inverse +\ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse \ first [ 1array ] define-inverse \ first2 [ 2array ] define-inverse @@ -214,6 +225,12 @@ DEFER: _ \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse +: assure-same-class ( obj1 obj2 -- ) + [ class ] bi@ = assure ; inline + +\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ inputsequence ] ] define-pop-inverse + ! Constructor inverse : deconstruct-pred ( class -- quot ) "predicate" word-prop [ dupd call assure ] curry ; @@ -245,7 +262,7 @@ DEFER: _ ] recover ; inline : true-out ( quot effect -- quot' ) - out>> '[ @ __ ndrop t ] ; + out>> '[ @ _ ndrop t ] ; : false-recover ( effect -- quot ) in>> [ ndrop f ] curry [ recover-fail ] curry ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 6f283ac1bb..4dfe02d651 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -46,7 +46,7 @@ M: winnt add-completion ( win32-handle -- ) { [ dup integer? ] [ ] } { [ dup array? ] [ first dup eof? - [ drop 0 ] [ (win32-error-string) throw ] if + [ drop 0 ] [ n>win32-error-string throw ] if ] } } cond ] with-timeout ; @@ -105,7 +105,7 @@ M: winnt seek-handle ( n seek-type handle -- ) GetLastError { { [ dup expected-io-error? ] [ drop f ] } { [ dup eof? ] [ drop t ] } - [ (win32-error-string) throw ] + [ n>win32-error-string throw ] } cond ] [ f ] if ; diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/io/backend/windows/nt/privileges/privileges.factor index 64218f75b0..33577a9394 100755 --- a/basis/io/backend/windows/nt/privileges/privileges.factor +++ b/basis/io/backend/windows/nt/privileges/privileges.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types alien.syntax arrays continuations destructors generic io.mmap io.ports io.backend.windows io.files.windows kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system accessors -io.backend.windows.privileges ; +io.backend.windows.privileges windows.errors ; IN: io.backend.windows.nt.privileges TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES diff --git a/basis/io/backend/windows/privileges/privileges-tests.factor b/basis/io/backend/windows/privileges/privileges-tests.factor new file mode 100755 index 0000000000..7237651b80 --- /dev/null +++ b/basis/io/backend/windows/privileges/privileges-tests.factor @@ -0,0 +1,4 @@ +IN: io.backend.windows.privileges.tests +USING: io.backend.windows.privileges tools.test ; + +[ [ ] with-privileges ] must-infer diff --git a/basis/io/backend/windows/privileges/privileges.factor b/basis/io/backend/windows/privileges/privileges.factor old mode 100644 new mode 100755 index 8661ba99d9..58806cc4df --- a/basis/io/backend/windows/privileges/privileges.factor +++ b/basis/io/backend/windows/privileges/privileges.factor @@ -1,12 +1,13 @@ USING: io.backend kernel continuations sequences -system vocabs.loader combinators ; +system vocabs.loader combinators fry ; IN: io.backend.windows.privileges -HOOK: set-privilege io-backend ( name ? -- ) inline +HOOK: set-privilege io-backend ( name ? -- ) : with-privileges ( seq quot -- ) - over [ [ t set-privilege ] each ] curry compose - swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline + [ '[ _ [ t set-privilege ] each @ ] ] + [ drop '[ _ [ f set-privilege ] each ] ] + 2bi [ ] cleanup ; inline { { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] } diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 6ecbc49f2a..9f5c00cc5f 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend -io.buffers io.files io.ports io.binary io.timeouts -windows.errors strings kernel math namespaces sequences windows -windows.kernel32 windows.shell32 windows.types windows.winsock -splitting continuations math.bitwise system accessors ; +io.buffers io.files io.ports io.binary io.timeouts system +windows.errors strings kernel math namespaces sequences +windows.errors windows.kernel32 windows.shell32 windows.types +windows.winsock splitting continuations math.bitwise accessors ; IN: io.backend.windows : set-inherit ( handle ? -- ) @@ -51,4 +51,4 @@ HOOK: add-completion io-backend ( port -- ) : default-security-attributes ( -- obj ) "SECURITY_ATTRIBUTES" "SECURITY_ATTRIBUTES" heap-size - over set-SECURITY_ATTRIBUTES-nLength ; \ No newline at end of file + over set-SECURITY_ATTRIBUTES-nLength ; diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor index 899bedfbc6..594e245a9c 100644 --- a/basis/io/encodings/iana/iana.factor +++ b/basis/io/encodings/iana/iana.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel strings values io.files assocs splitting sequences io namespaces sets -io.encodings.ascii io.encodings.utf8 ; +io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ; IN: io.encodings.iana n-table [ initial-e>n ] initialize ] [ swap e>n-table get-global set-at ] 2bi ; ascii "ANSI_X3.4-1968" register-encoding +utf16be "UTF-16BE" register-encoding +utf16le "UTF-16LE" register-encoding +utf16 "UTF-16" register-encoding \ No newline at end of file diff --git a/basis/io/encodings/string/string.factor b/basis/io/encodings/string/string.factor index 5e57a943a9..3659939fb0 100644 --- a/basis/io/encodings/string/string.factor +++ b/basis/io/encodings/string/string.factor @@ -4,7 +4,7 @@ USING: io io.streams.byte-array ; IN: io.encodings.string : decode ( byte-array encoding -- string ) - contents ; + stream-contents ; : encode ( string encoding -- byte-array ) [ write ] with-byte-writer ; diff --git a/basis/io/files/links/links-docs.factor b/basis/io/files/links/links-docs.factor index 8419399c92..bf1bedaa08 100644 --- a/basis/io/files/links/links-docs.factor +++ b/basis/io/files/links/links-docs.factor @@ -5,6 +5,10 @@ HELP: make-link { $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } } { $description "Creates a symbolic link." } ; +HELP: make-hard-link +{ $values { "target" "a path to the hard link's target" } { "link" "a path to new symbolic link" } } +{ $description "Creates a hard link." } ; + HELP: read-link { $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } } { $description "Reads the symbolic link and returns its target path." } ; diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor index 1212d579db..7aec916c72 100644 --- a/basis/io/files/links/links.factor +++ b/basis/io/files/links/links.factor @@ -6,6 +6,8 @@ IN: io.files.links HOOK: make-link os ( target symlink -- ) +HOOK: make-hard-link os ( target link -- ) + HOOK: read-link os ( symlink -- path ) : copy-link ( target symlink -- ) diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index 7d2a6ee4f3..c9a651b484 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -7,6 +7,9 @@ IN: io.files.links.unix M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; +M: unix make-hard-link ( path1 path2 -- ) + normalize-path link io-error ; + M: unix read-link ( path -- path' ) normalize-path read-symbolic-link ; diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 0e4338e3e0..a7ae317668 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -35,6 +35,9 @@ SYMBOL: unique-retries : random-name ( -- string ) unique-length get [ random-ch ] "" replicate-as ; +: retry ( quot: ( -- ? ) n -- ) + swap [ drop ] prepose attempt-all ; inline + : (make-unique-file) ( path prefix suffix -- path ) '[ _ _ _ random-name glue append-path diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index afc81c784c..32424a37a3 100755 --- a/basis/io/files/windows/nt/nt.factor +++ b/basis/io/files/windows/nt/nt.factor @@ -4,7 +4,8 @@ io.backend.windows io.files.windows io.encodings.utf16n windows windows.kernel32 kernel libc math threads system environment alien.c-types alien.arrays alien.strings sequences combinators combinators.short-circuit ascii splitting alien strings assocs -namespaces make accessors tr windows.time windows.shell32 ; +namespaces make accessors tr windows.time windows.shell32 +windows.errors ; IN: io.files.windows.nt M: winnt cwd diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index f5809223fc..838c09c657 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -3,9 +3,9 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors environment -io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.ports debugger prettyprint summary -calendar ; +io io.encodings.ascii io.backend io.timeouts io.pipes +io.pipes.private io.encodings io.streams.duplex io.ports +debugger prettyprint summary calendar ; IN: io.launcher TUPLE: process < identity-tuple @@ -265,3 +265,5 @@ M: object run-pipeline-element { [ os winnt? ] [ "io.launcher.windows.nt" require ] } [ ] } cond + +: run-desc ( desc -- result ) ascii f swap stream-read-until drop ; diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index f375bb41e8..852d8171e4 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -33,7 +33,7 @@ concurrency.promises threads unix.process ; "cat" "launcher-test-1" temp-file 2array - ascii contents + ascii stream-contents ] unit-test [ ] [ @@ -48,11 +48,11 @@ concurrency.promises threads unix.process ; try-process ] unit-test -[ f ] [ +[ "" ] [ "cat" "launcher-test-1" temp-file 2array - ascii contents + ascii stream-contents ] unit-test [ ] [ @@ -70,14 +70,14 @@ concurrency.promises threads unix.process ; "cat" "launcher-test-1" temp-file 2array - ascii contents + ascii stream-contents ] unit-test [ t ] [ "env" >>command { { "A" "B" } } >>environment - ascii lines + ascii stream-lines "A=B" swap member? ] unit-test @@ -86,7 +86,7 @@ concurrency.promises threads unix.process ; "env" >>command { { "A" "B" } } >>environment +replace-environment+ >>environment-mode - ascii lines + ascii stream-lines ] unit-test [ "hi\n" ] [ @@ -113,13 +113,13 @@ concurrency.promises threads unix.process ; "append-test" temp-file utf8 file-contents ] unit-test -[ t ] [ "ls" utf8 contents >boolean ] unit-test +[ t ] [ "ls" utf8 stream-contents >boolean ] unit-test [ "Hello world.\n" ] [ "cat" utf8 [ "Hello world.\n" write output-stream get dispose - input-stream get contents + input-stream get stream-contents ] with-stream ] unit-test diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 53b3d3ce7e..4587556e0c 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests console-vm "-run=listener" 2array >>command +closed+ >>stdin +stdout+ >>stderr - ascii [ input-stream get contents ] with-process-reader + ascii [ contents ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "stderr.factor" 3array >>command "err2.txt" temp-file >>stderr - ascii lines first + ascii stream-lines first ] with-directory ] unit-test @@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests launcher-test-path [ console-vm "-script" "env.factor" 3array >>command - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command +replace-environment+ >>environment-mode os-envs >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "A" swap at @@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index ebd8109d14..8fdc7fefd9 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.mmap io.ports io.backend.windows io.files.windows io.backend.windows.privileges kernel libc math math.bitwise namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system -accessors locals ; +accessors locals windows.errors ; IN: io.mmap.windows : create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE ) @@ -12,8 +12,8 @@ IN: io.mmap.windows MapViewOfFile [ win32-error=0/f ] keep ; :: mmap-open ( path length access-mode create-mode protect access -- handle handle address ) - [let | lo [ length HEX: ffffffff bitand ] - hi [ length -32 shift HEX: ffffffff bitand ] | + [let | lo [ length 32 bits ] + hi [ length -32 shift 32 bits ] | { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ path access-mode create-mode 0 open-file |dispose dup handle>> f protect hi lo f create-file-mapping |dispose diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor index d2408a3dd1..bec249c04c 100755 --- a/basis/io/monitors/windows/nt/nt.factor +++ b/basis/io/monitors/windows/nt/nt.factor @@ -6,7 +6,7 @@ hashtables sorting arrays combinators math.bitwise strings system accessors threads splitting io.backend io.backend.windows io.backend.windows.nt io.files.windows.nt io.monitors io.ports io.buffers io.files io.timeouts io.encodings.string -io.encodings.utf16n io windows windows.kernel32 windows.types +io.encodings.utf16n io windows.errors windows.kernel32 windows.types io.pathnames ; IN: io.monitors.windows.nt diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index ae79290f0a..ab99531eb4 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ; dup start-server* sockets>> first addr>> port>> "port" set ] unit-test -[ "Hello world." ] [ "localhost" "port" get ascii drop contents ] unit-test +[ "Hello world." ] [ "localhost" "port" get ascii drop stream-contents ] unit-test diff --git a/basis/io/sockets/secure/unix/unix-tests.factor b/basis/io/sockets/secure/unix/unix-tests.factor index 7c4dcc17d1..f87ad93fbd 100644 --- a/basis/io/sockets/secure/unix/unix-tests.factor +++ b/basis/io/sockets/secure/unix/unix-tests.factor @@ -23,7 +23,7 @@ io.sockets.secure.unix.debug ; : client-test ( -- string ) [ - "127.0.0.1" "port" get ?promise ascii drop contents + "127.0.0.1" "port" get ?promise ascii drop stream-contents ] with-secure-context ; [ ] [ [ class name>> write ] server-test ] unit-test diff --git a/basis/io/streams/string/string-tests.factor b/basis/io/streams/string/string-tests.factor index 967c0d4613..27971f1431 100644 --- a/basis/io/streams/string/string-tests.factor +++ b/basis/io/streams/string/string-tests.factor @@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make tools.test ; IN: io.streams.string.tests +[ "" ] [ "" [ contents ] with-string-reader ] unit-test + [ "line 1" CHAR: l ] [ "line 1\nline 2\nline 3" diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor old mode 100644 new mode 100755 index 6148394c57..8fcf12aae9 --- a/basis/io/styles/styles-docs.factor +++ b/basis/io/styles/styles-docs.factor @@ -1,17 +1,17 @@ USING: help.markup help.syntax io.streams.plain io strings -hashtables kernel quotations colors ; +hashtables kernel quotations colors assocs ; IN: io.styles HELP: stream-format -{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } } +{ $values { "str" string } { "style" assoc } { "stream" "an output stream" } } { $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." $nl -"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." } +"The " { $snippet "style" } " assoc holds character style information. See " { $link "character-styles" } "." } { $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." } $io-error ; HELP: make-block-stream -{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } +{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } } { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." $nl "Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output." @@ -21,7 +21,7 @@ $nl $io-error ; HELP: stream-write-table -{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } } +{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" assoc } { "stream" "an output stream" } } { $contract "Prints a table of cells produced by " { $link with-cell } "." $nl "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } @@ -29,13 +29,13 @@ $nl $io-error ; HELP: make-cell-stream -{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } } +{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" object } } { $contract "Creates an output stream which writes to a table cell object." } { $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." } $io-error ; HELP: make-span-stream -{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } +{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } } { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." $nl "Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." } @@ -43,19 +43,19 @@ $nl $io-error ; HELP: format -{ $values { "str" string } { "style" "a hashtable" } } +{ $values { "str" string } { "style" assoc } } { $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $notes "Details are in the documentation for " { $link stream-format } "." } $io-error ; HELP: with-nesting -{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $values { "style" assoc } { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." } { $notes "Details are in the documentation for " { $link make-block-stream } "." } $io-error ; HELP: tabular-output -{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $values { "style" assoc } { "quot" quotation } } { $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "." $nl "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } @@ -85,7 +85,7 @@ HELP: write-cell $io-error ; HELP: with-style -{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $values { "style" assoc } { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." } { $notes "Details are in the documentation for " { $link make-span-stream } "." } $io-error ; diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index c3bf5d2f28..2d25016919 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -99,7 +99,11 @@ M: plain-writer make-block-stream nip ; M: plain-writer stream-write-table - [ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ; + [ + drop + [ [ >string ] map ] map format-table + [ nl ] [ write ] interleave + ] with-output-stream* ; M: plain-writer make-cell-stream 2drop ; diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor index 0014ba1eb1..887a7a50e5 100644 --- a/basis/json/reader/reader.factor +++ b/basis/json/reader/reader.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Peter Burns. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel peg peg.ebnf math.parser math.private strings math +USING: kernel peg peg.ebnf math.parser math.parser.private strings math math.functions sequences arrays vectors hashtables assocs prettyprint json ; IN: json.reader diff --git a/extra/literals/authors.txt b/basis/literals/authors.txt similarity index 100% rename from extra/literals/authors.txt rename to basis/literals/authors.txt diff --git a/extra/literals/literals-docs.factor b/basis/literals/literals-docs.factor similarity index 71% rename from extra/literals/literals-docs.factor rename to basis/literals/literals-docs.factor index 0d61dcb467..9dd398d962 100644 --- a/extra/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -21,7 +21,7 @@ CONSTANT: five 5 USING: kernel literals prettyprint ; IN: scratchpad -<< : seven-eleven ( -- a b ) 7 11 ; >> +: seven-eleven ( -- a b ) 7 11 ; { $ seven-eleven } . "> "{ 7 11 }" } @@ -43,7 +43,24 @@ IN: scratchpad } ; -{ POSTPONE: $ POSTPONE: $[ } related-words +HELP: ${ +{ $syntax "${ code }" } +{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." } +{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } +{ $examples + + { $example <" +USING: kernel literals math prettyprint ; +IN: scratchpad + +CONSTANT: five 5 +CONSTANT: six 6 +${ five six 7 } . + "> "{ 5 6 7 }" + } +} ; + +{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." @@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values" USING: kernel literals math prettyprint ; IN: scratchpad -<< CONSTANT: five 5 >> +CONSTANT: five 5 { $ five $[ five dup 1+ dup 2 + ] } . "> "{ 5 5 6 8 }" } { $subsection POSTPONE: $ } { $subsection POSTPONE: $[ } +{ $subsection POSTPONE: ${ } ; ABOUT: "literals" diff --git a/extra/literals/literals-tests.factor b/basis/literals/literals-tests.factor old mode 100644 new mode 100755 similarity index 77% rename from extra/literals/literals-tests.factor rename to basis/literals/literals-tests.factor index 024c94e4f2..d7256a64b1 --- a/extra/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -19,3 +19,11 @@ IN: literals.tests [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test + +CONSTANT: constant-a 3 + +[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test + +: sixty-nine ( -- a b ) 6 9 ; + +[ { 6 9 } ] [ ${ sixty-nine } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor new file mode 100755 index 0000000000..ba1da393b1 --- /dev/null +++ b/basis/literals/literals.factor @@ -0,0 +1,21 @@ +! (c) Joe Groff, see license for details +USING: accessors continuations kernel parser words quotations +combinators.smart vectors sequences fry ; +IN: literals + +> call so that CONSTANT:s defined in the same file can +! be called + +: expand-literal ( seq obj -- seq' ) + '[ _ dup word? [ def>> call ] when ] with-datastack ; + +: expand-literals ( seq -- seq' ) + [ [ { } ] dip expand-literal ] map concat ; + +PRIVATE> + +SYNTAX: $ scan-word expand-literal >vector ; +SYNTAX: $[ parse-quotation with-datastack >vector ; +SYNTAX: ${ \ } [ expand-literals ] parse-literal ; diff --git a/extra/literals/summary.txt b/basis/literals/summary.txt similarity index 100% rename from extra/literals/summary.txt rename to basis/literals/summary.txt diff --git a/extra/literals/tags.txt b/basis/literals/tags.txt similarity index 100% rename from extra/literals/tags.txt rename to basis/literals/tags.txt diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 68fa8dbda0..1549a77663 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -585,4 +585,4 @@ M: integer ed's-bug neg ; :: ed's-test-case ( a -- b ) { [ a ed's-bug ] } && ; -[ t ] [ \ ed's-test-case optimized>> ] unit-test +[ t ] [ \ ed's-test-case optimized? ] unit-test diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor old mode 100644 new mode 100755 index acd2c3383f..6a4672bea0 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -49,6 +49,7 @@ $nl { $subsection POSTPONE: MACRO: } "A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion." { $subsection define-transform } -"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ; +"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." +{ $see-also "generalizations" "fry" } ; ABOUT: "macros" diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 8920955df3..72b83a991f 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ; C: bits : make-bits ( number -- bits ) - dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ ] if ; inline + dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + ] if ; inline M: bits length length>> ; diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 3148567bc0..ff4806348b 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -13,10 +13,10 @@ IN: math.bitwise : unmask? ( x n -- ? ) unmask 0 > ; inline : mask ( x n -- ? ) bitand ; inline : mask? ( x n -- ? ) mask 0 > ; inline -: wrap ( m n -- m' ) 1- bitand ; inline +: wrap ( m n -- m' ) 1 - bitand ; inline : bits ( m n -- m' ) 2^ wrap ; inline : mask-bit ( m n -- m' ) 2^ mask ; inline -: on-bits ( n -- m ) 2^ 1- ; inline +: on-bits ( n -- m ) 2^ 1 - ; inline : toggle-bit ( m n -- m' ) 2^ bitxor ; inline : shift-mod ( n s w -- n ) @@ -35,6 +35,11 @@ IN: math.bitwise : w- ( int int -- int ) - 32 bits ; inline : w* ( int int -- int ) * 32 bits ; inline +! 64-bit arithmetic +: W+ ( int int -- int ) + 64 bits ; inline +: W- ( int int -- int ) - 64 bits ; inline +: W* ( int int -- int ) * 64 bits ; inline + ! flags MACRO: flags ( values -- ) [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ; @@ -64,8 +69,8 @@ DEFER: byte-bit-count << \ byte-bit-count -256 [ - 8 0 [ [ 1+ ] when ] reduce +256 iota [ + 8 0 [ [ 1 + ] when ] reduce ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] (( byte -- table )) define-declared @@ -97,12 +102,19 @@ PRIVATE> ! Signed byte array to integer conversion : signed-le> ( bytes -- x ) - [ le> ] [ length 8 * 1- on-bits ] bi + [ le> ] [ length 8 * 1 - on-bits ] bi 2dup > [ bitnot bitor ] [ drop ] if ; : signed-be> ( bytes -- x ) signed-le> ; : >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; + 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; +: >odd ( n -- int ) 0 set-bit ; foldable + +: >even ( n -- int ) 0 clear-bit ; foldable + +: next-even ( m -- n ) >even 2 + ; foldable + +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index d7c6ebc927..3017a12b18 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -164,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX 1- ; + (prepare-nrm2) IXAMAX 1 - ; M: VECTOR (blas-vector-like) drop ; diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 514c808ee0..041539c981 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -1,37 +1,93 @@ -USING: help.markup help.syntax kernel math math.order sequences ; +USING: help.markup help.syntax kernel math math.order multiline sequences ; IN: math.combinatorics HELP: factorial { $values { "n" "a non-negative integer" } { "n!" integer } } { $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "4 factorial ." "24" } +} ; HELP: nPk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } { $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nPk ." "5040" } +} ; HELP: nCk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } { $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nCk ." "210" } +} ; HELP: permutation { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "1 3 permutation ." "{ 0 2 1 }" } + { $example "USING: math.combinatorics prettyprint ;" + "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } +} ; HELP: all-permutations { $values { "seq" sequence } { "seq" sequence } } { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } +} ; + +HELP: each-permutation +{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ; HELP: inverse-permutation { $values { "seq" sequence } { "permutation" sequence } } { $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } { $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } + { $example "USING: math.combinatorics prettyprint ;" + "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } +} ; + +HELP: combination +{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." } +{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." } +{ $examples + { $example "USING: math.combinatorics sequences prettyprint ;" + "6 7 iota 4 combination ." "{ 0 1 3 6 }" } + { $example "USING: math.combinatorics prettyprint ;" + "0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" } +} ; + +HELP: all-combinations +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." } +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ." +<" { + { "a" "b" } + { "a" "c" } + { "a" "d" } + { "b" "c" } + { "b" "d" } + { "c" "d" } +}"> } } ; + +HELP: each-combination +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ; IN: math.combinatorics.private diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 5ef435a4e0..ca6ec9cb53 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -1,18 +1,6 @@ -USING: math.combinatorics math.combinatorics.private tools.test ; +USING: math.combinatorics math.combinatorics.private tools.test sequences ; IN: math.combinatorics.tests -[ { } ] [ 0 factoradic ] unit-test -[ { 1 0 } ] [ 1 factoradic ] unit-test -[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test - -[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test -[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test - -[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test -[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test - [ 1 ] [ 0 factorial ] unit-test [ 1 ] [ 1 factorial ] unit-test [ 3628800 ] [ 10 factorial ] unit-test @@ -31,6 +19,19 @@ IN: math.combinatorics.tests [ 2598960 ] [ 52 5 nCk ] unit-test [ 2598960 ] [ 52 47 nCk ] unit-test + +[ { } ] [ 0 factoradic ] unit-test +[ { 1 0 } ] [ 1 factoradic ] unit-test +[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test + +[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test +[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test + +[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test +[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test + [ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test @@ -43,3 +44,29 @@ IN: math.combinatorics.tests [ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test [ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test + +[ 2598960 ] [ 52 iota 5 choose ] unit-test + +[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test +[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test +[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test +[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test + +[ 9 ] [ 0 5 iota 3 dual-index ] unit-test +[ 0 ] [ 9 5 iota 3 dual-index ] unit-test +[ 179 ] [ 72 10 iota 5 dual-index ] unit-test + +[ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test +[ { 4 3 2 1 0 } ] [ 10 iota 5 0 combinadic ] unit-test +[ { 8 6 3 1 0 } ] [ 10 iota 5 72 combinadic ] unit-test +[ { 9 8 7 6 5 } ] [ 10 iota 5 251 combinadic ] unit-test + +[ { 0 1 2 } ] [ 0 5 iota 3 combination-indices ] unit-test +[ { 2 3 4 } ] [ 9 5 iota 3 combination-indices ] unit-test + +[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test +[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test + +[ { { "a" "b" } { "a" "c" } + { "a" "d" } { "b" "c" } + { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index afdf4e378e..bc09f9fe0f 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,7 +1,7 @@ -! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. +! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math math.order math.ranges mirrors -namespaces sequences sorting fry ; +USING: accessors assocs binary-search fry kernel locals math math.order + math.ranges mirrors namespaces sequences sorting ; IN: math.combinatorics [ dupd - ] when ; inline -! See this article for explanation of the factoradic-based permutation methodology: -! http://msdn2.microsoft.com/en-us/library/aa302371.aspx +PRIVATE> + +: factorial ( n -- n! ) + 1 [ 1 + * ] reduce ; + +: nPk ( n k -- nPk ) + 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; + +: nCk ( n k -- nCk ) + twiddle [ nPk ] keep factorial / ; + + +! Factoradic-based permutation methodology + + ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ; + 0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ; : (>permutation) ( seq n -- seq ) - [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ; + [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ; : >permutation ( factoradic -- permutation ) reverse 1 cut [ (>permutation) ] each ; @@ -29,27 +42,84 @@ IN: math.combinatorics PRIVATE> -: factorial ( n -- n! ) - 1 [ 1+ * ] reduce ; - -: nPk ( n k -- nPk ) - 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; - -: nCk ( n k -- nCk ) - twiddle [ nPk ] keep factorial / ; - : permutation ( n seq -- seq ) [ permutation-indices ] keep nths ; : all-permutations ( seq -- seq ) - [ length factorial ] keep '[ _ permutation ] map ; + [ length factorial ] keep + '[ _ permutation ] map ; : each-permutation ( seq quot -- ) [ [ length factorial ] keep ] dip '[ _ permutation @ ] each ; inline -: reduce-permutations ( seq initial quot -- result ) +: reduce-permutations ( seq identity quot -- result ) swapd each-permutation ; inline : inverse-permutation ( seq -- permutation ) >alist sort-values keys ; + + +! Combinadic-based combination methodology + + combo + +: choose ( combo -- nCk ) + [ seq>> length ] [ k>> ] bi nCk ; + +: largest-value ( a b x -- v ) + dup 0 = [ + drop 1 - nip + ] [ + [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip + ] if ; + +:: next-values ( a b x -- a' b' x' v ) + a b x largest-value dup :> v ! a' + b 1 - ! b' + x v b nCk - ! x' + v ; ! v == a' + +: dual-index ( m combo -- m' ) + choose 1 - swap - ; + +: initial-values ( combo m -- n k m ) + [ [ seq>> length ] [ k>> ] bi ] dip ; + +: combinadic ( combo m -- combinadic ) + initial-values [ over 0 > ] [ next-values ] produce + [ 3drop ] dip ; + +: combination-indices ( m combo -- seq ) + [ tuck dual-index combinadic ] keep + seq>> length 1 - swap [ - ] with map ; + +: apply-combination ( m combo -- seq ) + [ combination-indices ] keep seq>> nths ; + +PRIVATE> + +: combination ( m seq k -- seq ) + apply-combination ; + +: all-combinations ( seq k -- seq ) + [ choose [0,b) ] keep + '[ _ apply-combination ] map ; + +: each-combination ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] each ; inline + +: map-combinations ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] map ; inline + +: reduce-combinations ( seq k identity quot -- result ) + [ -rot ] dip each-combination ; inline + diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor index 6b6f5c95bd..a51b86ff0b 100644 --- a/basis/math/complex/complex-docs.factor +++ b/basis/math/complex/complex-docs.factor @@ -25,7 +25,3 @@ HELP: complex { $class-description "The class of complex numbers with non-zero imaginary part." } ; ABOUT: "complex-numbers" - -HELP: ( x y -- z ) -{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } } -{ $description "Low-level complex number constructor. User code should call " { $link rect> } " instead." } ; diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index c41faaf558..832a9e64ba 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -15,14 +15,14 @@ M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; : complex= ( x y quot -- ? ) componentwise and ; inline M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; M: complex number= [ number= ] complex= ; -: complex-op ( x y quot -- z ) componentwise (rect>) ; inline +: complex-op ( x y quot -- z ) componentwise rect> ; inline M: complex + [ + ] complex-op ; M: complex - [ - ] complex-op ; : *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline : *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline -M: complex * [ *re - ] [ *im + ] 2bi (rect>) ; +M: complex * [ *re - ] [ *im + ] 2bi rect> ; : (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline -: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ (rect>) ; inline +: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline M: complex / [ / ] complex/ ; M: complex /f [ /f ] complex/ ; M: complex /i [ /i ] complex/ ; diff --git a/basis/math/constants/constants.factor b/basis/math/constants/constants.factor index 118a8e8197..a2d3213e78 100644 --- a/basis/math/constants/constants.factor +++ b/basis/math/constants/constants.factor @@ -7,6 +7,7 @@ IN: math.constants : euler ( -- gamma ) 0.57721566490153286060 ; inline : phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline +: 2pi ( -- pi ) 2 pi * ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline : smallest-float ( -- x ) HEX: 1 bits>double ; foldable : largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index f7d0d5a941..48da8aa6ec 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -100,11 +100,6 @@ ARTICLE: "math-functions" "Mathematical functions" ABOUT: "math-functions" -HELP: (rect>) -{ $values { "x" real } { "y" real } { "z" number } } -{ $description "Creates a complex number from real and imaginary components." } -{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ; - HELP: rect> { $values { "x" real } { "y" real } { "z" number } } { $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ; diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 397a7cc2f3..66d813bab8 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -157,3 +157,8 @@ IN: math.functions.tests 2135623355842621559 [ >bignum ] tri@ ^mod ] unit-test + +[ 1.0 ] [ 1.0 2.5 0.0 lerp ] unit-test +[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test +[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test + diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index a6beb87345..a1bf9480d5 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -7,19 +7,8 @@ IN: math.functions : >fraction ( a/b -- a b ) [ numerator ] [ denominator ] bi ; inline -) ( x y -- z ) - dup 0 = [ drop ] [ ] if ; inline - -PRIVATE> - : rect> ( x y -- z ) - 2dup [ real? ] both? [ - (rect>) - ] [ - "Complex number must have real components" throw - ] if ; inline + dup 0 = [ drop ] [ complex boa ] if ; inline GENERIC: sqrt ( x -- y ) foldable @@ -29,12 +18,12 @@ M: real sqrt : factor-2s ( n -- r s ) #! factor an integer into 2^r * s dup 0 = [ 1 ] [ - 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while + 0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while ] if ; inline interval ] } [ (interval-abs) points>interval ] } cond ; @@ -376,11 +378,11 @@ SYMBOL: incomparable : interval-log2 ( i1 -- i2 ) { { empty-interval [ empty-interval ] } - { full-interval [ 0 [a,inf] ] } + { full-interval [ [0,inf] ] } [ to>> first 1 max dup most-positive-fixnum > [ drop full-interval interval-log2 ] - [ 1+ >integer log2 0 swap [a,b] ] + [ 1 + >integer log2 0 swap [a,b] ] if ] } case ; @@ -407,7 +409,7 @@ SYMBOL: incomparable : integral-closure ( i1 -- i2 ) dup special-interval? [ - [ from>> first2 [ 1+ ] unless ] - [ to>> first2 [ 1- ] unless ] + [ from>> first2 [ 1 + ] unless ] + [ to>> first2 [ 1 - ] unless ] bi [a,b] ] unless ; diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor deleted file mode 100755 index 8c237d0dc3..0000000000 --- a/basis/math/miller-rabin/miller-rabin.factor +++ /dev/null @@ -1,76 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel locals math math.functions math.ranges -random sequences sets ; -IN: math.miller-rabin - -odd ( n -- int ) dup even? [ 1+ ] when ; foldable - -TUPLE: positive-even-expected n ; - -:: (miller-rabin) ( n trials -- ? ) - [let | r [ n 1- factor-2s drop ] - s [ n 1- factor-2s nip ] - prime?! [ t ] - a! [ 0 ] - count! [ 0 ] | - trials [ - n 1- [1,b] random a! - a s n ^mod 1 = [ - 0 count! - r [ - 2^ s * a swap n ^mod n - -1 = - [ count 1+ count! r + ] when - ] each - count zero? [ f prime?! trials + ] when - ] unless drop - ] each prime? ] ; - -PRIVATE> - -: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; - -: miller-rabin* ( n numtrials -- ? ) - over { - { [ dup 1 <= ] [ 3drop f ] } - { [ dup 2 = ] [ 3drop t ] } - { [ dup even? ] [ 3drop f ] } - [ drop (miller-rabin) ] - } cond ; - -: miller-rabin ( n -- ? ) 10 miller-rabin* ; - -: next-prime ( n -- p ) - next-odd dup miller-rabin [ next-prime ] unless ; - -: random-prime ( numbits -- p ) - random-bits next-prime ; - -ERROR: no-relative-prime n ; - - [ 2 + (find-relative-prime) ] [ nip ] if ; - -PRIVATE> - -: find-relative-prime* ( n guess -- p ) - #! find a prime relative to n with initial guess - >odd (find-relative-prime) ; - -: find-relative-prime ( n -- p ) - dup random find-relative-prime* ; - -ERROR: too-few-primes ; - -: unique-primes ( numbits n -- seq ) - #! generate two primes - swap - dup 5 < [ too-few-primes ] when - 2dup [ random-prime ] curry replicate - dup all-unique? [ 2nip ] [ drop unique-primes ] if ; diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor index edffa5377d..6617556270 100644 --- a/basis/math/polynomials/polynomials-docs.factor +++ b/basis/math/polynomials/polynomials-docs.factor @@ -93,7 +93,13 @@ HELP: pdiff { $description "Finds the derivative of " { $snippet "p" } "." } ; HELP: polyval -{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } } +{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } } { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." } -{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ; +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ; +HELP: polyval* +{ $values { "p" "a literal polynomial" } } +{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." } +{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ; + +{ polyval polyval* } related-words diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 749bde3a10..fd6eda4a90 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel make math math.order math.vectors sequences - splitting vectors ; + splitting vectors macros combinators ; IN: math.polynomials : powers ( n x -- seq ) - 1 [ * ] accumulate nip ; + 1 [ * ] accumulate nip ; : p= ( p q -- ? ) pextend = ; @@ -29,7 +29,7 @@ PRIVATE> : n*p ( n p -- n*p ) n*v ; : pextend-conv ( p q -- p q ) - 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ; + 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ; : p* ( p q -- r ) 2unempty pextend-conv dup length @@ -44,7 +44,7 @@ PRIVATE> 2ptrim 2dup [ length ] bi@ - dup 1 < [ drop 1 ] when - [ over length + 0 pad-head pextend ] keep 1+ ; + [ over length + 0 pad-head pextend ] keep 1 + ; : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences @@ -80,6 +80,12 @@ PRIVATE> : pdiff ( p -- p' ) dup length v* { 0 } ?head drop ; -: polyval ( p x -- p[x] ) - [ dup length ] dip powers v. ; +: polyval ( x p -- p[x] ) + [ length swap powers ] [ nip ] 2bi v. ; + +MACRO: polyval* ( p -- ) + reverse + [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ] + [ first \ drop swap [ ] 2sequence ] bi + prefix \ cleave [ ] 2sequence ; diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 278bf70b3d..f5fa468687 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators kernel make math math.functions math.primes sequences ; +USING: arrays combinators kernel make math math.functions +math.primes sequences ; IN: math.primes.factors ] } 1&& + [ invalid-lucas-lehmer-candidate ] unless ; + +PRIVATE> + +: lucas-lehmer ( p -- ? ) + lucas-lehmer-guard + { + { [ dup 2 = ] [ drop t ] } + { [ dup prime? ] [ do-lucas-lehmer ] } + [ drop f ] + } cond ; diff --git a/basis/math/miller-rabin/authors.txt b/basis/math/primes/miller-rabin/authors.txt similarity index 100% rename from basis/math/miller-rabin/authors.txt rename to basis/math/primes/miller-rabin/authors.txt diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor new file mode 100644 index 0000000000..2d19d51e06 --- /dev/null +++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel sequences math ; +IN: math.primes.miller-rabin + +HELP: miller-rabin +{ $values + { "n" integer } + { "?" "a boolean" } +} +{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ; + +{ miller-rabin miller-rabin* } related-words + +HELP: miller-rabin* +{ $values + { "n" integer } { "numtrials" integer } + { "?" "a boolean" } +} +{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ; + +ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test" +"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl +"The Miller-Rabin probabilistic primality test:" +{ $subsection miller-rabin } +{ $subsection miller-rabin* } ; + +ABOUT: "math.primes.miller-rabin" diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor similarity index 68% rename from basis/math/miller-rabin/miller-rabin-tests.factor rename to basis/math/primes/miller-rabin/miller-rabin-tests.factor index 5f1b9835e4..d201abfef8 100644 --- a/basis/math/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor @@ -1,11 +1,11 @@ -USING: math.miller-rabin tools.test ; -IN: math.miller-rabin.tests +USING: kernel math.primes.miller-rabin sequences tools.test ; +IN: math.primes.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ t ] [ 2 miller-rabin ] unit-test [ t ] [ 3 miller-rabin ] unit-test [ f ] [ 36 miller-rabin ] unit-test [ t ] [ 37 miller-rabin ] unit-test -[ 101 ] [ 100 next-prime ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test \ No newline at end of file + +[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor new file mode 100755 index 0000000000..b0dfc4ed35 --- /dev/null +++ b/basis/math/primes/miller-rabin/miller-rabin.factor @@ -0,0 +1,35 @@ +! Copyright (c) 2008-2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators combinators.short-circuit kernel locals math +math.functions math.ranges random sequences sets ; +IN: math.primes.miller-rabin + + n-1 + n-1 factor-2s :> s :> r + 0 :> a! + trials [ + drop + 2 n 2 - [a,b] random a! + a s n ^mod 1 = [ + f + ] [ + r iota [ + 2^ s * a swap n ^mod n - -1 = + ] any? not + ] if + ] any? not ; + +PRIVATE> + +: miller-rabin* ( n numtrials -- ? ) + over { + { [ dup 1 <= ] [ 3drop f ] } + { [ dup 2 = ] [ 3drop t ] } + { [ dup even? ] [ 3drop f ] } + [ drop (miller-rabin) ] + } cond ; + +: miller-rabin ( n -- ? ) 10 miller-rabin* ; diff --git a/basis/math/miller-rabin/summary.txt b/basis/math/primes/miller-rabin/summary.txt similarity index 100% rename from basis/math/miller-rabin/summary.txt rename to basis/math/primes/miller-rabin/summary.txt diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor index c7dbc950e8..71bf3ac2c8 100644 --- a/basis/math/primes/primes-docs.factor +++ b/basis/math/primes/primes-docs.factor @@ -1,10 +1,10 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax math sequences ; IN: math.primes { next-prime prime? } related-words HELP: next-prime -{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } } +{ $values { "n" integer } { "p" "a prime number" } } { $description "Return the next prime number greater than " { $snippet "n" } "." } ; HELP: prime? @@ -20,3 +20,48 @@ HELP: primes-upto HELP: primes-between { $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } } { $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ; + +HELP: find-relative-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; + +HELP: find-relative-prime* +{ $values + { "n" integer } { "guess" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; + +HELP: random-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: unique-primes +{ $values + { "numbits" integer } { "n" integer } + { "seq" sequence } +} +{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; + +ARTICLE: "math.primes" "Prime numbers" +"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl +"Testing if a number is prime:" +{ $subsection prime? } +"Generating prime numbers:" +{ $subsection next-prime } +{ $subsection primes-upto } +{ $subsection primes-between } +{ $subsection random-prime } +"Generating relative prime numbers:" +{ $subsection find-relative-prime } +{ $subsection find-relative-prime* } +"Make a sequence of random prime numbers:" +{ $subsection unique-primes } ; + +ABOUT: "math.primes" diff --git a/basis/math/primes/primes-tests.factor b/basis/math/primes/primes-tests.factor index db738399ef..6580f0780e 100644 --- a/basis/math/primes/primes-tests.factor +++ b/basis/math/primes/primes-tests.factor @@ -1,4 +1,6 @@ -USING: arrays math.primes tools.test ; +USING: arrays math math.primes math.primes.miller-rabin +tools.test ; +IN: math.primes.tests { 1237 } [ 1234 next-prime ] unit-test { f t } [ 1234 prime? 1237 prime? ] unit-test @@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ; { { 4999963 4999999 5000011 5000077 5000081 } } [ 4999962 5000082 primes-between >array ] unit-test + +[ 2 ] [ 1 next-prime ] unit-test +[ 3 ] [ 2 next-prime ] unit-test +[ 5 ] [ 3 next-prime ] unit-test +[ 101 ] [ 100 next-prime ] unit-test +[ t ] [ 2135623355842621559 miller-rabin ] unit-test +[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test + +[ 49 ] [ 50 random-prime log2 ] unit-test diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 688fdad713..e3985fc600 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007-2009 Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math math.functions math.miller-rabin -math.order math.primes.erato math.ranges sequences ; +USING: combinators kernel math math.bitwise math.functions +math.order math.primes.erato math.primes.miller-rabin +math.ranges random sequences sets fry ; IN: math.primes } cond ; foldable : next-prime ( n -- p ) - next-odd [ dup really-prime? ] [ 2 + ] until ; foldable + dup 2 < [ + drop 2 + ] [ + next-odd [ dup really-prime? ] [ 2 + ] until + ] if ; foldable : primes-between ( low high -- seq ) [ dup 3 max dup even? [ 1 + ] when ] dip @@ -31,3 +36,34 @@ PRIVATE> : primes-upto ( n -- seq ) 2 swap primes-between ; : coprime? ( a b -- ? ) gcd nip 1 = ; foldable + +: random-prime ( numbits -- p ) + random-bits* next-prime ; + +: estimated-primes ( m -- n ) + dup log / ; foldable + +ERROR: no-relative-prime n ; + + [ 2 + (find-relative-prime) ] [ nip ] if ; + +PRIVATE> + +: find-relative-prime* ( n guess -- p ) + #! find a prime relative to n with initial guess + >odd (find-relative-prime) ; + +: find-relative-prime ( n -- p ) + dup random find-relative-prime* ; + +ERROR: too-few-primes n numbits ; + +: unique-primes ( n numbits -- seq ) + 2dup 2^ estimated-primes > [ too-few-primes ] when + 2dup '[ _ random-prime ] replicate + dup all-unique? [ 2nip ] [ drop unique-primes ] if ; diff --git a/basis/math/primes/safe/authors.txt b/basis/math/primes/safe/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/math/primes/safe/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/math/primes/safe/safe-docs.factor b/basis/math/primes/safe/safe-docs.factor new file mode 100644 index 0000000000..861fc4e4ed --- /dev/null +++ b/basis/math/primes/safe/safe-docs.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit help.markup help.syntax kernel +math math.functions math.primes random ; +IN: math.primes.safe + +HELP: next-safe-prime +{ $values + { "n" integer } + { "q" integer } +} +{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; + +HELP: random-safe-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: safe-prime? +{ $values + { "q" integer } + { "?" "a boolean" } +} +{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; + + +ARTICLE: "math.primes.safe" "Safe prime numbers" +"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl + +"Testing if a number is a safe prime:" +{ $subsection safe-prime? } +"Generating safe prime numbers:" +{ $subsection next-safe-prime } +{ $subsection random-safe-prime } ; + +ABOUT: "math.primes.safe" diff --git a/basis/math/primes/safe/safe-tests.factor b/basis/math/primes/safe/safe-tests.factor new file mode 100644 index 0000000000..ef9aa9246f --- /dev/null +++ b/basis/math/primes/safe/safe-tests.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: math.primes.safe math.primes.safe.private tools.test ; +IN: math.primes.safe.tests + +[ 863 ] [ 862 next-safe-prime ] unit-test +[ f ] [ 862 safe-prime? ] unit-test +[ t ] [ 7 safe-prime? ] unit-test +[ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 47 safe-prime-candidate? ] unit-test +[ t ] [ 47 safe-prime? ] unit-test +[ t ] [ 863 safe-prime? ] unit-test + +[ 47 ] [ 31 next-safe-prime ] unit-test diff --git a/basis/math/primes/safe/safe.factor b/basis/math/primes/safe/safe.factor new file mode 100644 index 0000000000..a3becb628f --- /dev/null +++ b/basis/math/primes/safe/safe.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit kernel math math.functions +math.primes random ; +IN: math.primes.safe + + + +: safe-prime? ( q -- ? ) + { + [ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ] + [ prime? ] + } 1&& ; + +: next-safe-prime ( n -- q ) + next-safe-prime-candidate + dup safe-prime? [ next-safe-prime ] unless ; + +: random-safe-prime ( numbits -- p ) + random-bits* next-safe-prime ; diff --git a/basis/math/quaternions/quaternions-docs.factor b/basis/math/quaternions/quaternions-docs.factor index bb34ec8da2..a24011cb7c 100644 --- a/basis/math/quaternions/quaternions-docs.factor +++ b/basis/math/quaternions/quaternions-docs.factor @@ -1,6 +1,16 @@ USING: help.markup help.syntax math math.vectors vectors ; IN: math.quaternions +HELP: q+ +{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u+v" "a quaternion" } } +{ $description "Add quaternions." } +{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q+ ." "{ C{ 0 1 } 1 }" } } ; + +HELP: q- +{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u-v" "a quaternion" } } +{ $description "Subtract quaternions." } +{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q- ." "{ C{ 0 1 } -1 }" } } ; + HELP: q* { $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } } { $description "Multiply quaternions." } diff --git a/basis/math/quaternions/quaternions-tests.factor b/basis/math/quaternions/quaternions-tests.factor index a6d255e421..3efc417e42 100644 --- a/basis/math/quaternions/quaternions-tests.factor +++ b/basis/math/quaternions/quaternions-tests.factor @@ -24,3 +24,7 @@ math.constants ; [ t ] [ qk q>v v>q qk = ] unit-test [ t ] [ 1 c>q q1 = ] unit-test [ t ] [ C{ 0 1 } c>q qi = ] unit-test +[ t ] [ qi qi q+ qi 2 q*n = ] unit-test +[ t ] [ qi qi q- q0 = ] unit-test +[ t ] [ qi qj q+ qj qi q+ = ] unit-test +[ t ] [ qi qj q- qj qi q- -1 q*n = ] unit-test diff --git a/basis/math/quaternions/quaternions.factor b/basis/math/quaternions/quaternions.factor index f2c2c6d226..b713f44ebd 100755 --- a/basis/math/quaternions/quaternions.factor +++ b/basis/math/quaternions/quaternions.factor @@ -20,6 +20,12 @@ IN: math.quaternions PRIVATE> +: q+ ( u v -- u+v ) + v+ ; + +: q- ( u v -- u-v ) + v- ; + : q* ( u v -- u*v ) [ q*a ] [ q*b ] 2bi 2array ; diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 068f599b6f..883be006dc 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -10,7 +10,7 @@ TUPLE: range { step read-only } ; : ( a b step -- range ) - [ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline + [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline M: range length ( seq -- n ) length>> ; diff --git a/basis/math/ratios/ratios-docs.factor b/basis/math/ratios/ratios-docs.factor index 7b6393dabe..2e51fa1870 100644 --- a/basis/math/ratios/ratios-docs.factor +++ b/basis/math/ratios/ratios-docs.factor @@ -47,6 +47,3 @@ HELP: 2>fraction { $values { "a/b" rational } { "c/d" rational } { "a" integer } { "c" integer } { "b" "a positive integer" } { "d" "a positive integer" } } { $description "Extracts the numerator and denominator of two rational numbers at once." } ; -HELP: ( a b -- a/b ) -{ $values { "a" integer } { "b" integer } { "a/b" "a ratio" } } -{ $description "Primitive ratio constructor. User code should call " { $link / } " to create ratios instead." } ; diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 54e4bee1a8..d4f457180e 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -9,7 +9,7 @@ IN: math.ratios ( a b -- a/b ) - dup 1 number= [ drop ] [ ] if ; inline + dup 1 number= [ drop ] [ ratio boa ] if ; inline : scale ( a/b c/d -- a*d b*c ) 2>fraction [ * swap ] dip * swap ; inline diff --git a/basis/math/rectangles/prettyprint/authors.txt b/basis/math/rectangles/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/math/rectangles/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/math/rectangles/prettyprint/prettyprint.factor b/basis/math/rectangles/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..c23be50029 --- /dev/null +++ b/basis/math/rectangles/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ; +IN: math.rectangles.prettyprint + +M: rect pprint* + \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; diff --git a/basis/math/rectangles/rectangles-tests.factor b/basis/math/rectangles/rectangles-tests.factor index ca722859d2..7959d98f92 100644 --- a/basis/math/rectangles/rectangles-tests.factor +++ b/basis/math/rectangles/rectangles-tests.factor @@ -1,42 +1,42 @@ USING: tools.test math.rectangles ; IN: math.rectangles.tests -[ T{ rect f { 10 10 } { 20 20 } } ] +[ RECT: { 10 10 } { 20 20 } ] [ - T{ rect f { 10 10 } { 50 50 } } - T{ rect f { -10 -10 } { 40 40 } } + RECT: { 10 10 } { 50 50 } + RECT: { -10 -10 } { 40 40 } rect-intersect ] unit-test -[ T{ rect f { 200 200 } { 0 0 } } ] +[ RECT: { 200 200 } { 0 0 } ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 200 200 } { 40 40 } } + RECT: { 100 100 } { 50 50 } + RECT: { 200 200 } { 40 40 } rect-intersect ] unit-test [ f ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 200 200 } { 40 40 } } + RECT: { 100 100 } { 50 50 } + RECT: { 200 200 } { 40 40 } contains-rect? ] unit-test [ t ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 120 120 } { 40 40 } } + RECT: { 100 100 } { 50 50 } + RECT: { 120 120 } { 40 40 } contains-rect? ] unit-test [ f ] [ - T{ rect f { 1000 100 } { 50 50 } } - T{ rect f { 120 120 } { 40 40 } } + RECT: { 1000 100 } { 50 50 } + RECT: { 120 120 } { 40 40 } contains-rect? ] unit-test -[ T{ rect f { 10 20 } { 20 20 } } ] [ +[ RECT: { 10 20 } { 20 20 } ] [ { { 20 20 } { 10 40 } { 30 30 } } rect-containing -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index 1d9c91328f..c8569dfdb9 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -1,12 +1,15 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays sequences math math.vectors accessors ; +USING: kernel arrays sequences math math.vectors accessors +parser ; IN: math.rectangles TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; : ( loc dim -- rect ) rect boa ; inline +SYNTAX: RECT: scan-object scan-object parsed ; + : ( -- rect ) rect new ; inline : point>rect ( loc -- rect ) { 0 0 } ; inline @@ -15,6 +18,8 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; : rect-extent ( rect -- loc ext ) rect-bounds over v+ ; +: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ; + : with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- ) [ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline @@ -55,4 +60,8 @@ M: rect contains-point? : set-rect-bounds ( rect1 rect -- ) [ [ loc>> ] dip (>>loc) ] [ [ dim>> ] dip (>>dim) ] - 2bi ; inline \ No newline at end of file + 2bi ; inline + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when \ No newline at end of file diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 589876184f..4cd8c5b888 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -15,7 +15,7 @@ IN: math.statistics : median ( seq -- n ) natural-sort dup length even? [ - [ midpoint@ dup 1- 2array ] keep nths mean + [ midpoint@ dup 1 - 2array ] keep nths mean ] [ [ midpoint@ ] keep nth ] if ; @@ -33,7 +33,7 @@ IN: math.statistics drop 0 ] [ [ [ mean ] keep [ - sq ] with sigma ] keep - length 1- / + length 1 - / ] if ; : std ( seq -- x ) @@ -47,7 +47,7 @@ IN: math.statistics 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ; : (r) ( mean(x) mean(y) {x} {y} sx sy -- r ) - * recip [ [ ((r)) ] keep length 1- / ] dip * ; + * recip [ [ ((r)) ] keep length 1 - / ] dip * ; : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy ) first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ; diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index aef4ade877..968af6a3aa 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -9,3 +9,10 @@ USING: math.vectors tools.test ; [ 5 ] [ { 1 2 } norm-sq ] unit-test [ 13 ] [ { 2 3 } norm-sq ] unit-test +[ { 1.0 2.5 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test +[ { 2.5 1.0 } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test +[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test + +[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test + +[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index eb5fa7b970..bad2733bbf 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -6,6 +6,11 @@ IN: math.vectors : vneg ( u -- v ) [ neg ] map ; +: v+n ( u n -- v ) [ + ] curry map ; +: n+v ( n u -- v ) [ + ] with map ; +: v-n ( u n -- v ) [ - ] curry map ; +: n-v ( n u -- v ) [ - ] with map ; + : v*n ( u n -- v ) [ * ] curry map ; : n*v ( n u -- v ) [ * ] with map ; : v/n ( u n -- v ) [ / ] curry map ; @@ -19,6 +24,10 @@ IN: math.vectors : vmax ( u v -- w ) [ max ] 2map ; : vmin ( u v -- w ) [ min ] 2map ; +: vfloor ( v -- _v_ ) [ floor ] map ; +: vceiling ( v -- ^v^ ) [ ceiling ] map ; +: vtruncate ( v -- -v- ) [ truncate ] map ; + : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; @@ -32,6 +41,23 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: 2tetra@ ( p q r s t u v w quot -- ) + dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline + +: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv ) + [ first lerp ] [ second lerp ] [ third lerp ] tri-curry + [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ; + +: bilerp ( aa ba ab bb {t,u} -- a_tu ) + [ first lerp ] [ second lerp ] bi-curry + [ 2bi@ ] [ call ] bi* ; + +: vlerp ( a b t -- a_t ) + [ lerp ] 3map ; + +: vnlerp ( a b t -- a_t ) + [ lerp ] curry 2map ; + HINTS: vneg { array } ; HINTS: norm-sq { array } ; HINTS: norm { array } ; @@ -50,3 +76,9 @@ HINTS: v/ { array array } ; HINTS: vmax { array array } ; HINTS: vmin { array array } ; HINTS: v. { array array } ; + +HINTS: vlerp { array array array } ; +HINTS: vnlerp { array array object } ; + +HINTS: bilerp { object object object object array } ; +HINTS: trilerp { object object object object object object object object array } ; diff --git a/basis/opengl/gl/windows/windows.factor b/basis/opengl/gl/windows/windows.factor index 8f48f60d3c..c8a179edf5 100644 --- a/basis/opengl/gl/windows/windows.factor +++ b/basis/opengl/gl/windows/windows.factor @@ -1,6 +1,11 @@ -USING: kernel windows.opengl32 ; +USING: alien.syntax kernel windows.types ; IN: opengl.gl.windows +LIBRARY: gl + +FUNCTION: HGLRC wglGetCurrentContext ( ) ; +FUNCTION: void* wglGetProcAddress ( char* name ) ; + : gl-function-context ( -- context ) wglGetCurrentContext ; inline : gl-function-address ( name -- address ) wglGetProcAddress ; inline : gl-function-calling-convention ( -- str ) "stdcall" ; inline diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index a77d29da2f..15fab1aae0 100755 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -92,11 +92,16 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; : gl-program-shaders-length ( program -- shaders-length ) GL_ATTACHED_SHADERS gl-program-get-int ; inline +! On some macosx-x86-64 graphics drivers, glGetAttachedShaders tries to treat the +! shaders parameter as a ulonglong array rather than a GLuint array as documented. +! We hack around this by allocating a buffer twice the size and sifting out the zero +! values + : gl-program-shaders ( program -- shaders ) - dup gl-program-shaders-length + dup gl-program-shaders-length 2 * 0 over - [ glGetAttachedShaders ] keep ; + [ glGetAttachedShaders ] keep [ zero? not ] filter ; : delete-gl-program-only ( program -- ) glDeleteProgram ; inline diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index d103e90bee..49725d2242 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -39,6 +39,8 @@ SLOT: display-list GENERIC: draw-scaled-texture ( dim texture -- ) +DEFER: make-texture + > first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri glTexSubImage2D ; -: make-texture ( image -- id ) - #! We use glTexSubImage2D to work around the power of 2 texture size - #! limitation - gen-texture [ - GL_TEXTURE_BIT [ - GL_TEXTURE_2D swap glBindTexture - non-power-of-2-textures? get - [ dup bitmap>> (tex-image) ] - [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if - ] do-attribs - ] keep ; - : init-texture ( -- ) GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri @@ -176,6 +166,18 @@ CONSTANT: max-texture-size { 512 512 } PRIVATE> +: make-texture ( image -- id ) + #! We use glTexSubImage2D to work around the power of 2 texture size + #! limitation + gen-texture [ + GL_TEXTURE_BIT [ + GL_TEXTURE_2D swap glBindTexture + non-power-of-2-textures? get + [ dup bitmap>> (tex-image) ] + [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if + ] do-attribs + ] keep ; + : ( image loc -- texture ) over dim>> max-texture-size [ <= ] 2all? [ ] diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 683fa328d8..cae1e05dc8 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -199,10 +199,10 @@ IN: peg.tests USE: compiler -[ ] [ disable-compiler ] unit-test +[ ] [ disable-optimizer ] unit-test [ ] [ "" epsilon parse drop ] unit-test -[ ] [ enable-compiler ] unit-test +[ ] [ enable-optimizer ] unit-test [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test diff --git a/basis/present/present-tests.factor b/basis/present/present-tests.factor index 22d352cb5a..e908fd8147 100644 --- a/basis/present/present-tests.factor +++ b/basis/present/present-tests.factor @@ -1,5 +1,5 @@ IN: present.tests -USING: tools.test present math vocabs tools.vocabs sequences kernel ; +USING: tools.test vocabs.hierarchy present math vocabs sequences kernel ; [ "3" ] [ 3 present ] unit-test [ "Hi" ] [ "Hi" present ] unit-test diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 1976c84fd1..3dcd7fb0ed 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -1,11 +1,10 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays generic hashtables io assocs -kernel math namespaces make sequences strings sbufs vectors +USING: accessors arrays byte-arrays byte-vectors generic hashtables io +assocs kernel math namespaces make sequences strings sbufs vectors words prettyprint.config prettyprint.custom prettyprint.sections -quotations io io.pathnames io.styles math.parser effects -classes.tuple math.order classes.tuple.private classes -combinators colors ; +quotations io io.pathnames io.styles math.parser effects classes.tuple +math.order classes.tuple.private classes combinators colors ; IN: prettyprint.backend M: effect pprint* effect>string "(" ")" surround text ; @@ -135,8 +134,8 @@ M: pathname pprint* [ text ] [ f ] bi* \ } pprint-word block> ; -M: tuple pprint* - boa-tuples? get [ call-next-method ] [ +: pprint-tuple ( tuple -- ) + boa-tuples? get [ pprint-object ] [ [ pprint-sequence ; M: vector >pprint-sequence ; +M: byte-vector >pprint-sequence ; M: curry >pprint-sequence ; M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; @@ -202,6 +206,7 @@ M: object pprint-object ( obj -- ) M: object pprint* pprint-object ; M: vector pprint* pprint-object ; +M: byte-vector pprint* pprint-object ; M: hashtable pprint* pprint-object ; M: curry pprint* pprint-object ; M: compose pprint* pprint-object ; diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index c35d7488ac..651e43ef5b 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests 100 [ 100 random ] replicate ; : test-rng ( seed quot -- ) - [ ] dip with-random ; inline + [ ] dip with-random ; inline [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index c7600a731f..222ecaf935 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -40,9 +40,17 @@ HELP: random-bytes } ; HELP: random-bits -{ $values { "n" "an integer" } { "r" "a random integer" } } +{ $values { "numbits" integer } { "r" "a random integer" } } { $description "Outputs an random integer n bits in length." } ; +HELP: random-bits* +{ $values + { "numbits" integer } + { "n" integer } +} +{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; + + HELP: with-random { $values { "tuple" "a random generator" } { "quot" "a quotation" } } { $description "Calls the quotation with the random generator in a dynamic variable. All random numbers will be generated using this random generator." } ; @@ -93,6 +101,9 @@ $nl "Randomizing a sequence:" { $subsection randomize } "Deleting a random element from a sequence:" -{ $subsection delete-random } ; +{ $subsection delete-random } +"Random numbers with " { $snippet "n" } " bits:" +{ $subsection random-bits } +{ $subsection random-bits* } ; ABOUT: "random" diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 9607627b3d..2b6ac9b1b8 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -23,3 +23,5 @@ IN: random.tests [ f ] [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test + +[ 49 ] [ 50 random-bits* log2 ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index ebde3802b4..661e771258 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -3,7 +3,7 @@ USING: alien.c-types kernel math namespaces sequences io.backend io.binary combinators system vocabs.loader summary math.bitwise byte-vectors fry byte-arrays -math.ranges ; +math.ranges math.constants math.functions accessors ; IN: random SYMBOL: system-random-generator @@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; PRIVATE> -: random-bits ( n -- r ) 2^ random-integer ; +: random-bits ( numbits -- r ) 2^ random-integer ; + +: random-bits* ( numbits -- n ) + 1 - [ random-bits ] keep set-bit ; : random ( seq -- elt ) [ f ] [ @@ -54,7 +57,7 @@ PRIVATE> : randomize ( seq -- seq ) dup length [ dup 1 > ] - [ [ random ] [ 1- ] bi [ pick exchange ] keep ] + [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ] while drop ; : delete-random ( seq -- elt ) @@ -69,6 +72,20 @@ PRIVATE> : with-secure-random ( quot -- ) secure-random-generator get swap with-random ; inline +: uniform-random-float ( min max -- n ) + 4 random-bytes underlying>> *uint >float + 4 random-bytes underlying>> *uint >float + 2.0 32 ^ * + + [ over - 2.0 -64 ^ * ] dip + * + ; inline + +: normal-random-float ( mean sigma -- n ) + 0.0 1.0 uniform-random-float + 0.0 1.0 uniform-random-float + [ 2 pi * * cos ] + [ 1.0 swap - log -2.0 * sqrt ] + bi* * * + ; + USE: vocabs.loader { diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index a4cf74e1df..488deef41f 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -1,6 +1,6 @@ USING: accessors alien.c-types byte-arrays continuations -kernel windows windows.advapi32 init namespaces random -destructors locals ; +kernel windows.advapi32 init namespaces random destructors +locals windows.errors ; IN: random.windows TUPLE: windows-rng provider type ; diff --git a/basis/refs/refs-docs.factor b/basis/refs/refs-docs.factor old mode 100644 new mode 100755 index 9c10641c4c..9971a1d4fa --- a/basis/refs/refs-docs.factor +++ b/basis/refs/refs-docs.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: boxes help.markup help.syntax kernel math namespaces ; +USING: boxes help.markup help.syntax kernel math namespaces assocs ; IN: refs ARTICLE: "refs" "References" -"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "." -{ $subsection get-ref } -{ $subsection set-ref } -{ $subsection set-ref* } -{ $subsection delete-ref } +"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing a protocol." +{ $subsection "refs-protocol" } +{ $subsection "refs-impls" } +{ $subsection "refs-utils" } +"References are used by the " { $link "ui-inspector" } "." ; + +ABOUT: "refs" + +ARTICLE: "refs-impls" "Reference implementations" "References to objects:" { $subsection obj-ref } { $subsection } @@ -27,20 +31,24 @@ ARTICLE: "refs" "References" { $subsection slot-ref } { $subsection } "Using boxes as references:" -{ $subsection "box-refs" } -"References are used by the UI inspector." ; +{ $subsection "box-refs" } ; -ABOUT: "refs" +ARTICLE: "refs-utils" "Reference utilities" +{ $subsection ref-on } +{ $subsection ref-off } +{ $subsection ref-inc } +{ $subsection ref-dec } +{ $subsection set-ref* } ; -ARTICLE: "refs-protocol" "Reference Protocol" +ARTICLE: "refs-protocol" "Reference protocol" "To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:" { $subsection get-ref } { $subsection set-ref } "References may also implement:" { $subsection delete-ref } ; -ARTICLE: "box-refs" "Using Boxes as References" -"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ; +ARTICLE: "box-refs" "Boxes as references" +{ $link "boxes" } " are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ; HELP: ref { $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ; @@ -89,14 +97,14 @@ HELP: key-ref { $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link } "." } ; HELP: -{ $values { "assoc" "an assoc" } { "key" object } { "key-ref" key-ref } } +{ $values { "assoc" assoc } { "key" object } { "key-ref" key-ref } } { $description "Creates a reference to a key stored in an assoc." } ; HELP: value-ref { $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link } "." } ; HELP: -{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } } +{ $values { "assoc" assoc } { "key" object } { "value-ref" value-ref } } { $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ; { get-ref set-ref delete-ref set-ref* } related-words diff --git a/basis/see/see.factor b/basis/see/see.factor index 2494c72fa4..37153b5229 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.builtin -classes.intersection classes.mixin classes.predicate -classes.singleton classes.tuple classes.union combinators -definitions effects generic generic.standard io io.pathnames +classes.intersection classes.mixin classes.predicate classes.singleton +classes.tuple classes.union combinators definitions effects generic +generic.single generic.standard generic.hook io io.pathnames io.streams.string io.styles kernel make namespaces prettyprint prettyprint.backend prettyprint.config prettyprint.custom -prettyprint.sections sequences sets sorting strings summary -words words.symbol words.constant words.alias ; +prettyprint.sections sequences sets sorting strings summary words +words.symbol words.constant words.alias ; IN: see GENERIC: synopsis* ( defspec -- ) diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 73e719b806..1e470b699a 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -2,7 +2,8 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool specialized-arrays.ushort alien.c-types accessors kernel -specialized-arrays.direct.int arrays ; +specialized-arrays.direct.int specialized-arrays.char +specialized-arrays.uint arrays combinators ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -10,7 +11,13 @@ specialized-arrays.direct.int arrays ; [ 2 ] [ int-array{ 1 2 3 } second ] unit-test -[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test +[ t ] [ + { t f t } >bool-array underlying>> + { 1 0 1 } "bool" heap-size { + { 1 [ >char-array ] } + { 4 [ >uint-array ] } + } case underlying>> = +] unit-test [ ushort-array{ 1234 } ] [ little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 4fb5bab96f..338b052316 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry arrays generic io io.streams.string kernel math -namespaces parser sequences strings vectors words quotations -effects classes continuations assocs combinators -compiler.errors accessors math.order definitions sets -generic.standard.engines.tuple hints macros stack-checker.state +USING: fry arrays generic io io.streams.string kernel math namespaces +parser sequences strings vectors words quotations effects classes +continuations assocs combinators compiler.errors accessors math.order +definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor index e5c0f23b30..b222cbbcf7 100644 --- a/basis/stack-checker/call-effect/call-effect-tests.factor +++ b/basis/stack-checker/call-effect/call-effect-tests.factor @@ -1,7 +1,16 @@ -USING: stack-checker.call-effect tools.test math kernel ; +USING: stack-checker.call-effect tools.test math kernel math effects ; IN: stack-checker.call-effect.tests [ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test [ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test [ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test -[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test \ No newline at end of file +[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test + +[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test +[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test +[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test +[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test +[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test +[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test +[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test +[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index 100088f174..b3b678d93d 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.private effects fry kernel kernel.private make sequences continuations quotations -stack-checker stack-checker.transforms words ; +stack-checker stack-checker.transforms words math ; IN: stack-checker.call-effect ! call( and execute( have complex expansions. @@ -18,14 +18,36 @@ IN: stack-checker.call-effect TUPLE: inline-cache value ; -: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline +: cache-hit? ( word/quot ic -- ? ) + [ value>> eq? ] [ value>> ] bi and ; inline -SYMBOL: +unknown+ +SINGLETON: +unknown+ GENERIC: cached-effect ( quot -- effect ) M: object cached-effect drop +unknown+ ; +GENERIC: curry-effect ( effect -- effect' ) + +M: +unknown+ curry-effect ; + +M: effect curry-effect + [ in>> length ] [ out>> length ] [ terminated?>> ] tri + pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if + effect boa ; + +M: curry cached-effect + quot>> cached-effect curry-effect ; + +: compose-effects* ( effect1 effect2 -- effect' ) + { + { [ 2dup [ effect? ] both? ] [ compose-effects ] } + { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] } + } cond ; + +M: compose cached-effect + [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ; + M: quotation cached-effect dup cached-effect>> [ ] [ @@ -79,7 +101,7 @@ M: quotation cached-effect [ '[ _ execute ] ] dip call-effect-slow ; inline : execute-effect-unsafe? ( word effect -- ? ) - over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline + over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline : execute-effect-fast ( word effect inline-cache -- ) 2over execute-effect-unsafe? diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor old mode 100644 new mode 100755 index 7a87ab988d..6a67b815cd --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -84,8 +84,11 @@ HELP: inconsistent-recursive-call-error } ; ARTICLE: "inference-errors" "Stack checker errors" -"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "." -$nl +"These " { $link "inference" } " failure conditions are reported in one of two ways:" +{ $list + { { $link "tools.inference" } " throws them as errors" } + { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } } +} "Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):" { $subsection literal-expected } "Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index e036d4d81b..b1071df708 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -33,4 +33,6 @@ ERROR: unknown-primitive-error < inference-error ; ERROR: transform-expansion-error < inference-error word error ; +ERROR: bad-declaration-error < inference-error declaration ; + M: object (literal) "literal value" literal-expected ; \ No newline at end of file diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index eade33e52b..56ef67d2a8 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -1,17 +1,18 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors alien alien.accessors arrays byte-arrays -classes sequences.private continuations.private effects generic -hashtables hashtables.private io io.backend io.files -io.files.private io.streams.c kernel kernel.private math -math.private memory namespaces namespaces.private parser -quotations quotations.private sbufs sbufs.private -sequences sequences.private slots.private strings +USING: fry accessors alien alien.accessors arrays byte-arrays classes +sequences.private continuations.private effects generic hashtables +hashtables.private io io.backend io.files io.files.private +io.streams.c kernel kernel.private math math.private +math.parser.private memory memory.private namespaces +namespaces.private parser quotations quotations.private sbufs +sbufs.private sequences sequences.private slots.private strings strings.private system threads.private classes.tuple -classes.tuple.private vectors vectors.private words definitions -words.private assocs summary compiler.units system.private -combinators locals locals.backend locals.types words.private +classes.tuple.private vectors vectors.private words definitions assocs +summary compiler.units system.private combinators +combinators.short-circuit locals locals.backend locals.types quotations.private combinators.private stack-checker.values +generic.single generic.single.private alien.libraries stack-checker.alien stack-checker.state @@ -57,8 +58,12 @@ IN: stack-checker.known-words : infer-shuffle-word ( word -- ) "shuffle" word-prop infer-shuffle ; +: check-declaration ( declaration -- declaration ) + dup { [ array? ] [ [ class? ] all? ] } 1&& + [ bad-declaration-error ] unless ; + : infer-declare ( -- ) - pop-literal nip + pop-literal nip check-declaration [ length ensure-d ] keep zip #declare, ; @@ -90,15 +95,6 @@ M: composed infer-call* M: object infer-call* "literal quotation" literal-expected ; -: infer-nslip ( n -- ) - [ infer->r infer-call ] [ infer-r> ] bi ; - -: infer-slip ( -- ) 1 infer-nslip ; - -: infer-2slip ( -- ) 2 infer-nslip ; - -: infer-3slip ( -- ) 3 infer-nslip ; - : infer-ndip ( word n -- ) [ literals get ] 2dip [ '[ _ def>> infer-quot-here ] ] @@ -142,7 +138,7 @@ M: object infer-call* apply-word/effect ; : infer-execute-effect-unsafe ( -- ) - \ execute infer-effect-unsafe ; + \ (execute) infer-effect-unsafe ; : infer-call-effect-unsafe ( -- ) \ call infer-effect-unsafe ; @@ -175,9 +171,6 @@ M: object infer-call* { \ declare [ infer-declare ] } { \ call [ infer-call ] } { \ (call) [ infer-call ] } - { \ slip [ infer-slip ] } - { \ 2slip [ infer-2slip ] } - { \ 3slip [ infer-3slip ] } { \ dip [ infer-dip ] } { \ 2dip [ infer-2dip ] } { \ 3dip [ infer-3dip ] } @@ -211,7 +204,7 @@ M: object infer-call* "local-word-def" word-prop infer-quot-here ; { - declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose + declare call (call) dip 2dip 3dip curry compose execute (execute) call-effect-unsafe execute-effect-unsafe if dispatch exit load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect @@ -227,14 +220,7 @@ M: object infer-call* ! More words not to compile \ call t "no-compile" set-word-prop -\ call subwords [ t "no-compile" set-word-prop ] each - \ execute t "no-compile" set-word-prop -\ execute subwords [ t "no-compile" set-word-prop ] each - -\ effective-method t "no-compile" set-word-prop -\ effective-method subwords [ t "no-compile" set-word-prop ] each - \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) @@ -292,14 +278,11 @@ M: object infer-call* \ bignum>float { bignum } { float } define-primitive \ bignum>float make-foldable -\ { integer integer } { ratio } define-primitive -\ make-foldable +\ (string>float) { byte-array } { float } define-primitive +\ (string>float) make-foldable -\ string>float { string } { float } define-primitive -\ string>float make-foldable - -\ float>string { float } { string } define-primitive -\ float>string make-foldable +\ (float>string) { float } { byte-array } define-primitive +\ (float>string) make-foldable \ float>bits { real } { integer } define-primitive \ float>bits make-foldable @@ -313,9 +296,6 @@ M: object infer-call* \ bits>double { integer } { float } define-primitive \ bits>double make-foldable -\ { real real } { complex } define-primitive -\ make-foldable - \ both-fixnums? { object object } { object } define-primitive \ fixnum+ { fixnum fixnum } { integer } define-primitive @@ -473,9 +453,9 @@ M: object infer-call* \ gc-stats { } { array } define-primitive -\ save-image { string } { } define-primitive +\ (save-image) { byte-array } { } define-primitive -\ save-image-and-exit { string } { } define-primitive +\ (save-image-and-exit) { byte-array } { } define-primitive \ data-room { } { integer integer array } define-primitive \ data-room make-flushable @@ -489,9 +469,9 @@ M: object infer-call* \ tag { object } { fixnum } define-primitive \ tag make-foldable -\ dlopen { string } { dll } define-primitive +\ (dlopen) { byte-array } { dll } define-primitive -\ dlsym { string object } { c-ptr } define-primitive +\ (dlsym) { byte-array object } { c-ptr } define-primitive \ dlclose { dll } { } define-primitive @@ -606,7 +586,7 @@ M: object infer-call* \ die { } { } define-primitive -\ fopen { string string } { alien } define-primitive +\ (fopen) { byte-array byte-array } { alien } define-primitive \ fgetc { alien } { object } define-primitive @@ -659,7 +639,7 @@ M: object infer-call* \ become { array array } { } define-primitive -\ innermost-frame-quot { callstack } { quotation } define-primitive +\ innermost-frame-executing { callstack } { object } define-primitive \ innermost-frame-scan { callstack } { fixnum } define-primitive @@ -676,3 +656,12 @@ M: object infer-call* \ gc-stats { } { array } define-primitive \ jit-compile { quotation } { } define-primitive + +\ lookup-method { object array } { word } define-primitive + +\ reset-dispatch-stats { } { } define-primitive +\ dispatch-stats { } { array } define-primitive +\ reset-inline-cache-stats { } { } define-primitive +\ inline-cache-stats { } { array } define-primitive + +\ optimized? { word } { object } define-primitive \ No newline at end of file diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 243221ccf0..7d18482bff 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -102,6 +102,7 @@ ARTICLE: "tools.inference" "Stack effect tools" "Comparing effects:" { $subsection effect-height } { $subsection effect<= } +{ $subsection effect= } "The class of stack effects:" { $subsection effect } { $subsection effect? } ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 919cd098f6..201f3ce30b 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -180,7 +180,7 @@ DEFER: blah4 over [ 2drop ] [ - [ swap slip ] keep swap bad-combinator + [ dip ] keep swap bad-combinator ] if ; inline recursive [ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index cd8a57bf2e..8113a662d6 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -19,7 +19,6 @@ IN: stack-checker.transforms rstate recursive-state [ word stack quot call-transformer ] with-variable [ - word inlined-dependency depends-on values [ length meta-d shorten-by ] [ #drop, ] bi rstate infer-quot ] [ word infer-word ] if* ; @@ -108,7 +107,6 @@ IN: stack-checker.transforms ] 1 define-transform \ boa t "no-compile" set-word-prop -M\ tuple-class boa t "no-compile" set-word-prop \ new [ dup tuple-class? [ diff --git a/basis/strings/tables/tables-tests.factor b/basis/strings/tables/tables-tests.factor index a77312897a..9429772f4a 100644 --- a/basis/strings/tables/tables-tests.factor +++ b/basis/strings/tables/tables-tests.factor @@ -2,3 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test strings.tables ; IN: strings.tables.tests + +[ { "A BB" "CC D" } ] [ { { "A" "BB" } { "CC" "D" } } format-table ] unit-test + +[ { "A C" "B " "D E" } ] [ { { "A\nB" "C" } { "D" "E" } } format-table ] unit-test \ No newline at end of file diff --git a/basis/strings/tables/tables.factor b/basis/strings/tables/tables.factor index c6ccba5a78..51032264c7 100644 --- a/basis/strings/tables/tables.factor +++ b/basis/strings/tables/tables.factor @@ -1,21 +1,30 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences fry math.order ; +USING: kernel sequences fry math.order splitting ; IN: strings.tables ] dip '[ 0 = @ ] 2map ; inline +: max-length ( seq -- n ) + [ length ] [ max ] map-reduce ; + +: format-row ( seq ? -- seq ) + [ + dup max-length + '[ _ "" pad-tail ] map + ] unless ; + +: format-column ( seq ? -- seq ) + [ + dup max-length + '[ _ CHAR: \s pad-tail ] map + ] unless ; + PRIVATE> : format-table ( table -- seq ) - flip [ format-column ] map-last - flip [ " " join ] map ; \ No newline at end of file + [ [ [ string-lines ] map ] dip format-row flip ] map-last concat + flip [ format-column ] map-last flip [ " " join ] map ; \ No newline at end of file diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 99def097a2..00d86a1608 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel arrays sequences math namespaces -strings io fry vectors words assocs combinators sorting -unicode.case unicode.categories math.order vocabs -tools.vocabs unicode.data locals ; +USING: accessors kernel arrays sequences math namespaces strings io +fry vectors words assocs combinators sorting unicode.case +unicode.categories math.order vocabs vocabs.hierarchy unicode.data +locals ; IN: tools.completion :: (fuzzy) ( accum i full ch -- accum i full ? ) diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor index 1ac4557ec4..15fdb9f9b5 100644 --- a/basis/tools/continuations/continuations.factor +++ b/basis/tools/continuations/continuations.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.arrow arrays accessors -generic generic.standard definitions make sbufs tools.crossref ; +generic generic.single definitions make sbufs tools.crossref fry ; IN: tools.continuations > (step-into-quot) ] @@ -80,21 +79,18 @@ M: object add-breakpoint ; (step-into-call-next-method) } [ t "no-compile" set-word-prop ] each >> +: >innermost-frame< ( callstack -- n quot ) + [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ; + +: (change-frame) ( callstack quot -- callstack' ) + [ dup innermost-frame-executing quotation? ] dip '[ + clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri + ] when ; inline + : change-frame ( continuation quot -- continuation' ) #! Applies quot to innermost call frame of the #! continuation. - [ clone ] dip [ - [ clone ] dip - [ - [ - [ innermost-frame-scan 1+ ] - [ innermost-frame-quot ] bi - ] dip call - ] - [ drop set-innermost-frame-quot ] - [ drop ] - 2tri - ] curry change-call ; inline + [ clone ] dip '[ _ (change-frame) ] change-call ; inline PRIVATE> @@ -102,7 +98,7 @@ PRIVATE> [ 2dup length = [ nip [ break ] append ] [ 2dup nth \ break = [ nip ] [ - swap 1+ cut [ break ] glue + swap 1 + cut [ break ] glue ] if ] if ] change-frame ; @@ -110,7 +106,6 @@ PRIVATE> : continuation-step-out ( continuation -- continuation' ) [ nip \ break suffix ] change-frame ; - { { call [ (step-into-quot) ] } { dip [ (step-into-dip) ] } @@ -125,7 +120,7 @@ PRIVATE> ! Never step into these words : don't-step-into ( word -- ) - dup [ execute break ] curry "step-into" set-word-prop ; + dup '[ _ execute break ] "step-into" set-word-prop ; { >n ndrop >c c> @@ -152,6 +147,4 @@ PRIVATE> ] change-frame ; : continuation-current ( continuation -- obj ) - call>> - [ innermost-frame-scan 1+ ] - [ innermost-frame-quot ] bi ?nth ; + call>> >innermost-frame< ?nth ; diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index c5cd246f2e..6082933bcb 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -3,8 +3,7 @@ USING: words assocs definitions io io.pathnames io.styles kernel prettyprint sorting see sets sequences arrays hashtables help.crossref help.topics help.markup quotations accessors source-files namespaces -graphs vocabs generic generic.standard.engines.tuple threads -compiler.units init ; +graphs vocabs generic generic.single threads compiler.units init ; IN: tools.crossref SYMBOL: crossref @@ -82,7 +81,7 @@ M: object irrelevant? drop f ; M: default-method irrelevant? drop t ; -M: engine-word irrelevant? drop t ; +M: predicate-engine irrelevant? drop t ; PRIVATE> diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 6ca54ca36b..b74548a65f 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -3,12 +3,11 @@ USING: namespaces make continuations.private kernel.private init assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes -summary layouts vocabs.loader prettyprint.config prettyprint -debugger io.streams.c io.files io.files.temp io.pathnames -io.directories io.directories.hierarchy io.backend quotations -io.launcher words.private tools.deploy.config -tools.deploy.config.editor bootstrap.image io.encodings.utf8 -destructors accessors hashtables ; +summary layouts vocabs.loader prettyprint.config prettyprint debugger +io.streams.c io.files io.files.temp io.pathnames io.directories +io.directories.hierarchy io.backend quotations io.launcher +tools.deploy.config tools.deploy.config.editor bootstrap.image +io.encodings.utf8 destructors accessors hashtables ; IN: tools.deploy.backend : copy-vm ( executable bundle-name -- vm ) diff --git a/basis/tools/deploy/config/editor/editor.factor b/basis/tools/deploy/config/editor/editor.factor index ac89e3290b..78d86a4707 100644 --- a/basis/tools/deploy/config/editor/editor.factor +++ b/basis/tools/deploy/config/editor/editor.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs io.pathnames kernel parser prettyprint sequences -splitting tools.deploy.config tools.vocabs vocabs.loader ; +splitting tools.deploy.config vocabs.loader vocabs.metadata ; IN: tools.deploy.config.editor : deploy-config-path ( vocab -- string ) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e23e1b092d..816dbb7979 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors io.backend io.streams.c init fry namespaces make assocs kernel parser lexer strings.parser vocabs -sequences words words.private memory kernel.private +sequences words memory kernel.private continuations io vocabs.loader system strings sets vectors quotations byte-arrays sorting compiler.units definitions generic generic.standard tools.deploy.config ; @@ -23,7 +23,13 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show - { "cpu.x86" "command-line" "libc" "system" "environment" } + { + "command-line" + "cpu.x86" + "environment" + "libc" + "alien.strings" + } [ init-hooks get delete-at ] each deploy-threads? get [ "threads" init-hooks get delete-at @@ -36,8 +42,12 @@ IN: tools.deploy.shaker "io.backend" init-hooks get delete-at ] when strip-dictionary? [ - "compiler.units" init-hooks get delete-at - "tools.vocabs" init-hooks get delete-at + { + "compiler.units" + "vocabs" + "vocabs.cache" + "source-files.errors" + } [ init-hooks get delete-at ] each ] when ; : strip-debugger ( -- ) @@ -103,6 +113,7 @@ IN: tools.deploy.shaker "compiled-uses" "constraints" "custom-inlining" + "decision-tree" "declared-effect" "default" "default-method" @@ -112,14 +123,12 @@ IN: tools.deploy.shaker "engines" "forgotten" "identities" - "if-intrinsics" - "infer" "inline" "inlined-block" "input-classes" "instances" "interval" - "intrinsics" + "intrinsic" "lambda" "loc" "local-reader" @@ -136,7 +145,7 @@ IN: tools.deploy.shaker "method-generic" "modular-arithmetic" "no-compile" - "optimizer-hooks" + "owner-generic" "outputs" "participants" "predicate" @@ -149,17 +158,13 @@ IN: tools.deploy.shaker "register" "register-size" "shuffle" - "slot-names" "slots" "special" "specializer" - "step-into" - "step-into?" ! UI needs this ! "superclass" "transform-n" "transform-quot" - "tuple-dispatch-generic" "type" "writer" "writing" @@ -265,21 +270,20 @@ IN: tools.deploy.shaker compiler.errors:compiler-errors definition-observers interactive-vocabs - layouts:num-tags - layouts:num-types - layouts:tag-mask - layouts:tag-numbers - layouts:type-numbers lexer-factory print-use-hook root-cache source-files.errors:error-types + source-files.errors:error-observers vocabs:dictionary vocabs:load-vocab-hook + vocabs:vocab-observers word parser-notes } % + { } { "layouts" } strip-vocab-globals % + { } { "math.partial-dispatch" } strip-vocab-globals % { } { "peg" } strip-vocab-globals % @@ -351,13 +355,6 @@ IN: tools.deploy.shaker : compress-wrappers ( -- ) [ wrapper? ] [ ] "wrappers" compress ; -: finish-deploy ( final-image -- ) - "Finishing up" show - V{ } set-namestack - V{ } set-catchstack - "Saving final image" show - save-image-and-exit ; - SYMBOL: deploy-vocab : [:c] ( -- word ) ":c" "debugger" lookup ; @@ -442,7 +439,8 @@ SYMBOL: deploy-vocab "Vocabulary has no MAIN: word." print flush 1 exit ] unless strip - finish-deploy + "Saving final image" show + save-image-and-exit ] deploy-error-handler ] bind ; diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index eb780e40cc..f997a6eb3a 100644 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -16,4 +16,5 @@ IN: tools.deploy.test : run-temp-image ( -- ) vm "-i=" "test.image" temp-file append - 2array try-process ; \ No newline at end of file + 2array + swap >>command +closed+ >>stdin try-process ; \ No newline at end of file diff --git a/basis/tools/disassembler/disassembler-tests.factor b/basis/tools/disassembler/disassembler-tests.factor index 49cfb054a1..89ca265bf6 100644 --- a/basis/tools/disassembler/disassembler-tests.factor +++ b/basis/tools/disassembler/disassembler-tests.factor @@ -1,6 +1,4 @@ IN: tools.disassembler.tests -USING: math classes.tuple prettyprint.custom -tools.disassembler tools.test strings ; +USING: kernel fry vocabs tools.disassembler tools.test sequences ; -[ ] [ \ + disassemble ] unit-test -[ ] [ M\ string pprint* disassemble ] unit-test +"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each \ No newline at end of file diff --git a/basis/tools/disassembler/udis/udis-tests.factor b/basis/tools/disassembler/udis/udis-tests.factor new file mode 100644 index 0000000000..9ad3dbbcc2 --- /dev/null +++ b/basis/tools/disassembler/udis/udis-tests.factor @@ -0,0 +1,9 @@ +IN: tools.disassembler.udis.tests +USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ; + +{ + { [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } + { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] } + { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] } + [ ] +} cond \ No newline at end of file diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 51e399c1c3..df624cab28 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -3,7 +3,7 @@ USING: tools.disassembler namespaces combinators alien alien.syntax alien.c-types lexer parser kernel sequences layouts math math.order alien.libraries -math.parser system make fry arrays ; +math.parser system make fry arrays libc destructors ; IN: tools.disassembler.udis << @@ -16,7 +16,57 @@ IN: tools.disassembler.udis LIBRARY: libudis86 -TYPEDEF: char[592] ud +C-STRUCT: ud_operand + { "int" "type" } + { "uchar" "size" } + { "ulonglong" "lval" } + { "int" "base" } + { "int" "index" } + { "uchar" "offset" } + { "uchar" "scale" } ; + +C-STRUCT: ud + { "void*" "inp_hook" } + { "uchar" "inp_curr" } + { "uchar" "inp_fill" } + { "FILE*" "inp_file" } + { "uchar" "inp_ctr" } + { "uchar*" "inp_buff" } + { "uchar*" "inp_buff_end" } + { "uchar" "inp_end" } + { "void*" "translator" } + { "ulonglong" "insn_offset" } + { "char[32]" "insn_hexcode" } + { "char[64]" "insn_buffer" } + { "uint" "insn_fill" } + { "uchar" "dis_mode" } + { "ulonglong" "pc" } + { "uchar" "vendor" } + { "struct map_entry*" "mapen" } + { "int" "mnemonic" } + { "ud_operand[3]" "operand" } + { "uchar" "error" } + { "uchar" "pfx_rex" } + { "uchar" "pfx_seg" } + { "uchar" "pfx_opr" } + { "uchar" "pfx_adr" } + { "uchar" "pfx_lock" } + { "uchar" "pfx_rep" } + { "uchar" "pfx_repe" } + { "uchar" "pfx_repne" } + { "uchar" "pfx_insn" } + { "uchar" "default64" } + { "uchar" "opr_mode" } + { "uchar" "adr_mode" } + { "uchar" "br_far" } + { "uchar" "br_near" } + { "uchar" "implicit_addr" } + { "uchar" "c1" } + { "uchar" "c2" } + { "uchar" "c3" } + { "uchar[256]" "inp_cache" } + { "uchar[64]" "inp_sess" } + { "ud_itab_entry*" "itab_entry" } ; FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ; @@ -47,11 +97,14 @@ FUNCTION: uint ud_insn_len ( ud* u ) ; FUNCTION: char* ud_lookup_mnemonic ( int c ) ; : ( -- ud ) - "ud" + "ud" malloc-object &free dup ud_init dup cell-bits ud_set_mode dup UD_SYN_INTEL ud_set_syntax ; +: with-ud ( quot: ( ud -- ) -- ) + [ [ ] dip call ] with-destructors ; inline + SINGLETON: udis-disassembler : buf/len ( from to -- buf len ) [ drop ] [ swap - ] 2bi ; @@ -82,10 +135,12 @@ SINGLETON: udis-disassembler ] { } make ; M: udis-disassembler disassemble* ( from to -- buffer ) - [ ] 2dip { + '[ + _ _ [ drop ud_set_pc ] [ buf/len ud_set_input_buffer ] [ 2drop (disassemble) format-disassembly ] - } 3cleave ; + 3tri + ] with-ud ; udis-disassembler disassembler-backend set-global diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index f35da24266..5c8b868483 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -6,7 +6,7 @@ vocabs.loader io combinators calendar accessors math.parser io.streams.string ui.tools.operations quotations strings arrays prettyprint words vocabs sorting sets classes math alien urls splitting ascii combinators.short-circuit alarms words.symbol -system ; +system summary ; IN: tools.scaffold SYMBOL: developer-name @@ -16,6 +16,10 @@ ERROR: not-a-vocab-root string ; ERROR: vocab-name-contains-separator path ; ERROR: vocab-name-contains-dot path ; ERROR: no-vocab vocab ; +ERROR: bad-developer-name name ; + +M: bad-developer-name summary + drop "Developer name must be a string." ; path scaffolding? [ - [ developer-name get ] dip utf8 set-file-contents + developer-name get [ + "authors.txt" vocab-root/vocab/file>path scaffolding? [ + developer-name get swap utf8 set-file-contents + ] [ + drop + ] if ] [ - drop + 2drop ] if ; : lookup-type ( string -- object/string ? ) @@ -298,9 +306,12 @@ SYMBOL: examples-flag "}" print ] with-variable ; +: touch. ( path -- ) + [ touch-file ] + [ "Click to edit: " write . ] bi ; + : scaffold-rc ( path -- ) - [ home ] dip append-path - [ touch-file ] [ "Click to edit: " write . ] bi ; + [ home ] dip append-path touch. ; : scaffold-factor-boot-rc ( -- ) os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; @@ -308,4 +319,7 @@ SYMBOL: examples-flag : scaffold-factor-rc ( -- ) os windows? "factor-rc" ".factor-rc" ? scaffold-rc ; -: scaffold-emacs ( -- ) ".emacs" scaffold-rc ; + +HOOK: scaffold-emacs os ( -- ) + +M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ; diff --git a/extra/crypto/timing/authors.txt b/basis/tools/scaffold/windows/authors.txt similarity index 100% rename from extra/crypto/timing/authors.txt rename to basis/tools/scaffold/windows/authors.txt diff --git a/basis/alien/strings/windows/tags.txt b/basis/tools/scaffold/windows/tags.txt similarity index 100% rename from basis/alien/strings/windows/tags.txt rename to basis/tools/scaffold/windows/tags.txt diff --git a/basis/tools/scaffold/windows/windows.factor b/basis/tools/scaffold/windows/windows.factor new file mode 100755 index 0000000000..fef6121717 --- /dev/null +++ b/basis/tools/scaffold/windows/windows.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: io.pathnames system tools.scaffold windows.shell32 ; +IN: tools.scaffold.windows + +M: windows scaffold-emacs ( -- ) + application-data ".emacs" append-path touch. ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index c0c2f1892d..3dc7b8740b 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -4,9 +4,9 @@ USING: accessors arrays assocs combinators compiler.units continuations debugger effects fry generalizations io io.files io.styles kernel lexer locals macros math.parser namespaces parser prettyprint quotations sequences source-files splitting -stack-checker summary unicode.case vectors vocabs vocabs.loader words -tools.vocabs tools.errors source-files.errors io.streams.string make -compiler.errors ; +stack-checker summary unicode.case vectors vocabs vocabs.loader +vocabs.files words tools.errors source-files.errors +io.streams.string make compiler.errors ; IN: tools.test TUPLE: test-failure < source-file-error continuation ; diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 0d1d9f6fa1..948c0d482d 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -1,24 +1,27 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.vectors memory io io.styles prettyprint -namespaces system sequences splitting grouping assocs strings ; +USING: kernel math memory io io.styles prettyprint +namespaces system sequences splitting grouping assocs strings +generic.single combinators ; IN: tools.time : benchmark ( quot -- runtime ) micros [ call micros ] dip - ; inline -: time. ( data -- ) - unclip - "==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl +: time. ( time -- ) + "== Running time ==" print nl 1000000 /f pprint " seconds" print ; + +: gc-stats. ( stats -- ) 5 cut* - "==== GARBAGE COLLECTION" print nl + "== Garbage collection ==" print nl + "Times are in microseconds." print nl [ 6 group { "GC count:" - "Cumulative GC time (us):" - "Longest GC pause (us):" - "Average GC pause (us):" + "Total GC time:" + "Longest GC pause:" + "Average GC pause:" "Objects copied:" "Bytes copied:" } prefix @@ -29,13 +32,43 @@ IN: tools.time [ nl { - "Total GC time (us):" + "Total GC time:" "Cards scanned:" "Decks scanned:" - "Card scan time (us):" + "Card scan time:" "Code heap literal scans:" } swap zip simple-table. ] bi* ; +: dispatch-stats. ( stats -- ) + "== Megamorphic caches ==" print nl + { "Hits" "Misses" } swap zip simple-table. ; + +: inline-cache-stats. ( stats -- ) + nl "== Polymorphic inline caches ==" print nl + 3 cut + [ + "Transitions:" print + { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip + simple-table. nl + ] [ + "Type check stubs:" print + { "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip + simple-table. + ] bi* ; + : time ( quot -- ) - gc-reset micros [ call gc-stats micros ] dip - prefix time. ; inline + gc-reset + reset-dispatch-stats + reset-inline-cache-stats + benchmark gc-stats dispatch-stats inline-cache-stats + H{ { table-gap { 20 20 } } } [ + [ + [ [ time. ] 3dip ] with-cell + [ ] with-cell + ] with-row + [ + [ [ gc-stats. ] 2dip ] with-cell + [ [ dispatch-stats. ] [ inline-cache-stats. ] bi* ] with-cell + ] with-row + ] tabular-output nl ; inline diff --git a/basis/tools/trace/trace-tests.factor b/basis/tools/trace/trace-tests.factor index 74f7c40943..06511c7ada 100644 --- a/basis/tools/trace/trace-tests.factor +++ b/basis/tools/trace/trace-tests.factor @@ -1,4 +1,30 @@ IN: tools.trace.tests -USING: tools.trace tools.test sequences ; +USING: tools.trace tools.test tools.continuations kernel math combinators +sequences ; -[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test \ No newline at end of file +[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test + +GENERIC: method-breakpoint-test ( x -- y ) + +TUPLE: method-breakpoint-tuple ; + +M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ; + +\ method-breakpoint-test don't-step-into + +[ 3 ] +[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test + +: case-breakpoint-test ( -- x ) + 5 { [ break 1 + ] } case ; + +\ case-breakpoint-test don't-step-into + +[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test + +: call(-breakpoint-test ( -- x ) + [ break 1 ] call( -- x ) 2 + ; + +\ call(-breakpoint-test don't-step-into + +[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test diff --git a/basis/tools/trace/trace.factor b/basis/tools/trace/trace.factor index e2c6bf864b..f7f0ae4a69 100644 --- a/basis/tools/trace/trace.factor +++ b/basis/tools/trace/trace.factor @@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel sequences concurrency.messaging locals continuations threads namespaces namespaces.private make assocs accessors io strings prettyprint math math.parser words effects summary io.styles classes -generic.math combinators.short-circuit ; +generic.math combinators.short-circuit kernel.private quotations ; IN: tools.trace -: callstack-depth ( callstack -- n ) - callstack>array length 2/ ; - -SYMBOL: end - SYMBOL: exclude-vocabs SYMBOL: include-vocabs exclude-vocabs { "math" "accessors" } swap set-global +array length 2/ ; + +SYMBOL: end + : include? ( vocab -- ? ) include-vocabs get dup [ member? ] [ 2drop t ] if ; @@ -65,15 +67,20 @@ M: trace-step summary [ CHAR: \s write ] [ number>string write ": " write ] bi ; +: trace-into? ( continuation -- ? ) + continuation-current into? ; + : trace-step ( continuation -- continuation' ) - dup continuation-current end eq? [ - [ print-depth ] - [ print-step ] - [ - dup continuation-current into? - [ continuation-step-into ] [ continuation-step ] if - ] tri - ] unless ; + dup call>> innermost-frame-executing quotation? [ + dup continuation-current end eq? [ + [ print-depth ] + [ print-step ] + [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ] + tri + ] unless + ] when ; + +PRIVATE> : trace ( quot -- data ) [ [ trace-step ] break-hook ] dip diff --git a/basis/tools/vocabs/summary.txt b/basis/tools/vocabs/summary.txt deleted file mode 100644 index 1ae5f43784..0000000000 --- a/basis/tools/vocabs/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Reloading vocabularies and cross-referencing vocabularies diff --git a/basis/tools/vocabs/vocabs-docs.factor b/basis/tools/vocabs/vocabs-docs.factor deleted file mode 100644 index 33f197d0ea..0000000000 --- a/basis/tools/vocabs/vocabs-docs.factor +++ /dev/null @@ -1,75 +0,0 @@ -USING: help.markup help.syntax strings ; -IN: tools.vocabs - -ARTICLE: "tools.vocabs" "Vocabulary tools" -"Reloading source files changed on disk:" -{ $subsection refresh } -{ $subsection refresh-all } -"Vocabulary summaries:" -{ $subsection vocab-summary } -{ $subsection set-vocab-summary } -"Vocabulary tags:" -{ $subsection vocab-tags } -{ $subsection set-vocab-tags } -{ $subsection add-vocab-tags } -"Getting and setting vocabulary meta-data:" -{ $subsection vocab-file-contents } -{ $subsection set-vocab-file-contents } -"Global meta-data:" -{ $subsection all-vocabs } -{ $subsection all-vocabs-seq } -{ $subsection all-tags } -{ $subsection all-authors } -"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" -{ $subsection reset-cache } ; - -ABOUT: "tools.vocabs" - -HELP: vocab-files -{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; - -HELP: vocab-tests -{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } -{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; - -HELP: source-modified? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ; - -HELP: refresh -{ $values { "prefix" string } } -{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; - -HELP: refresh-all -{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; - -{ refresh refresh-all } related-words - -HELP: vocab-file-contents -{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } -{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-file-contents -{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } -{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; - -HELP: vocab-summary -{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } -{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-summary -{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; - -HELP: vocab-tags -{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } -{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-tags -{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; - -HELP: all-vocabs -{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } -{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor deleted file mode 100644 index ba99a41eba..0000000000 --- a/basis/tools/vocabs/vocabs.factor +++ /dev/null @@ -1,289 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel io io.styles io.files io.files.info io.directories -io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences -namespaces make math.parser arrays hashtables assocs memoize -summary sorting splitting combinators source-files debugger -continuations compiler.errors init checksums checksums.crc32 -sets accessors generic definitions words ; -IN: tools.vocabs - -: vocab-tests-file ( vocab -- path ) - dup "-tests.factor" vocab-dir+ vocab-append-path dup - [ dup exists? [ drop f ] unless ] [ drop f ] if ; - -: vocab-tests-dir ( vocab -- paths ) - dup vocab-dir "tests" append-path vocab-append-path dup [ - dup exists? [ - dup directory-files [ ".factor" tail? ] filter - [ append-path ] with map - ] [ drop f ] if - ] [ drop f ] if ; - -: vocab-tests ( vocab -- tests ) - [ - [ vocab-tests-file [ , ] when* ] - [ vocab-tests-dir [ % ] when* ] bi - ] { } make ; - -: vocab-files ( vocab -- seq ) - [ - [ vocab-source-path [ , ] when* ] - [ vocab-docs-path [ , ] when* ] - [ vocab-tests % ] tri - ] { } make ; - -: vocab-heading. ( vocab -- ) - nl - "==== " write - [ vocab-name ] [ vocab write-object ] bi ":" print - nl ; - -: load-error. ( triple -- ) - [ first vocab-heading. ] [ second print-error ] bi ; - -: load-failures. ( failures -- ) - [ load-error. nl ] each ; - -SYMBOL: failures - -: require-all ( vocabs -- failures ) - [ - V{ } clone blacklist set - V{ } clone failures set - [ - [ require ] - [ swap vocab-name failures get set-at ] - recover - ] each - failures get - ] with-scope ; - -: source-modified? ( path -- ? ) - dup source-files get at [ - dup path>> - dup exists? [ - utf8 file-lines crc32 checksum-lines - swap checksum>> = not - ] [ - 2drop f - ] if - ] [ - exists? - ] ?if ; - -SYMBOL: changed-vocabs - -[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook - -: changed-vocab ( vocab -- ) - dup vocab changed-vocabs get and - [ dup changed-vocabs get set-at ] [ drop ] if ; - -: unchanged-vocab ( vocab -- ) - changed-vocabs get delete-at ; - -: unchanged-vocabs ( vocabs -- ) - [ unchanged-vocab ] each ; - -: changed-vocab? ( vocab -- ? ) - changed-vocabs get dup [ key? ] [ 2drop t ] if ; - -: filter-changed ( vocabs -- vocabs' ) - [ changed-vocab? ] filter ; - -SYMBOL: modified-sources -SYMBOL: modified-docs - -: (to-refresh) ( vocab variable loaded? path -- ) - dup [ - swap [ - pick changed-vocab? [ - source-modified? [ get push ] [ 2drop ] if - ] [ 3drop ] if - ] [ drop get push ] if - ] [ 2drop 2drop ] if ; - -: to-refresh ( prefix -- modified-sources modified-docs unchanged ) - [ - V{ } clone modified-sources set - V{ } clone modified-docs set - - child-vocabs [ - [ - [ - [ modified-sources ] - [ vocab source-loaded?>> ] - [ vocab-source-path ] - tri (to-refresh) - ] [ - [ modified-docs ] - [ vocab docs-loaded?>> ] - [ vocab-docs-path ] - tri (to-refresh) - ] bi - ] each - - modified-sources get - modified-docs get - ] - [ modified-docs get modified-sources get append diff ] bi - ] with-scope ; - -: do-refresh ( modified-sources modified-docs unchanged -- ) - unchanged-vocabs - [ - [ [ vocab f >>source-loaded? drop ] each ] - [ [ vocab f >>docs-loaded? drop ] each ] bi* - ] - [ - append prune - [ unchanged-vocabs ] - [ require-all load-failures. ] bi - ] 2bi ; - -: refresh ( prefix -- ) to-refresh do-refresh ; - -: refresh-all ( -- ) "" refresh ; - -MEMO: vocab-file-contents ( vocab name -- seq ) - vocab-append-path dup - [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ; - -: set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-append-path [ - utf8 set-file-lines - \ vocab-file-contents reset-memoized - ] [ - "The " swap vocab-name - " vocabulary was not loaded from the file system" - 3append throw - ] ?if ; - -: vocab-summary-path ( vocab -- string ) - vocab-dir "summary.txt" append-path ; - -: vocab-summary ( vocab -- summary ) - dup dup vocab-summary-path vocab-file-contents - [ - vocab-name " vocabulary" append - ] [ - nip first - ] if-empty ; - -M: vocab summary - [ - dup vocab-summary % - " (" % - words>> assoc-size # - " words)" % - ] "" make ; - -M: vocab-link summary vocab-summary ; - -: set-vocab-summary ( string vocab -- ) - [ 1array ] dip - dup vocab-summary-path - set-vocab-file-contents ; - -: vocab-tags-path ( vocab -- string ) - vocab-dir "tags.txt" append-path ; - -: vocab-tags ( vocab -- tags ) - dup vocab-tags-path vocab-file-contents harvest ; - -: set-vocab-tags ( tags vocab -- ) - dup vocab-tags-path set-vocab-file-contents ; - -: add-vocab-tags ( tags vocab -- ) - [ vocab-tags append prune ] keep set-vocab-tags ; - -: vocab-authors-path ( vocab -- string ) - vocab-dir "authors.txt" append-path ; - -: vocab-authors ( vocab -- authors ) - dup vocab-authors-path vocab-file-contents harvest ; - -: set-vocab-authors ( authors vocab -- ) - dup vocab-authors-path set-vocab-file-contents ; - -: subdirs ( dir -- dirs ) - [ - [ link-info directory? ] filter - ] with-directory-files natural-sort ; - -: (all-child-vocabs) ( root name -- vocabs ) - [ - vocab-dir append-path dup exists? - [ subdirs ] [ drop { } ] if - ] keep [ - swap [ "." glue ] with map - ] unless-empty ; - -: vocab-dir? ( root name -- ? ) - over - [ ".factor" vocab-dir+ append-path exists? ] - [ 2drop f ] - if ; - -: vocabs-in-dir ( root name -- ) - dupd (all-child-vocabs) [ - 2dup vocab-dir? [ dup >vocab-link , ] when - vocabs-in-dir - ] with each ; - -: all-vocabs ( -- assoc ) - vocab-roots get [ - dup [ "" vocabs-in-dir ] { } make - ] { } map>assoc ; - -MEMO: all-vocabs-seq ( -- seq ) - all-vocabs values concat ; - -: unportable? ( name -- ? ) - vocab-tags "unportable" swap member? ; - -: filter-unportable ( seq -- seq' ) - [ vocab-name unportable? not ] filter ; - -: try-everything ( -- failures ) - all-vocabs-seq - filter-unportable - require-all ; - -: load-everything ( -- ) - try-everything load-failures. ; - -: unrooted-child-vocabs ( prefix -- seq ) - dup empty? [ CHAR: . suffix ] unless - vocabs - [ find-vocab-root not ] filter - [ - vocab-name swap ?head CHAR: . rot member? not and - ] with filter - [ vocab ] map ; - -: all-child-vocabs ( prefix -- assoc ) - vocab-roots get [ - dup pick (all-child-vocabs) [ >vocab-link ] map - ] { } map>assoc - swap unrooted-child-vocabs f swap 2array suffix ; - -: all-child-vocabs-seq ( prefix -- assoc ) - vocab-roots get swap [ - dupd (all-child-vocabs) - [ vocab-dir? ] with filter - ] curry map concat ; - -MEMO: all-tags ( -- seq ) - all-vocabs-seq [ vocab-tags ] gather natural-sort ; - -MEMO: all-authors ( -- seq ) - all-vocabs-seq [ vocab-authors ] gather natural-sort ; - -: reset-cache ( -- ) - root-cache get-global clear-assoc - \ vocab-file-contents reset-memoized - \ all-vocabs-seq reset-memoized - \ all-authors reset-memoized - \ all-tags reset-memoized ; diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor index 6dabb73e30..b6094d7d7e 100644 --- a/basis/tools/walker/walker-tests.factor +++ b/basis/tools/walker/walker-tests.factor @@ -1,8 +1,8 @@ USING: tools.walker io io.streams.string kernel math math.private namespaces prettyprint sequences tools.test continuations math.parser threads arrays tools.walker.debug -generic.standard sequences.private kernel.private -tools.continuations accessors words ; +generic.single sequences.private kernel.private +tools.continuations accessors words combinators ; IN: tools.walker.tests [ { } ] [ @@ -118,7 +118,7 @@ IN: tools.walker.tests \ breakpoint-test don't-step-into -[ f ] [ \ breakpoint-test optimized>> ] unit-test +[ f ] [ \ breakpoint-test optimized? ] unit-test [ { 3 } ] [ [ breakpoint-test ] test-walker ] unit-test @@ -131,4 +131,18 @@ M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ; \ method-breakpoint-test don't-step-into [ { 3 } ] -[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test \ No newline at end of file +[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test + +: case-breakpoint-test ( -- x ) + 5 { [ break 1 + ] } case ; + +\ case-breakpoint-test don't-step-into + +[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test + +: call(-breakpoint-test ( -- x ) + [ break 1 ] call( -- x ) 2 + ; + +\ call(-breakpoint-test don't-step-into + +[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test diff --git a/basis/tuple-arrays/summary.txt b/basis/tuple-arrays/summary.txt new file mode 100755 index 0000000000..6f5c8b7244 --- /dev/null +++ b/basis/tuple-arrays/summary.txt @@ -0,0 +1 @@ +Efficient arrays of tuples with value semantics for elements diff --git a/basis/byte-vectors/tags.txt b/basis/tuple-arrays/tags.txt old mode 100644 new mode 100755 similarity index 100% rename from basis/byte-vectors/tags.txt rename to basis/tuple-arrays/tags.txt diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 4606ecdada..2eeae20aa1 100644 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -23,3 +23,10 @@ TUPLE-ARRAY: baz [ 0 ] [ 1 first bing>> ] unit-test [ f ] [ 1 first bong>> ] unit-test + +TUPLE: broken x ; +: broken ( -- ) ; + +TUPLE-ARRAY: broken + +[ 100 ] [ 100 length ] unit-test \ No newline at end of file diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 466262f3e0..35d771416c 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -1,26 +1,36 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators.smart fry functors grouping -kernel macros sequences sequences.private stack-checker -parser ; +USING: accessors arrays combinators.smart fry functors kernel +kernel.private macros sequences combinators sequences.private +stack-checker parser math classes.tuple.private ; FROM: inverse => undo ; IN: tuple-arrays ] ; + MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; +: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline + : smart-tuple>array ( tuple class -- array ) '[ [ _ boa ] undo ] output>array ; inline -: smart-array>tuple ( array class -- tuple ) - '[ _ boa ] inputarray ] bi ; inline +: tuple-slice ( n seq -- slice ) + [ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline + +: read-tuple ( slice class -- tuple ) + '[ _ boa-unsafe ] input [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] + bi '[ _ dip @ ] ; + PRIVATE> FUNCTOR: define-tuple-array ( CLASS -- ) @@ -35,31 +45,26 @@ CLASS-array? IS ${CLASS-array}? WHERE -TUPLE: CLASS-array { seq sliced-groups read-only } ; +TUPLE: CLASS-array +{ seq array read-only } +{ n array-capacity read-only } +{ length array-capacity read-only } ; : ( length -- tuple-array ) - CLASS tuple-prototype concat - CLASS tuple-arity - CLASS-array boa ; + [ \ CLASS [ tuple-prototype concat ] [ tuple-arity ] bi ] keep + \ CLASS-array boa ; inline -M: CLASS-array nth-unsafe - seq>> nth-unsafe CLASS smart-array>tuple ; +M: CLASS-array length length>> ; -M: CLASS-array set-nth-unsafe - [ CLASS smart-tuple>array ] 2dip seq>> set-nth-unsafe ; +M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; -M: CLASS-array new-sequence - drop ; +M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; -: >CLASS-array ( seq -- tuple-array ) - dup empty? [ - 0 clone-like - ] unless ; +M: CLASS-array new-sequence drop ; -M: CLASS-array like - drop dup CLASS-array? [ >CLASS-array ] unless ; +: >CLASS-array ( seq -- tuple-array ) 0 clone-like ; -M: CLASS-array length seq>> length ; +M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; INSTANCE: CLASS-array sequence diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 9c844d3663..63d551798c 100755 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -31,4 +31,8 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h ) '[ select-gl-context @ ] [ flush-gl-context gl-error ] bi ; inline -HOOK: (with-ui) ui-backend ( quot -- ) \ No newline at end of file +HOOK: (with-ui) ui-backend ( quot -- ) + +HOOK: (grab-input) ui-backend ( handle -- ) + +HOOK: (ungrab-input) ui-backend ( handle -- ) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 362305c8f7..47a3bfc1a6 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -1,14 +1,16 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors math arrays assocs cocoa cocoa.application -command-line kernel memory namespaces cocoa.messages -cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types -cocoa.windows cocoa.classes cocoa.nibs sequences ui ui.private -ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds -ui.backend.cocoa.views core-foundation core-foundation.run-loop -core-graphics.types threads math.rectangles fry libc -generalizations alien.c-types cocoa.views -combinators io.thread locals ; +USING: accessors alien.c-types arrays assocs classes cocoa +cocoa.application cocoa.classes cocoa.messages cocoa.nibs +cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types +cocoa.views cocoa.windows combinators command-line +core-foundation core-foundation.run-loop core-graphics +core-graphics.types destructors fry generalizations io.thread +kernel libc literals locals math math.rectangles memory +namespaces sequences specialized-arrays.int threads ui +ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets +ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private +ui.private words.symbol ; IN: ui.backend.cocoa TUPLE: handle ; @@ -20,6 +22,42 @@ C: offscreen-handle SINGLETON: cocoa-ui-backend +PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{ + { double-buffered { $ NSOpenGLPFADoubleBuffer } } + { stereo { $ NSOpenGLPFAStereo } } + { offscreen { $ NSOpenGLPFAOffScreen } } + { fullscreen { $ NSOpenGLPFAFullScreen } } + { windowed { $ NSOpenGLPFAWindow } } + { accelerated { $ NSOpenGLPFAAccelerated } } + { software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } } + { backing-store { $ NSOpenGLPFABackingStore } } + { multisampled { $ NSOpenGLPFAMultisample } } + { supersampled { $ NSOpenGLPFASupersample } } + { sample-alpha { $ NSOpenGLPFASampleAlpha } } + { color-float { $ NSOpenGLPFAColorFloat } } + { color-bits { $ NSOpenGLPFAColorSize } } + { alpha-bits { $ NSOpenGLPFAAlphaSize } } + { accum-bits { $ NSOpenGLPFAAccumSize } } + { depth-bits { $ NSOpenGLPFADepthSize } } + { stencil-bits { $ NSOpenGLPFAStencilSize } } + { aux-buffers { $ NSOpenGLPFAAuxBuffers } } + { sample-buffers { $ NSOpenGLPFASampleBuffers } } + { samples { $ NSOpenGLPFASamples } } +} + +M: cocoa-ui-backend (make-pixel-format) + nip >NSOpenGLPFA-int-array + NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ; + +M: cocoa-ui-backend (free-pixel-format) + handle>> -> release ; + +M: cocoa-ui-backend (pixel-format-attribute) + [ handle>> ] [ >NSOpenGLPFA ] bi* + [ drop f ] + [ first 0 [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ] + if-empty ; + TUPLE: pasteboard handle ; C: pasteboard @@ -70,7 +108,8 @@ M: cocoa-ui-backend fullscreen* ( world -- ? ) handle>> view>> -> isInFullScreenMode zero? not ; M:: cocoa-ui-backend (open-window) ( world -- ) - world dim>> :> view + world [ [ dim>> ] dip ] + with-world-pixel-format :> view view world world>NSRect :> window view -> release world view register-window @@ -83,6 +122,17 @@ M:: cocoa-ui-backend (open-window) ( world -- ) M: cocoa-ui-backend (close-window) ( handle -- ) window>> -> release ; +M: cocoa-ui-backend (grab-input) ( handle -- ) + 0 CGAssociateMouseAndMouseCursorPosition drop + CGMainDisplayID CGDisplayHideCursor drop + window>> -> frame CGRect>rect rect-center + first2 CGWarpMouseCursorPosition drop ; + +M: cocoa-ui-backend (ungrab-input) ( handle -- ) + drop + CGMainDisplayID CGDisplayShowCursor drop + 1 CGAssociateMouseAndMouseCursorPosition drop ; + M: cocoa-ui-backend close-window ( gadget -- ) find-world [ handle>> [ @@ -97,18 +147,19 @@ M: cocoa-ui-backend raise-window* ( world -- ) ] when* ; : pixel-size ( pixel-format -- size ) - 0 [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ] - keep *int -3 shift ; + color-bits pixel-format-attribute -3 shift ; : offscreen-buffer ( world pixel-format -- alien w h pitch ) [ dim>> first2 ] [ pixel-size ] bi* { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ; -: gadget-offscreen-context ( world -- context buffer ) - NSOpenGLPFAOffScreen 1array - [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ] - [ offscreen-buffer ] 2bi - 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ; +:: gadget-offscreen-context ( world -- context buffer ) + world [ + nip :> pf + NSOpenGLContext -> alloc pf handle>> f -> initWithFormat:shareContext: + dup world pf offscreen-buffer + 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip + ] with-world-pixel-format ; M: cocoa-ui-backend (open-offscreen-buffer) ( world -- ) dup gadget-offscreen-context >>handle drop ; diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor index eb8823b107..cf5493f33d 100644 --- a/basis/ui/backend/cocoa/tools/tools.factor +++ b/basis/ui/backend/cocoa/tools/tools.factor @@ -4,7 +4,8 @@ USING: alien.syntax cocoa cocoa.nibs cocoa.application cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing core-foundation core-foundation.strings help.topics kernel memory namespaces parser system ui ui.tools.browser -ui.tools.listener ui.backend.cocoa eval locals tools.vocabs ; +ui.tools.listener ui.backend.cocoa eval locals +vocabs.refresh ; IN: ui.backend.cocoa.tools : finder-run-files ( alien -- ) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 602c9bec73..aab851c783 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -9,7 +9,7 @@ threads combinators math.rectangles ; IN: ui.backend.cocoa.views : send-mouse-moved ( view event -- ) - [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ; + [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ; : button ( event -- n ) #! Cocoa -> Factor UI button mapping @@ -365,8 +365,8 @@ CLASS: { -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 CGLSetParameter drop ; -: ( dim -- view ) - FactorView swap [ sync-refresh-to-screen ] keep ; +: ( dim pixel-format -- view ) + [ FactorView ] 2dip [ sync-refresh-to-screen ] keep ; : save-position ( world window -- ) -> frame CGRect-top-left 2array >>window-loc drop ; diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index e405efb540..ba4926d97e 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -6,15 +6,169 @@ ui.gadgets ui.gadgets.private ui.backend ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io kernel math math.vectors namespaces make sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 -windows.messages windows.types windows.offscreen windows.nt windows +windows.messages windows.types windows.offscreen windows.nt threads libc combinators fry combinators.short-circuit continuations command-line shuffle opengl ui.render ascii math.bitwise locals accessors math.rectangles math.order ascii calendar -io.encodings.utf16n ; +io.encodings.utf16n windows.errors literals ui.pixel-formats +ui.pixel-formats.private memoize classes struct-arrays ; IN: ui.backend.windows SINGLETON: windows-ui-backend +TUPLE: win-base hDC hRC ; +TUPLE: win < win-base hWnd world title ; +TUPLE: win-offscreen < win-base hBitmap bits ; +C: win +C: win-offscreen + +> hDC>> (has-wglChoosePixelFormatARB?) ; + +: arb-make-pixel-format ( world attributes -- pf ) + [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 0 + [ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ; + +: arb-pixel-format-attribute ( pixel-format attribute -- value ) + >WGL_ARB + [ drop f ] [ + [ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip + first 0 + [ wglGetPixelFormatAttribivARB win32-error=0/f ] + keep *int + ] if-empty ; + +CONSTANT: pfd-flag-map H{ + { double-buffered $ PFD_DOUBLEBUFFER } + { stereo $ PFD_STEREO } + { offscreen $ PFD_DRAW_TO_BITMAP } + { fullscreen $ PFD_DRAW_TO_WINDOW } + { windowed $ PFD_DRAW_TO_WINDOW } + { backing-store $ PFD_SWAP_COPY } + { software-rendered $ PFD_GENERIC_FORMAT } +} + +: >pfd-flag ( attribute -- value ) + pfd-flag-map at [ ] [ 0 ] if* ; + +: >pfd-flags ( attributes -- flags ) + [ >pfd-flag ] [ bitor ] map-reduce + PFD_SUPPORT_OPENGL bitor ; + +: attr-value ( attributes name -- value ) + [ instance? ] curry find nip + [ value>> ] [ 0 ] if* ; + +: >pfd ( attributes -- pfd ) + "PIXELFORMATDESCRIPTOR" + "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize + 1 over set-PIXELFORMATDESCRIPTOR-nVersion + over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags + PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType + over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits + over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits + over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits + over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits + over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits + over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits + over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits + over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits + over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits + over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits + over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits + over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits + over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers + PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask + nip ; + +: pfd-make-pixel-format ( world attributes -- pf ) + [ handle>> hDC>> ] [ >pfd ] bi* + ChoosePixelFormat dup win32-error=0/f ; + +: get-pfd ( pixel-format -- pfd ) + [ world>> handle>> hDC>> ] [ handle>> ] bi + "PIXELFORMATDESCRIPTOR" heap-size + "PIXELFORMATDESCRIPTOR" + [ DescribePixelFormat win32-error=0/f ] keep ; + +: pfd-flag? ( pfd flag -- ? ) + [ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ; + +: (pfd-pixel-format-attribute) ( pfd attribute -- value ) + { + { double-buffered [ PFD_DOUBLEBUFFER pfd-flag? ] } + { stereo [ PFD_STEREO pfd-flag? ] } + { offscreen [ PFD_DRAW_TO_BITMAP pfd-flag? ] } + { fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] } + { windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] } + { software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] } + { color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] } + { red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] } + { green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] } + { blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] } + { alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] } + { accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] } + { accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] } + { accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] } + { accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] } + { accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] } + { depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] } + { stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] } + { aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] } + [ 2drop f ] + } case ; + +: pfd-pixel-format-attribute ( pixel-format attribute -- value ) + [ get-pfd ] dip (pfd-pixel-format-attribute) ; + +M: windows-ui-backend (make-pixel-format) + over has-wglChoosePixelFormatARB? + [ arb-make-pixel-format ] [ pfd-make-pixel-format ] if ; + +M: windows-ui-backend (free-pixel-format) + drop ; + +M: windows-ui-backend (pixel-format-attribute) + over world>> has-wglChoosePixelFormatARB? + [ arb-pixel-format-attribute ] [ pfd-pixel-format-attribute ] if ; + +PRIVATE> + +: lo-word ( wparam -- lo ) *short ; inline +: hi-word ( wparam -- hi ) -16 shift lo-word ; inline +: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ; + : crlf>lf ( str -- str' ) CHAR: \r swap remove ; @@ -69,12 +223,6 @@ M: pasteboard set-clipboard-contents drop copy ; clipboard set-global selection set-global ; -TUPLE: win-base hDC hRC ; -TUPLE: win < win-base hWnd world title ; -TUPLE: win-offscreen < win-base hBitmap bits ; -C: win -C: win-offscreen - SYMBOLS: msg-obj class-name-ptr mouse-captured ; : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline @@ -286,8 +434,6 @@ SYMBOL: nc-buttons message>button nc-buttons get swap [ push ] [ delete ] if ; -: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ; - : mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ; : mouse-event>gesture ( uMsg -- button ) @@ -475,25 +621,24 @@ M: windows-ui-backend do-events f class-name-ptr set-global f msg-obj set-global ; -: setup-pixel-format ( hdc flags -- ) - 32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep - swapd SetPixelFormat win32-error=0/f ; +: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ; -: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ; +: get-rc ( world -- ) + handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f + [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ; -: get-rc ( hDC -- hRC ) - dup wglCreateContext dup win32-error=0/f - [ wglMakeCurrent win32-error=0/f ] keep ; +: set-pixel-format ( pixel-format hdc -- ) + swap handle>> "PIXELFORMATDESCRIPTOR" SetPixelFormat win32-error=0/f ; -: setup-gl ( hwnd -- hDC hRC ) - get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ; +: setup-gl ( world -- ) + [ get-dc ] keep + [ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ] + with-world-pixel-format ; M: windows-ui-backend (open-window) ( world -- ) - [ create-window [ setup-gl ] keep ] keep - [ f ] keep - [ swap hWnd>> register-window ] 2keep - dupd (>>handle) - hWnd>> show-window ; + [ dup create-window [ f f ] dip f f >>handle setup-gl ] + [ dup handle>> hWnd>> register-window ] + [ handle>> hWnd>> show-window ] tri ; M: win-base select-gl-context ( handle -- ) [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f @@ -502,15 +647,15 @@ M: win-base select-gl-context ( handle -- ) M: win-base flush-gl-context ( handle -- ) hDC>> SwapBuffers win32-error=0/f ; -: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits ) - make-offscreen-dc-and-bitmap [ - [ dup offscreen-pfd-dwFlags setup-pixel-format ] - [ get-rc ] bi - ] 2dip ; +: setup-offscreen-gl ( world -- ) + dup [ handle>> ] [ dim>> ] bi make-offscreen-dc-and-bitmap + [ >>hDC ] [ >>hBitmap ] [ >>bits ] tri* drop [ + swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi + ] with-world-pixel-format ; M: windows-ui-backend (open-offscreen-buffer) ( world -- ) - dup dim>> setup-offscreen-gl - >>handle drop ; + win-offscreen new >>handle + setup-offscreen-gl ; M: windows-ui-backend (close-offscreen-buffer) ( handle -- ) [ hDC>> DeleteDC drop ] @@ -553,6 +698,68 @@ M: windows-ui-backend (with-ui) M: windows-ui-backend beep ( -- ) 0 MessageBeep drop ; +: fullscreen-RECT ( hwnd -- RECT ) + MONITOR_DEFAULTTONEAREST MonitorFromWindow + "MONITORINFOEX" dup length over set-MONITORINFOEX-cbSize + [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ; + +: client-area>RECT ( hwnd -- RECT ) + "RECT" + [ GetClientRect win32-error=0/f ] + [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ] + [ nip ] 2tri ; + +: hwnd>RECT ( hwnd -- RECT ) + "RECT" [ GetWindowRect win32-error=0/f ] keep ; + +M: windows-ui-backend (grab-input) ( handle -- ) + 0 ShowCursor drop + hWnd>> client-area>RECT ClipCursor drop ; +M: windows-ui-backend (ungrab-input) ( handle -- ) + drop + f ClipCursor drop + 1 ShowCursor drop ; + +: fullscreen-flags ( -- n ) + { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline + +: enter-fullscreen ( world -- ) + handle>> hWnd>> + { + [ + GWL_STYLE GetWindowLong + fullscreen-flags unmask + ] + [ GWL_STYLE rot SetWindowLong win32-error=0/f ] + [ + HWND_TOP + over hwnd>RECT get-RECT-dimensions + SWP_FRAMECHANGED + SetWindowPos win32-error=0/f + ] + [ SW_MAXIMIZE ShowWindow win32-error=0/f ] + } cleave ; + +: exit-fullscreen ( world -- ) + handle>> hWnd>> + { + [ + GWL_STYLE GetWindowLong + fullscreen-flags bitor + ] + [ GWL_STYLE rot SetWindowLong win32-error=0/f ] + [ + f + over hwnd>RECT get-RECT-dimensions + { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags + SetWindowPos win32-error=0/f + ] + [ SW_RESTORE ShowWindow win32-error=0/f ] + } cleave ; + +M: windows-ui-backend set-fullscreen* ( ? world -- ) + swap [ enter-fullscreen ] [ exit-fullscreen ] if ; + windows-ui-backend ui-backend set-global [ "ui.tools" ] main-vocab-hook set-global diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index fb78abe917..76fd9fa30c 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -7,7 +7,8 @@ namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows x11.io io.encodings.string io.encodings.ascii io.encodings.utf8 combinators command-line math.vectors classes.tuple opengl.gl threads -math.rectangles environment ascii ; +math.rectangles environment ascii literals +ui.pixel-formats ui.pixel-formats.private ; IN: ui.backend.x11 SINGLETON: x11-ui-backend @@ -29,6 +30,40 @@ M: world configure-event ! In case dimensions didn't change relayout-1 ; +PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{ + { double-buffered { $ GLX_DOUBLEBUFFER } } + { stereo { $ GLX_STEREO } } + { color-bits { $ GLX_BUFFER_SIZE } } + { red-bits { $ GLX_RED_SIZE } } + { green-bits { $ GLX_GREEN_SIZE } } + { blue-bits { $ GLX_BLUE_SIZE } } + { alpha-bits { $ GLX_ALPHA_SIZE } } + { accum-red-bits { $ GLX_ACCUM_RED_SIZE } } + { accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } } + { accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } } + { accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } } + { depth-bits { $ GLX_DEPTH_SIZE } } + { stencil-bits { $ GLX_STENCIL_SIZE } } + { aux-buffers { $ GLX_AUX_BUFFERS } } + { sample-buffers { $ GLX_SAMPLE_BUFFERS } } + { samples { $ GLX_SAMPLES } } +} + +M: x11-ui-backend (make-pixel-format) + [ drop dpy get scr get ] dip + >glx-visual-int-array glXChooseVisual ; + +M: x11-ui-backend (free-pixel-format) + handle>> XFree ; + +M: x11-ui-backend (pixel-format-attribute) + [ dpy get ] 2dip + [ handle>> ] [ >glx-visual ] bi* + [ 2drop f ] [ + first + 0 [ glXGetConfig drop ] keep *int + ] if-empty ; + CONSTANT: modifiers { { S+ HEX: 1 } @@ -187,7 +222,8 @@ M: world client-event : gadget-window ( world -- ) dup - [ window-loc>> ] [ dim>> ] bi glx-window swap + [ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ] + with-world-pixel-format swap dup "Factor" create-xic [ window>> register-window ] [ >>handle drop ] 2bi ; @@ -274,7 +310,9 @@ M: x11-pixmap-handle flush-gl-context ( handle -- ) drop ; M: x11-ui-backend (open-offscreen-buffer) ( world -- ) - dup dim>> glx-pixmap >>handle drop ; + dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] + with-world-pixel-format + >>handle drop ; M: x11-ui-backend (close-offscreen-buffer) ( handle -- ) dpy get swap [ glx-pixmap>> glXDestroyGLXPixmap ] diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 32d6c0c8a6..5dd1710cdd 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -393,3 +393,7 @@ M: f request-focus-on 2drop ; : focus-path ( gadget -- seq ) [ focus>> ] follow ; + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when \ No newline at end of file diff --git a/basis/ui/gadgets/glass/glass-tests.factor b/basis/ui/gadgets/glass/glass-tests.factor index d4e4306656..e95803d336 100644 --- a/basis/ui/gadgets/glass/glass-tests.factor +++ b/basis/ui/gadgets/glass/glass-tests.factor @@ -1,10 +1,14 @@ IN: ui.gadgets.glass.tests USING: tools.test ui.gadgets.glass ui.gadgets.worlds ui.gadgets -math.rectangles namespaces accessors models sequences ; +math.rectangles namespaces accessors models sequences arrays ; - "" f -{ 1000 1000 } >>dim -"w" set +[ ] [ + + 1array >>gadgets + + { 1000 1000 } >>dim + "w" set +] unit-test [ ] [ "g" set ] unit-test diff --git a/basis/ui/gadgets/prettyprint/authors.txt b/basis/ui/gadgets/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/gadgets/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/gadgets/prettyprint/prettyprint.factor b/basis/ui/gadgets/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..82a89eda11 --- /dev/null +++ b/basis/ui/gadgets/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ui.gadgets prettyprint.backend prettyprint.custom ; +IN: ui.gadgets.prettyprint + +! Don't print gadgets with RECT: syntax +M: gadget pprint* pprint-tuple ; \ No newline at end of file diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 6cfb83a49a..80829d7b66 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -53,8 +53,8 @@ CONSTANT: min-thumb-dim 30 [ slider-max* 1 max ] bi / ; -: slider>screen ( m slider -- n ) slider-scale * elevator-padding + ; -: screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ; +: slider>screen ( m slider -- n ) slider-scale * ; +: screen>slider ( m slider -- n ) slider-scale / ; M: slider model-changed nip elevator>> relayout-1 ; @@ -133,7 +133,7 @@ elevator H{ swap >>orientation ; : thumb-loc ( slider -- loc ) - [ slider-value ] keep slider>screen ; + [ slider-value ] keep slider>screen elevator-padding + ; : layout-thumb-loc ( thumb slider -- ) [ thumb-loc ] [ orientation>> ] bi n*v diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor index 57c69c2a66..7a68310e36 100644 --- a/basis/ui/gadgets/status-bar/status-bar-docs.factor +++ b/basis/ui/gadgets/status-bar/status-bar-docs.factor @@ -18,7 +18,7 @@ HELP: { $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ; HELP: open-status-window -{ $values { "gadget" gadget } { "title" string } } +{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } } { $description "Like " { $link open-window } ", with the additional feature that the new window iwll have a status bar displaying the value stored in the world's " { $slot "status" } " slot." } { $see-also show-status hide-status } ; @@ -30,4 +30,4 @@ ARTICLE: "ui.gadgets.status-bar" "Status bars and mouse-over help" { $subsection hide-status } { $link "ui.gadgets.presentations" } " use the status bar to display object summary." ; -ABOUT: "ui.gadgets.status-bar" \ No newline at end of file +ABOUT: "ui.gadgets.status-bar" diff --git a/basis/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor index a1c2dca23d..0d3015508e 100644 --- a/basis/ui/gadgets/status-bar/status-bar.factor +++ b/basis/ui/gadgets/status-bar/status-bar.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors models models.delay models.arrow sequences ui.gadgets.labels ui.gadgets.tracks -ui.gadgets.worlds ui.gadgets ui kernel calendar summary ; +ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ; IN: ui.gadgets.status-bar : ( model -- gadget ) @@ -10,9 +10,9 @@ IN: ui.gadgets.status-bar reverse-video-theme t >>root? ; -: open-status-window ( gadget title -- ) - f [ ] keep - f track-add +: open-status-window ( gadget title/attributes -- ) + ?attributes f >>status + dup status>> f track-add open-world-window ; : show-summary ( object gadget -- ) diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index d390b1e49b..ba3b5a2f78 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -46,14 +46,16 @@ mouse-index { takes-focus? initial: t } focused? ; -: ( rows renderer -- table ) - table new-line-gadget +: new-table ( rows renderer class -- table ) + new-line-gadget swap >>renderer swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; + transparent >>column-line-color ; inline + +:
( rows renderer -- table ) table new-table ; -{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } } -{ $description "Creates a new " { $link world } " delegating to the given gadget." } ; +{ $values { "world-attributes" world-attributes } { "world" "a new " { $link world } } } +{ $description "Creates a new " { $link world } " or world subclass with the given attributes." } ; HELP: find-world { $values { "gadget" gadget } { "world/f" { $maybe world } } } @@ -65,6 +65,30 @@ HELP: find-gl-context { $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." } { $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ; +HELP: begin-world +{ $values { "world" world } } +{ $description "Called immediately after " { $snippet "world" } "'s OpenGL context has been created. The world's OpenGL context is current when this method is called." } ; + +HELP: end-world +{ $values { "world" world } } +{ $description "Called immediately before " { $snippet "world" } "'s OpenGL context is destroyed. The world's OpenGL context is current when this method is called." } ; + +HELP: resize-world +{ $values { "world" world } } +{ $description "Called when the window containing " { $snippet "world" } " is resized. The " { $snippet "loc" } " and " { $snippet "dim" } " slots of " { $snippet "world" } " will be updated with the world's new position and size. The world's OpenGL context is current when this method is called." } ; + +HELP: draw-world* +{ $values { "world" world } } +{ $description "Called when " { $snippet "world" } " needs to be redrawn. The world's OpenGL context is current when this method is called." } ; + +ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds" +"The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:" +{ $subsection begin-world } +{ $subsection end-world } +{ $subsection resize-world } +{ $subsection draw-world* } +"See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ; + ARTICLE: "ui-paint-custom" "Implementing custom drawing logic" "The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:" { $subsection draw-gadget* } @@ -72,7 +96,8 @@ ARTICLE: "ui-paint-custom" "Implementing custom drawing logic" $nl "Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:" { $subsection find-gl-context } -"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa." +"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "." { $subsection "ui-paint-coord" } +{ $subsection "ui.gadgets.worlds-subclassing" } { $subsection "gl-utilities" } { $subsection "text-rendering" } ; diff --git a/basis/ui/gadgets/worlds/worlds-tests.factor b/basis/ui/gadgets/worlds/worlds-tests.factor index f738a8cff4..515a0b3aa8 100644 --- a/basis/ui/gadgets/worlds/worlds-tests.factor +++ b/basis/ui/gadgets/worlds/worlds-tests.factor @@ -1,12 +1,12 @@ USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test -namespaces models kernel accessors ; +namespaces models kernel accessors arrays ; IN: ui.gadgets.worlds.tests ! Test focus behavior "g1" set : ( gadget -- world ) - "Hi" f ; + "Hi" >>title swap 1array >>gadgets ; [ ] [ "g1" get "w" set diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor old mode 100644 new mode 100755 index a186de7670..eec5666f0e --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,15 +4,30 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.commands ; +ui.commands ui.pixel-formats destructors literals ; IN: ui.gadgets.worlds +CONSTANT: default-world-pixel-format-attributes + { windowed double-buffered T{ depth-bits { value 16 } } } + TUPLE: world < track -active? focused? -layers -title status status-owner -text-handle handle images -window-loc ; + active? focused? grab-input? + layers + title status status-owner + text-handle handle images + window-loc + pixel-format-attributes ; + +TUPLE: world-attributes + { world-class initial: world } + grab-input? + title + status + gadgets + { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; + +: ( -- world-attributes ) + world-attributes new ; inline : find-world ( gadget -- world/f ) [ world? ] find-parent ; @@ -45,18 +60,25 @@ M: world request-focus-on ( child gadget -- ) 2dup eq? [ 2drop ] [ dup focused?>> (request-focus) ] if ; -: new-world ( gadget title status class -- world ) +: new-world ( class -- world ) vertical swap new-track t >>root? t >>active? { 0 0 } >>window-loc - swap >>status - swap >>title - swap 1 track-add - dup request-focus ; + f >>grab-input? ; -: ( gadget title status -- world ) - world new-world ; +: apply-world-attributes ( world attributes -- world ) + { + [ title>> >>title ] + [ status>> >>status ] + [ pixel-format-attributes>> >>pixel-format-attributes ] + [ grab-input?>> >>grab-input? ] + [ gadgets>> [ 1 track-add ] each ] + } cleave ; + +: ( world-attributes -- world ) + [ world-class>> new-world ] keep apply-world-attributes + dup request-focus ; : as-big-as-possible ( world gadget -- ) dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline @@ -77,17 +99,36 @@ SYMBOL: flush-layout-cache-hook flush-layout-cache-hook [ [ ] ] initialize -: (draw-world) ( world -- ) - dup handle>> [ - check-extensions - { - [ init-gl ] - [ draw-gadget ] - [ text-handle>> [ purge-cache ] when* ] - [ images>> [ purge-cache ] when* ] - } cleave - ] with-gl-context - flush-layout-cache-hook get call( -- ) ; +GENERIC: begin-world ( world -- ) +GENERIC: end-world ( world -- ) + +GENERIC: resize-world ( world -- ) + +M: world begin-world + drop ; +M: world end-world + drop ; +M: world resize-world + drop ; + +M: world (>>dim) + [ call-next-method ] + [ + dup handle>> + [ select-gl-context resize-world ] + [ drop ] if* + ] bi ; + +GENERIC: draw-world* ( world -- ) + +M: world draw-world* + check-extensions + { + [ init-gl ] + [ draw-gadget ] + [ text-handle>> [ purge-cache ] when* ] + [ images>> [ purge-cache ] when* ] + } cleave ; : draw-world? ( world -- ? ) #! We don't draw deactivated worlds, or those with 0 size. @@ -108,7 +149,10 @@ ui-error-hook [ [ rethrow ] ] initialize : draw-world ( world -- ) dup draw-world? [ dup world [ - [ (draw-world) ] [ + [ + dup handle>> [ draw-world* ] with-gl-context + flush-layout-cache-hook get call( -- ) + ] [ over ui-error f >>active? drop ] recover @@ -149,3 +193,14 @@ M: world handle-gesture ( gesture gadget -- ? ) : close-global ( world global -- ) [ get-global find-world eq? ] keep '[ f _ set-global ] when ; + +M: world world-pixel-format-attributes + pixel-format-attributes>> ; + +M: world check-world-pixel-format + 2drop ; + +: with-world-pixel-format ( world quot -- ) + [ dup dup world-pixel-format-attributes ] + dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline + diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index c7db0839d7..7e038ef2e0 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -310,16 +310,16 @@ HOOK: keysym>string os ( keysym -- string ) M: macosx keysym>string >upper ; -M: object keysym>string ; +M: object keysym>string dup length 1 = [ >lower ] when ; M: key-down gesture>string [ mods>> ] [ sym>> ] bi { { [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] } { [ dup " " = ] [ drop "SPACE" ] } - [ keysym>string ] + [ ] } cond - [ modifiers>string ] dip append ; + [ modifiers>string ] [ keysym>string ] bi* append ; M: button-up gesture>string [ diff --git a/extra/ui/offscreen/authors.txt b/basis/ui/pixel-formats/authors.txt similarity index 100% rename from extra/ui/offscreen/authors.txt rename to basis/ui/pixel-formats/authors.txt diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor new file mode 100644 index 0000000000..003b205c3d --- /dev/null +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -0,0 +1,198 @@ +USING: destructors help.markup help.syntax kernel math multiline sequences +vocabs vocabs.parser words ; +IN: ui.pixel-formats + +! break circular dependency +<< + "ui.gadgets.worlds" create-vocab drop + "world" "ui.gadgets.worlds" create drop + "ui.gadgets.worlds" (use+) +>> + +ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes" +"The following pixel format attributes can be requested and queried of " { $link pixel-format } "s. Binary attributes are represented by the presence of a symbol in an attribute sequence:" +{ $subsection double-buffered } +{ $subsection stereo } +{ $subsection offscreen } +{ $subsection fullscreen } +{ $subsection windowed } +{ $subsection accelerated } +{ $subsection software-rendered } +{ $subsection backing-store } +{ $subsection multisampled } +{ $subsection supersampled } +{ $subsection sample-alpha } +{ $subsection color-float } +"Integer attributes are represented by a " { $link tuple } " with a single " { $snippet "value" } "slot:" +{ $subsection color-bits } +{ $subsection red-bits } +{ $subsection green-bits } +{ $subsection blue-bits } +{ $subsection alpha-bits } +{ $subsection accum-bits } +{ $subsection accum-red-bits } +{ $subsection accum-green-bits } +{ $subsection accum-blue-bits } +{ $subsection accum-alpha-bits } +{ $subsection depth-bits } +{ $subsection stencil-bits } +{ $subsection aux-buffers } +{ $subsection sample-buffers } +{ $subsection samples } +{ $examples +"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:" +{ $code <" +USING: kernel ui.worlds ui.pixel-formats ; +IN: ui.pixel-formats.examples + +TUPLE: picky-depth-buffered-world < world ; + +M: picky-depth-buffered-world world-pixel-format-attributes + drop { + double-buffered + T{ color-bits { value 24 } } + T{ depth-bits { value 24 } } + } ; + +M: picky-depth-buffered-world check-world-pixel-format + nip + [ double-buffered pixel-format-attribute 0 = [ "Not double buffered!" throw ] when ] + [ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ] + [ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ] + tri ; +"> } } +; + +HELP: double-buffered +{ $class-description "Requests a double-buffered pixel format." } ; +HELP: stereo +{ $class-description "Requests a stereoscopic pixel format." } ; + +HELP: offscreen +{ $class-description "Requests a pixel format suitable for offscreen rendering." } ; +HELP: fullscreen +{ $class-description "Requests a pixel format suitable for fullscreen rendering." } +{ $notes "On some window systems this is not distinct from " { $link windowed } "." } ; +HELP: windowed +{ $class-description "Requests a pixel format suitable for rendering to a window." } ; + +{ offscreen fullscreen windowed } related-words + +HELP: accelerated +{ $class-description "Requests a pixel format supported by GPU hardware acceleration." } ; +HELP: software-rendered +{ $class-description "Requests a pixel format only supported by the window system's default software renderer." } ; + +{ accelerated software-rendered } related-words + +HELP: backing-store +{ $class-description "Used with " { $link double-buffered } " to request a double-buffered pixel format where the back buffer contents are preserved and copied to the front when buffers are swapped." } ; + +{ double-buffered backing-store } related-words + +HELP: multisampled +{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of multisampling." } +{ $notes "On some window systems this is not distinct from " { $link supersampled } "." } ; + +HELP: supersampled +{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of supersampling." } +{ $notes "On some window systems this is not distinct from " { $link multisampled } "." } ; + +HELP: sample-alpha +{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ; + +HELP: color-float +{ $class-description "Requests a pixel format where the color buffer is stored in floating-point format." } ; + +HELP: color-bits +{ $class-description "Requests a pixel format with a color buffer of at least " { $snippet "value" } " bits per pixel." } ; +HELP: red-bits +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " red bits per pixel." } ; +HELP: green-bits +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " green bits per pixel." } ; +HELP: blue-bits +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ; +HELP: alpha-bits +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " alpha bits per pixel." } ; + +{ color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words + +HELP: accum-bits +{ $class-description "Requests a pixel format with an accumulation buffer of at least " { $snippet "value" } " bits per pixel." } ; +HELP: accum-red-bits +{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " red bits per pixel." } ; +HELP: accum-green-bits +{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " green bits per pixel." } ; +HELP: accum-blue-bits +{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " blue bits per pixel." } ; +HELP: accum-alpha-bits +{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " alpha bits per pixel." } ; + +{ accum-bits accum-red-bits accum-green-bits accum-blue-bits accum-alpha-bits } related-words + +HELP: depth-bits +{ $class-description "Requests a pixel format with a depth buffer of at least " { $snippet "value" } " bits per pixel." } ; + +HELP: stencil-bits +{ $class-description "Requests a pixel format with a stencil buffer of at least " { $snippet "value" } " bits per pixel." } ; + +HELP: aux-buffers +{ $class-description "Requests a pixel format with at least " { $snippet "value" } " auxiliary buffers." } ; + +HELP: sample-buffers +{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request a pixel format with at least " { $snippet "value" } " sampling buffers." } ; + +HELP: samples +{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request at least " { $snippet "value" } " samples per pixel." } ; + +{ multisampled supersampled sample-alpha sample-buffers samples } related-words + +HELP: world-pixel-format-attributes +{ $values { "world" world } { "attributes" sequence } } +{ $description "Returns the set of " { $link "ui.pixel-formats-attributes" } " that " { $snippet "world" } " requests when grafted. This generic can be overridden by subclasses of " { $snippet "world" } "." } +{ $notes "The pixel format provided by the window system will not necessarily exactly match the requested attributes. To verify required pixel format attributes, override " { $link check-world-pixel-format } "." } ; + +HELP: check-world-pixel-format +{ $values { "world" world } { "pixel-format" pixel-format } } +{ $description "Verifies that " { $snippet "pixel-format" } " fulfills the requirements of " { $snippet "world" } ". The default method does nothing. Subclasses can override this generic to perform their own checks on the pixel format." } ; + +HELP: pixel-format +{ $class-description "The type of pixel format objects. The tuple slot contents should be considered opaque by user code. To check the value of a pixel format's attributes, use the " { $link pixel-format-attribute } " word. Pixel format objects must be freed using the " { $link dispose } " word when they are no longer needed." } ; + +HELP: +{ $values { "world" world } { "attributes" sequence } { "pixel-format" pixel-format } } +{ $description "Requests a pixel format suitable for " { $snippet "world" } " with a set of " { $link "ui.pixel-formats-attributes" } ". If no pixel format can be found that satisfies the given attributes, an " { $link invalid-pixel-format-attributes } " error is thrown. Pixel format attributes not supported by the window system are ignored. The returned " { $snippet "pixel-format" } " must be released using the " { $link dispose } " word when it is no longer needed." } +{ $notes "Pixel formats don't normally need to be directly allocated by user code. If you need to control the pixel format requested by a window, subclass " { $snippet "world" } " and override the " { $link world-pixel-format-attributes } " and " { $link check-world-pixel-format } " words." +$nl +"The returned pixel format does not necessarily exactly match the requested attributes; the window system will try to find the format that best matches the given attributes. Use " { $link pixel-format-attribute } " to check the actual values of the attributes on the returned pixel format." } +; + +HELP: pixel-format-attribute +{ $values { "pixel-format" pixel-format } { "attribute-name" "one of the " { $link "ui.pixel-formats-attributes" } } { "value" object } } +{ $description "Returns the value of the requested " { $snippet "attribute-name" } " in " { $snippet "pixel-format" } ". If " { "attribute-name" } " is unsupported by the window system, " { $link f } " is returned." } ; + +HELP: invalid-pixel-format-attributes +{ $values { "world" world } { "attributes" sequence } } +{ $class-description "Thrown by " { $link } " when the window system is unable to find a pixel format for " { $snippet "world" } " that satisfies the requested " { $snippet "attributes" } "." } ; + +{ world-pixel-format-attributes check-world-pixel-format pixel-format pixel-format-attribute } +related-words + +ARTICLE: "ui.pixel-formats" "Pixel formats" +"The UI allows you to control the window system's OpenGL interface with a cross-platform set of pixel format specifiers:" +{ $subsection "ui.pixel-formats-attributes" } + +"Pixel formats can be requested using these attributes:" +{ $subsection pixel-format } +{ $subsection } +{ $subsection pixel-format-attribute } + +"If a request for a set of pixel format attributes cannot be satisfied, an error is thrown:" +{ $subsection invalid-pixel-format-attributes } + +"Pixel formats are requested as part of opening a window for a " { $link world } ". These generics can be overridden on " { $snippet "world" } " subclasses to control pixel format selection:" +{ $subsection world-pixel-format-attributes } +{ $subsection check-world-pixel-format } +; + +ABOUT: "ui.pixel-formats" diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor new file mode 100644 index 0000000000..52abf44362 --- /dev/null +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -0,0 +1,94 @@ +USING: accessors assocs classes destructors functors kernel +lexer math parser sequences specialized-arrays.int ui.backend +words.symbol ; +IN: ui.pixel-formats + +SYMBOLS: + double-buffered + stereo + offscreen + fullscreen + windowed + accelerated + software-rendered + backing-store + multisampled + supersampled + sample-alpha + color-float ; + +TUPLE: pixel-format-attribute { value integer } ; + +TUPLE: color-bits < pixel-format-attribute ; +TUPLE: red-bits < pixel-format-attribute ; +TUPLE: green-bits < pixel-format-attribute ; +TUPLE: blue-bits < pixel-format-attribute ; +TUPLE: alpha-bits < pixel-format-attribute ; + +TUPLE: accum-bits < pixel-format-attribute ; +TUPLE: accum-red-bits < pixel-format-attribute ; +TUPLE: accum-green-bits < pixel-format-attribute ; +TUPLE: accum-blue-bits < pixel-format-attribute ; +TUPLE: accum-alpha-bits < pixel-format-attribute ; + +TUPLE: depth-bits < pixel-format-attribute ; + +TUPLE: stencil-bits < pixel-format-attribute ; + +TUPLE: aux-buffers < pixel-format-attribute ; + +TUPLE: sample-buffers < pixel-format-attribute ; +TUPLE: samples < pixel-format-attribute ; + +HOOK: (make-pixel-format) ui-backend ( world attributes -- pixel-format-handle ) +HOOK: (free-pixel-format) ui-backend ( pixel-format -- ) +HOOK: (pixel-format-attribute) ui-backend ( pixel-format attribute-name -- value ) + +ERROR: invalid-pixel-format-attributes world attributes ; + +TUPLE: pixel-format world handle ; + +: ( world attributes -- pixel-format ) + 2dup (make-pixel-format) + [ nip pixel-format boa ] [ invalid-pixel-format-attributes ] if* ; + +M: pixel-format dispose + [ (free-pixel-format) ] [ f >>handle drop ] bi ; + +: pixel-format-attribute ( pixel-format attribute-name -- value ) + (pixel-format-attribute) ; + +PFA DEFINES >${NAME} +>PFA-int-array DEFINES >${NAME}-int-array + +WHERE + +GENERIC: >PFA ( attribute -- pfas ) + +M: object >PFA + drop { } ; +M: symbol >PFA + TABLE at [ { } ] unless* ; +M: pixel-format-attribute >PFA + dup class TABLE at + [ swap value>> suffix ] + [ drop { } ] if* ; + +: >PFA-int-array ( attribute -- int-array ) + [ >PFA ] map concat PERM prepend 0 suffix >int-array ; + +;FUNCTOR + +SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE: + scan scan-object scan-object define-pixel-format-attribute-table ; + +PRIVATE> + +GENERIC: world-pixel-format-attributes ( world -- attributes ) + +GENERIC# check-world-pixel-format 1 ( world pixel-format -- ) + diff --git a/basis/ui/pixel-formats/summary.txt b/basis/ui/pixel-formats/summary.txt new file mode 100644 index 0000000000..517f42458b --- /dev/null +++ b/basis/ui/pixel-formats/summary.txt @@ -0,0 +1 @@ +Cross-platform OpenGL context pixel format specifiers diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor index 2edb20fc22..c1f05182e6 100755 --- a/basis/ui/text/text.factor +++ b/basis/ui/text/text.factor @@ -75,10 +75,8 @@ M: array draw-text USING: vocabs.loader namespaces system combinators ; -"ui-backend" get [ - { - { [ os macosx? ] [ "core-text" ] } - { [ os windows? ] [ "uniscribe" ] } - { [ os unix? ] [ "pango" ] } - } cond -] unless* "ui.text." prepend require \ No newline at end of file +{ + { [ os macosx? ] [ "core-text" ] } + { [ os windows? ] [ "uniscribe" ] } + { [ os unix? ] [ "pango" ] } +} cond "ui.text." prepend require diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index a493d5d7d2..1b8af1dd03 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -25,7 +25,10 @@ M: browser-gadget set-history-value : show-help ( link browser-gadget -- ) [ >link ] dip - [ [ add-recent ] [ history>> add-history ] bi* ] + [ + 2dup model>> value>> = + [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if + ] [ model>> set-model ] 2bi ; diff --git a/basis/ui/tools/common/common.factor b/basis/ui/tools/common/common.factor index e581e72e24..95af20ec72 100644 --- a/basis/ui/tools/common/common.factor +++ b/basis/ui/tools/common/common.factor @@ -7,7 +7,7 @@ IN: ui.tools.common SYMBOL: tool-dims -tool-dims global [ H{ } clone or ] change-at +tool-dims [ H{ } clone ] initialize TUPLE: tool < track ; diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index aa23a8ebe1..704ae112e5 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -10,7 +10,7 @@ ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs -ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener +ui.gadgets.labels ui.baseline-alignment ui.images compiler.errors tools.errors tools.errors.model ; IN: ui.tools.error-list diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index ba66121bc2..fdba400c3d 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -3,11 +3,10 @@ USING: accessors arrays assocs calendar colors colors.constants documents documents.elements fry kernel words sets splitting math math.vectors models.delay models.arrow combinators.short-circuit -parser present sequences tools.completion help.vocabs generic -generic.standard.engines.tuple fonts definitions.icons ui.images -ui.commands ui.operations ui.gadgets ui.gadgets.editors -ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables -ui.gadgets.tracks ui.gadgets.labeled +parser present sequences tools.completion help.vocabs generic fonts +definitions.icons ui.images ui.commands ui.operations ui.gadgets +ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers +ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid ui.tools.listener.history combinators vocabs ui.tools.listener.popups ; IN: ui.tools.listener.completion @@ -40,7 +39,7 @@ M: history-completion completion-quot drop '[ drop _ history-list ] ; GENERIC: completion-element ( completion-mode -- element ) -M: object completion-element drop one-word-elt ; +M: object completion-element drop word-start-elt ; M: history-completion completion-element drop one-line-elt ; GENERIC: completion-banner ( completion-mode -- string ) @@ -73,13 +72,13 @@ M: vocab-completion row-color drop vocab? COLOR: black COLOR: dark-gray ? ; : complete-IN:/USE:? ( tokens -- ? ) - 2 short tail* { "IN:" "USE:" } intersects? ; + 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ; : chop-; ( seq -- seq' ) { ";" } split1-last [ ] [ ] ?if ; : complete-USING:? ( tokens -- ? ) - chop-; { "USING:" } intersects? ; + chop-; 1 short head* { "USING:" } intersects? ; : complete-CHAR:? ( tokens -- ? ) 2 short tail* "CHAR:" swap member? ; @@ -120,8 +119,6 @@ M: object completion-string present ; M: method-body completion-string method-completion-string ; -M: engine-word completion-string method-completion-string ; - GENERIC# accept-completion-hook 1 ( item popup -- ) : insert-completion ( item popup -- ) diff --git a/basis/ui/tools/listener/listener-docs.factor b/basis/ui/tools/listener/listener-docs.factor index ec4fc80a4d..998020c9c4 100644 --- a/basis/ui/tools/listener/listener-docs.factor +++ b/basis/ui/tools/listener/listener-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax ui.commands ui.operations ui.gadgets.editors ui.gadgets.panes listener io words ui.tools.listener.completion ui.tools.common help.tips -tools.vocabs vocabs ; +vocabs vocabs.refresh ; IN: ui.tools.listener HELP: interactor diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 45b94344a6..e06e17374f 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -75,7 +75,7 @@ CONSTANT: text "Hello world.\nThis is a test." [ ] [ [ "interactor" get register-self - "interactor" get contents "promise" get fulfill + "interactor" get stream-contents "promise" get fulfill ] in-thread ] unit-test @@ -150,4 +150,4 @@ CONSTANT: text "Hello world.\nThis is a test." [ ] [ "l" set ] unit-test [ ] [ "l" get com-scroll-up ] unit-test -[ ] [ "l" get com-scroll-down ] unit-test \ No newline at end of file +[ ] [ "l" get com-scroll-down ] unit-test diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index eca16e7286..6ed3577a06 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -6,14 +6,15 @@ compiler.units help.tips concurrency.flags concurrency.mailboxes continuations destructors documents documents.elements fry hashtables help help.markup io io.styles kernel lexer listener math models sets models.delay models.arrow namespaces parser prettyprint quotations -sequences strings threads tools.vocabs vocabs vocabs.loader +sequences strings threads vocabs vocabs.refresh vocabs.loader vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations ui.tools.browser ui.tools.common ui.tools.debugger ui.tools.listener.completion ui.tools.listener.popups -ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ; +ui.tools.listener.history ui.images ui.tools.error-list +tools.errors.model ; FROM: source-files.errors => all-errors ; IN: ui.tools.listener diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index 3c16011897..650d751ee2 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -4,7 +4,7 @@ USING: continuations definitions generic help.topics threads stack-checker summary io.pathnames io.styles kernel namespaces parser prettyprint quotations tools.crossref tools.annotations editors tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader -words sequences tools.vocabs classes compiler.errors compiler.units +words sequences classes compiler.errors compiler.units accessors vocabs.parser macros.expander ui ui.tools.browser ui.tools.listener ui.tools.listener.completion ui.tools.profiler ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index c825c60dbb..7ea34e651f 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: memory system kernel tools.vocabs ui.tools.operations +USING: memory system kernel vocabs.refresh ui.tools.operations ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list ui.tools.walker ui.commands ui.gestures ui ui.private ; IN: ui.tools diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index f2b6154745..397fc419fa 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -2,17 +2,28 @@ USING: help.markup help.syntax strings quotations debugger namespaces ui.backend ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ui.gadgets.private math.rectangles colors ui.text fonts -kernel ui.private ; +kernel ui.private classes sequences ; IN: ui HELP: windows { $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ; -{ windows open-window find-window } related-words +{ windows open-window find-window world-attributes } related-words HELP: open-window -{ $values { "gadget" gadget } { "title" string } } -{ $description "Opens a native window with the specified title." } ; +{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } } +{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ; + +HELP: world-attributes +{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } } +{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" } +{ $list + { { $snippet "world-class" } " specifies the class of world to construct. " { $link world } " is the default." } + { { $snippet "title" } " is the window title." } + { { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." } + { { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." } + { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." } +} ; HELP: set-fullscreen? { $values { "?" "a boolean" } { "gadget" gadget } } diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 8be486cb1a..d53d4c6753 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -4,7 +4,8 @@ USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words continuations init combinators combinators.short-circuit hashtables concurrency.flags sets accessors calendar fry destructors ui.gadgets ui.gadgets.private -ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ; +ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render +strings ; IN: ui > [ handle>> (grab-input) ] [ drop ] if ; + +: ?ungrab-input ( world -- ) + dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ; + : focus-world ( world -- ) t >>focused? - dup raised-window - focus-path f focus-gestures ; + [ ?grab-input ] [ + dup raised-window + focus-path f focus-gestures + ] bi ; : unfocus-world ( world -- ) f >>focused? - focus-path f swap focus-gestures ; + [ ?ungrab-input ] + [ focus-path f swap focus-gestures ] bi ; + +: try-to-open-window ( world -- ) + { + [ (open-window) ] + [ handle>> select-gl-context ] + [ + [ begin-world ] + [ [ handle>> (close-window) ] [ ui-error ] bi* ] + recover + ] + [ resize-world ] + } cleave ; M: world graft* - [ (open-window) ] + [ try-to-open-window ] [ [ title>> ] keep set-title ] [ request-focus ] tri ; @@ -66,6 +88,7 @@ M: world graft* [ images>> [ dispose ] when* ] [ hand-clicked close-global ] [ hand-gadget close-global ] + [ end-world ] } cleave ; M: world ungraft* @@ -131,7 +154,9 @@ SYMBOL: ui-thread PRIVATE> : find-window ( quot -- world ) - [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline + [ windows get values ] dip + '[ dup children>> [ ] [ nip first ] if-empty @ ] + find-last nip ; inline : ui-running? ( -- ? ) \ ui-running get-global ; @@ -166,13 +191,17 @@ PRIVATE> : restore-windows? ( -- ? ) windows get empty? not ; +: ?attributes ( gadget title/attributes -- attributes ) + dup string? [ world-attributes new swap >>title ] when + swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ; + PRIVATE> : open-world-window ( world -- ) dup pref-dim >>dim dup relayout graft ; -: open-window ( gadget title -- ) - f open-world-window ; +: open-window ( gadget title/attributes -- ) + ?attributes open-world-window ; : set-fullscreen? ( ? gadget -- ) find-world set-fullscreen* ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index a6a0147504..10fb2ad64f 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -194,6 +194,7 @@ FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_ FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; FUNCTION: int symlink ( char* path1, char* path2 ) ; +FUNCTION: int link ( char* path1, char* path2 ) ; FUNCTION: int system ( char* command ) ; FUNCTION: int unlink ( char* path ) ; diff --git a/basis/vocabs/cache/authors.txt b/basis/vocabs/cache/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/cache/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/cache/cache.factor b/basis/vocabs/cache/cache.factor new file mode 100644 index 0000000000..63a8d6d292 --- /dev/null +++ b/basis/vocabs/cache/cache.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel namespaces memoize init vocabs +vocabs.hierarchy vocabs.loader vocabs.metadata vocabs.refresh ; +IN: vocabs.cache + +: reset-cache ( -- ) + root-cache get-global clear-assoc + \ vocab-file-contents reset-memoized + \ all-vocabs-seq reset-memoized + \ all-authors reset-memoized + \ all-tags reset-memoized ; + +SINGLETON: cache-observer + +M: cache-observer vocabs-changed drop reset-cache ; + +[ + f changed-vocabs set-global + cache-observer add-vocab-observer +] "vocabs.cache" add-init-hook \ No newline at end of file diff --git a/basis/vocabs/cache/summary.txt b/basis/vocabs/cache/summary.txt new file mode 100644 index 0000000000..92ab1fe8eb --- /dev/null +++ b/basis/vocabs/cache/summary.txt @@ -0,0 +1 @@ +Caching vocabulary data from disk diff --git a/basis/vocabs/errors/authors.txt b/basis/vocabs/errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/errors/errors.factor b/basis/vocabs/errors/errors.factor new file mode 100644 index 0000000000..8f88eb3816 --- /dev/null +++ b/basis/vocabs/errors/errors.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs continuations debugger io io.styles kernel +namespaces sequences vocabs vocabs.loader ; +IN: vocabs.errors + + + +: load-failures. ( failures -- ) + [ load-error. nl ] each ; + +: require-all ( vocabs -- failures ) + [ + V{ } clone blacklist set + V{ } clone failures set + [ + [ require ] + [ swap vocab-name failures get set-at ] + recover + ] each + failures get + ] with-scope ; \ No newline at end of file diff --git a/basis/vocabs/errors/summary.txt b/basis/vocabs/errors/summary.txt new file mode 100644 index 0000000000..b7e7040366 --- /dev/null +++ b/basis/vocabs/errors/summary.txt @@ -0,0 +1 @@ +Loading vocabularies and batching errors diff --git a/basis/vocabs/files/authors.txt b/basis/vocabs/files/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/files/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/files/files-docs.factor b/basis/vocabs/files/files-docs.factor new file mode 100644 index 0000000000..e2c6a5f373 --- /dev/null +++ b/basis/vocabs/files/files-docs.factor @@ -0,0 +1,11 @@ +USING: help.markup help.syntax strings ; +IN: vocabs.files + +HELP: vocab-files +{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ; + +HELP: vocab-tests +{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } } +{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ; + diff --git a/basis/vocabs/files/files-tests.factor b/basis/vocabs/files/files-tests.factor new file mode 100644 index 0000000000..a12a9c957f --- /dev/null +++ b/basis/vocabs/files/files-tests.factor @@ -0,0 +1,9 @@ +IN: vocabs.files.tests +USING: tools.test vocabs.files vocabs arrays grouping ; + +[ t ] [ + "kernel" vocab-files + "kernel" vocab vocab-files + "kernel" vocab-files + 3array all-equal? +] unit-test \ No newline at end of file diff --git a/basis/vocabs/files/files.factor b/basis/vocabs/files/files.factor new file mode 100644 index 0000000000..c1d7dcfd59 --- /dev/null +++ b/basis/vocabs/files/files.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.directories io.files io.pathnames kernel make +sequences vocabs.loader ; +IN: vocabs.files + + + +: vocab-tests ( vocab -- tests ) + [ + [ vocab-tests-file [ , ] when* ] + [ vocab-tests-dir [ % ] when* ] bi + ] { } make ; + +: vocab-files ( vocab -- seq ) + [ + [ vocab-source-path [ , ] when* ] + [ vocab-docs-path [ , ] when* ] + [ vocab-tests % ] tri + ] { } make ; \ No newline at end of file diff --git a/basis/vocabs/files/summary.txt b/basis/vocabs/files/summary.txt new file mode 100644 index 0000000000..b1633e3782 --- /dev/null +++ b/basis/vocabs/files/summary.txt @@ -0,0 +1 @@ +Getting a list of files in a vocabulary diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor new file mode 100644 index 0000000000..3bea362582 --- /dev/null +++ b/basis/vocabs/hierarchy/hierarchy-docs.factor @@ -0,0 +1,33 @@ +USING: help.markup help.syntax strings vocabs.loader ; +IN: vocabs.hierarchy + +ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools" +"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not." +$nl +"Loading vocabulary hierarchies:" +{ $subsection load } +{ $subsection load-all } +"Getting all vocabularies on disk:" +{ $subsection all-vocabs } +{ $subsection all-vocabs-seq } +"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:" +{ $subsection all-tags } +{ $subsection all-authors } ; + +ABOUT: "vocabs.hierarchy" + +HELP: all-vocabs +{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } } +{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ; + +HELP: load +{ $values { "prefix" string } } +{ $description "Load all vocabularies that match the provided prefix." } +{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ; + +HELP: load-all +{ $description "Load all vocabularies in the source tree." } ; + +HELP: all-vocabs-under +{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } } +{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ; diff --git a/basis/vocabs/hierarchy/hierarchy-tests.factor b/basis/vocabs/hierarchy/hierarchy-tests.factor new file mode 100644 index 0000000000..97fa59a342 --- /dev/null +++ b/basis/vocabs/hierarchy/hierarchy-tests.factor @@ -0,0 +1,2 @@ +IN: vocabs.hierarchy.tests +USING: continuations namespaces tools.test vocabs.hierarchy vocabs.hierarchy.private ; diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor new file mode 100644 index 0000000000..046ccb8c2d --- /dev/null +++ b/basis/vocabs/hierarchy/hierarchy.factor @@ -0,0 +1,99 @@ +! Copyright (C) 2007, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs combinators.short-circuit fry +io.directories io.files io.files.info io.pathnames kernel make +memoize namespaces sequences sorting splitting vocabs sets +vocabs.loader vocabs.metadata vocabs.errors ; +IN: vocabs.hierarchy + +vocab-link , ] when + vocabs-in-dir + ] with each ; + +PRIVATE> + +: all-vocabs ( -- assoc ) + vocab-roots get [ + dup [ "" vocabs-in-dir ] { } make + ] { } map>assoc ; + +: all-vocabs-under ( prefix -- vocabs ) + [ + [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each + ] { } make ; + +MEMO: all-vocabs-seq ( -- seq ) + "" all-vocabs-under ; + + + +: all-child-vocabs ( prefix -- assoc ) + vocab-roots get [ + dup pick (all-child-vocabs) [ >vocab-link ] map + ] { } map>assoc + swap unrooted-child-vocabs f swap 2array suffix ; + +: all-child-vocabs-seq ( prefix -- assoc ) + vocab-roots get swap '[ + dup _ (all-child-vocabs) + [ vocab-dir? ] with filter + ] map concat ; + + + +: (load) ( prefix -- failures ) + all-vocabs-under + filter-unportable + require-all ; + +: load ( prefix -- ) + (load) load-failures. ; + +: load-all ( -- ) + "" load ; + +MEMO: all-tags ( -- seq ) + all-vocabs-seq [ vocab-tags ] gather natural-sort ; + +MEMO: all-authors ( -- seq ) + all-vocabs-seq [ vocab-authors ] gather natural-sort ; \ No newline at end of file diff --git a/basis/vocabs/hierarchy/summary.txt b/basis/vocabs/hierarchy/summary.txt new file mode 100644 index 0000000000..b8d931570e --- /dev/null +++ b/basis/vocabs/hierarchy/summary.txt @@ -0,0 +1 @@ +Searching for vocabularies on disk diff --git a/basis/vocabs/metadata/authors.txt b/basis/vocabs/metadata/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/metadata/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/vocabs/metadata/metadata-docs.factor b/basis/vocabs/metadata/metadata-docs.factor new file mode 100644 index 0000000000..002f8534b4 --- /dev/null +++ b/basis/vocabs/metadata/metadata-docs.factor @@ -0,0 +1,44 @@ +USING: help.markup help.syntax strings ; +IN: vocabs.metadata + +ARTICLE: "vocabs.metadata" "Vocabulary metadata" +"Vocabulary summaries:" +{ $subsection vocab-summary } +{ $subsection set-vocab-summary } +"Vocabulary authors:" +{ $subsection vocab-authors } +{ $subsection set-vocab-authors } +"Vocabulary tags:" +{ $subsection vocab-tags } +{ $subsection set-vocab-tags } +{ $subsection add-vocab-tags } +"Getting and setting arbitrary vocabulary metadata:" +{ $subsection vocab-file-contents } +{ $subsection set-vocab-file-contents } ; + +ABOUT: "vocabs.metadata" + +HELP: vocab-file-contents +{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } +{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-file-contents +{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } +{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; + +HELP: vocab-summary +{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } +{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-summary +{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ; + +HELP: vocab-tags +{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } } +{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-tags +{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ; + diff --git a/basis/vocabs/metadata/metadata.factor b/basis/vocabs/metadata/metadata.factor new file mode 100644 index 0000000000..85a503c7f0 --- /dev/null +++ b/basis/vocabs/metadata/metadata.factor @@ -0,0 +1,70 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs io.encodings.utf8 io.files +io.pathnames kernel make math.parser memoize sequences sets +sorting summary vocabs vocabs.loader ; +IN: vocabs.metadata + +MEMO: vocab-file-contents ( vocab name -- seq ) + vocab-append-path dup + [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ; + +: set-vocab-file-contents ( seq vocab name -- ) + dupd vocab-append-path [ + utf8 set-file-lines + \ vocab-file-contents reset-memoized + ] [ + "The " swap vocab-name + " vocabulary was not loaded from the file system" + 3append throw + ] ?if ; + +: vocab-summary-path ( vocab -- string ) + vocab-dir "summary.txt" append-path ; + +: vocab-summary ( vocab -- summary ) + dup dup vocab-summary-path vocab-file-contents + [ + vocab-name " vocabulary" append + ] [ + nip first + ] if-empty ; + +M: vocab summary + [ + dup vocab-summary % + " (" % + words>> assoc-size # + " words)" % + ] "" make ; + +M: vocab-link summary vocab-summary ; + +: set-vocab-summary ( string vocab -- ) + [ 1array ] dip + dup vocab-summary-path + set-vocab-file-contents ; + +: vocab-tags-path ( vocab -- string ) + vocab-dir "tags.txt" append-path ; + +: vocab-tags ( vocab -- tags ) + dup vocab-tags-path vocab-file-contents harvest ; + +: set-vocab-tags ( tags vocab -- ) + dup vocab-tags-path set-vocab-file-contents ; + +: add-vocab-tags ( tags vocab -- ) + [ vocab-tags append prune ] keep set-vocab-tags ; + +: vocab-authors-path ( vocab -- string ) + vocab-dir "authors.txt" append-path ; + +: vocab-authors ( vocab -- authors ) + dup vocab-authors-path vocab-file-contents harvest ; + +: set-vocab-authors ( authors vocab -- ) + dup vocab-authors-path set-vocab-file-contents ; + +: unportable? ( vocab -- ? ) + vocab-tags "unportable" swap member? ; \ No newline at end of file diff --git a/basis/vocabs/metadata/summary.txt b/basis/vocabs/metadata/summary.txt new file mode 100644 index 0000000000..eec7fd52e9 --- /dev/null +++ b/basis/vocabs/metadata/summary.txt @@ -0,0 +1 @@ +Managing vocabulary author, tag and summary information diff --git a/basis/vocabs/refresh/authors.txt b/basis/vocabs/refresh/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/vocabs/refresh/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/vocabs/monitor/authors.txt b/basis/vocabs/refresh/monitor/authors.txt similarity index 100% rename from basis/tools/vocabs/monitor/authors.txt rename to basis/vocabs/refresh/monitor/authors.txt diff --git a/basis/tools/vocabs/monitor/monitor-tests.factor b/basis/vocabs/refresh/monitor/monitor-tests.factor similarity index 67% rename from basis/tools/vocabs/monitor/monitor-tests.factor rename to basis/vocabs/refresh/monitor/monitor-tests.factor index 0e767a3d34..86091189a5 100644 --- a/basis/tools/vocabs/monitor/monitor-tests.factor +++ b/basis/vocabs/refresh/monitor/monitor-tests.factor @@ -1,5 +1,5 @@ -USING: tools.test tools.vocabs.monitor io.pathnames ; -IN: tools.vocabs.monitor.tests +USING: tools.test vocabs.refresh.monitor io.pathnames ; +IN: vocabs.refresh.monitor.tests [ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test [ "kernel" ] [ "core/kernel/" path>vocab ] unit-test diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/vocabs/refresh/monitor/monitor.factor similarity index 80% rename from basis/tools/vocabs/monitor/monitor.factor rename to basis/vocabs/refresh/monitor/monitor.factor index 1914da78b2..1445b9f882 100644 --- a/basis/tools/vocabs/monitor/monitor.factor +++ b/basis/vocabs/refresh/monitor/monitor.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: threads io.files io.pathnames io.monitors init kernel -vocabs vocabs.loader tools.vocabs namespaces continuations -sequences splitting assocs command-line concurrency.messaging -io.backend sets tr accessors ; -IN: tools.vocabs.monitor +USING: accessors assocs command-line concurrency.messaging +continuations init io.backend io.files io.monitors io.pathnames +kernel namespaces sequences sets splitting threads +tr vocabs vocabs.loader vocabs.refresh vocabs.cache ; +IN: vocabs.refresh.monitor TR: convert-separators "/\\" ".." ; @@ -56,4 +56,4 @@ TR: convert-separators "/\\" ".." ; [ "-no-monitors" (command-line) member? [ start-monitor-thread ] unless -] "tools.vocabs.monitor" add-init-hook +] "vocabs.refresh.monitor" add-init-hook diff --git a/basis/tools/vocabs/monitor/summary.txt b/basis/vocabs/refresh/monitor/summary.txt similarity index 100% rename from basis/tools/vocabs/monitor/summary.txt rename to basis/vocabs/refresh/monitor/summary.txt diff --git a/basis/vocabs/refresh/refresh-docs.factor b/basis/vocabs/refresh/refresh-docs.factor new file mode 100644 index 0000000000..5652d2ac6a --- /dev/null +++ b/basis/vocabs/refresh/refresh-docs.factor @@ -0,0 +1,22 @@ +USING: help.markup help.syntax strings ; +IN: vocabs.refresh + +HELP: source-modified? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ; + +HELP: refresh +{ $values { "prefix" string } } +{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; + +HELP: refresh-all +{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; + +{ refresh refresh-all } related-words + +ARTICLE: "vocabs.refresh" "Runtime code reloading" +"Reloading source files changed on disk:" +{ $subsection refresh } +{ $subsection refresh-all } ; + +ABOUT: "vocabs.refresh" diff --git a/basis/tools/vocabs/vocabs-tests.factor b/basis/vocabs/refresh/refresh-tests.factor similarity index 70% rename from basis/tools/vocabs/vocabs-tests.factor rename to basis/vocabs/refresh/refresh-tests.factor index 04e628d080..ad8f005398 100644 --- a/basis/tools/vocabs/vocabs-tests.factor +++ b/basis/vocabs/refresh/refresh-tests.factor @@ -1,5 +1,5 @@ -IN: tools.vocabs.tests -USING: tools.test tools.vocabs namespaces continuations ; +IN: vocabs.refresh.tests +USING: vocabs.refresh tools.test continuations namespaces ; [ ] [ changed-vocabs get-global diff --git a/basis/vocabs/refresh/refresh.factor b/basis/vocabs/refresh/refresh.factor new file mode 100644 index 0000000000..9ec89e3102 --- /dev/null +++ b/basis/vocabs/refresh/refresh.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs checksums checksums.crc32 +io.encodings.utf8 io.files kernel namespaces sequences sets +source-files vocabs vocabs.errors vocabs.loader ; +IN: vocabs.refresh + +: source-modified? ( path -- ? ) + dup source-files get at [ + dup path>> + dup exists? [ + utf8 file-lines crc32 checksum-lines + swap checksum>> = not + ] [ + 2drop f + ] if + ] [ + exists? + ] ?if ; + +SYMBOL: changed-vocabs + +: changed-vocab ( vocab -- ) + dup vocab changed-vocabs get and + [ dup changed-vocabs get set-at ] [ drop ] if ; + +: unchanged-vocab ( vocab -- ) + changed-vocabs get delete-at ; + +: unchanged-vocabs ( vocabs -- ) + [ unchanged-vocab ] each ; + +: changed-vocab? ( vocab -- ? ) + changed-vocabs get dup [ key? ] [ 2drop t ] if ; + +: filter-changed ( vocabs -- vocabs' ) + [ changed-vocab? ] filter ; + +SYMBOL: modified-sources +SYMBOL: modified-docs + +: (to-refresh) ( vocab variable loaded? path -- ) + dup [ + swap [ + pick changed-vocab? [ + source-modified? [ get push ] [ 2drop ] if + ] [ 3drop ] if + ] [ drop get push ] if + ] [ 2drop 2drop ] if ; + +: to-refresh ( prefix -- modified-sources modified-docs unchanged ) + [ + V{ } clone modified-sources set + V{ } clone modified-docs set + + child-vocabs [ + [ + [ + [ modified-sources ] + [ vocab source-loaded?>> ] + [ vocab-source-path ] + tri (to-refresh) + ] [ + [ modified-docs ] + [ vocab docs-loaded?>> ] + [ vocab-docs-path ] + tri (to-refresh) + ] bi + ] each + + modified-sources get + modified-docs get + ] + [ modified-docs get modified-sources get append diff ] bi + ] with-scope ; + +: do-refresh ( modified-sources modified-docs unchanged -- ) + unchanged-vocabs + [ + [ [ vocab f >>source-loaded? drop ] each ] + [ [ vocab f >>docs-loaded? drop ] each ] bi* + ] + [ + append prune + [ unchanged-vocabs ] + [ require-all load-failures. ] bi + ] 2bi ; + +: refresh ( prefix -- ) to-refresh do-refresh ; + +: refresh-all ( -- ) "" refresh ; \ No newline at end of file diff --git a/basis/vocabs/refresh/summary.txt b/basis/vocabs/refresh/summary.txt new file mode 100644 index 0000000000..4f75199aa5 --- /dev/null +++ b/basis/vocabs/refresh/summary.txt @@ -0,0 +1 @@ +Reloading changed vocabularies from disk diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index 5b62f54795..fd037cb2a0 100644 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -350,35 +350,46 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080 TOKEN_ADJUST_DEFAULT } flags ; foldable -CONSTANT: HKEY_CLASSES_ROOT 1 -CONSTANT: HKEY_CURRENT_CONFIG 2 -CONSTANT: HKEY_CURRENT_USER 3 -CONSTANT: HKEY_LOCAL_MACHINE 4 -CONSTANT: HKEY_USERS 5 +CONSTANT: HKEY_CLASSES_ROOT HEX: 80000000 +CONSTANT: HKEY_CURRENT_USER HEX: 80000001 +CONSTANT: HKEY_LOCAL_MACHINE HEX: 80000002 +CONSTANT: HKEY_USERS HEX: 80000003 +CONSTANT: HKEY_PERFORMANCE_DATA HEX: 80000004 +CONSTANT: HKEY_CURRENT_CONFIG HEX: 80000005 +CONSTANT: HKEY_DYN_DATA HEX: 80000006 +CONSTANT: HKEY_PERFORMANCE_TEXT HEX: 80000050 +CONSTANT: HKEY_PERFORMANCE_NLSTEXT HEX: 80000060 -CONSTANT: KEY_ALL_ACCESS HEX: 0001 -CONSTANT: KEY_CREATE_LINK HEX: 0002 +CONSTANT: KEY_QUERY_VALUE HEX: 0001 +CONSTANT: KEY_SET_VALUE HEX: 0002 CONSTANT: KEY_CREATE_SUB_KEY HEX: 0004 CONSTANT: KEY_ENUMERATE_SUB_KEYS HEX: 0008 -CONSTANT: KEY_EXECUTE HEX: 0010 -CONSTANT: KEY_NOTIFY HEX: 0020 -CONSTANT: KEY_QUERY_VALUE HEX: 0040 -CONSTANT: KEY_READ HEX: 0080 -CONSTANT: KEY_SET_VALUE HEX: 0100 -CONSTANT: KEY_WOW64_64KEY HEX: 0200 -CONSTANT: KEY_WOW64_32KEY HEX: 0400 -CONSTANT: KEY_WRITE HEX: 0800 +CONSTANT: KEY_NOTIFY HEX: 0010 +CONSTANT: KEY_CREATE_LINK HEX: 0020 +CONSTANT: KEY_READ HEX: 20019 +CONSTANT: KEY_WOW64_32KEY HEX: 0200 +CONSTANT: KEY_WOW64_64KEY HEX: 0100 +CONSTANT: KEY_WRITE HEX: 20006 +CONSTANT: KEY_EXECUTE KEY_READ +CONSTANT: KEY_ALL_ACCESS HEX: F003F -CONSTANT: REG_BINARY 1 -CONSTANT: REG_DWORD 2 -CONSTANT: REG_EXPAND_SZ 3 -CONSTANT: REG_MULTI_SZ 4 -CONSTANT: REG_QWORD 5 -CONSTANT: REG_SZ 6 +CONSTANT: REG_NONE 0 +CONSTANT: REG_SZ 1 +CONSTANT: REG_EXPAND_SZ 2 +CONSTANT: REG_BINARY 3 +CONSTANT: REG_DWORD 4 +CONSTANT: REG_DWORD_LITTLE_ENDIAN 4 +CONSTANT: REG_DWORD_BIG_ENDIAN 5 +CONSTANT: REG_LINK 6 +CONSTANT: REG_MULTI_SZ 7 +CONSTANT: REG_RESOURCE_LIST 8 +CONSTANT: REG_FULL_RESOURCE_DESCRIPTOR 9 +CONSTANT: REG_RESOURCE_REQUIREMENTS_LIST 10 +CONSTANT: REG_QWORD 11 +CONSTANT: REG_QWORD_LITTLE_ENDIAN 11 TYPEDEF: DWORD REGSAM - ! : I_ScGetCurrentGroupStateW ; ! : A_SHAFinal ; ! : A_SHAInit ; @@ -874,7 +885,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : ReadEncryptedFileRaw ; ! : ReadEventLogA ; ! : ReadEventLogW ; -! : RegCloseKey ; +FUNCTION: LONG RegCloseKey ( HKEY hKey ) ; ! : RegConnectRegistryA ; ! : RegConnectRegistryW ; ! : RegCreateKeyA ; @@ -883,15 +894,52 @@ FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LP ! : RegCreateKeyW ! : RegDeleteKeyA ; ! : RegDeleteKeyW ; + +FUNCTION: LONG RegDeleteKeyExW ( + HKEY hKey, + LPCTSTR lpSubKey, + DWORD Reserved, + LPTSTR lpClass, + DWORD dwOptions, + REGSAM samDesired, + LPSECURITY_ATTRIBUTES lpSecurityAttributes, + PHKEY phkResult, + LPDWORD lpdwDisposition + ) ; + +ALIAS: RegDeleteKeyEx RegDeleteKeyExW + ! : RegDeleteValueA ; ! : RegDeleteValueW ; ! : RegDisablePredefinedCache ; ! : RegEnumKeyA ; ! : RegEnumKeyExA ; -! : RegEnumKeyExW ; +FUNCTION: LONG RegEnumKeyExW ( + HKEY hKey, + DWORD dwIndex, + LPTSTR lpName, + LPDWORD lpcName, + LPDWORD lpReserved, + LPTSTR lpClass, + LPDWORD lpcClass, + PFILETIME lpftLastWriteTime + ) ; ! : RegEnumKeyW ; ! : RegEnumValueA ; -! : RegEnumValueW ; + +FUNCTION: LONG RegEnumValueW ( + HKEY hKey, + DWORD dwIndex, + LPTSTR lpValueName, + LPDWORD lpcchValueName, + LPDWORD lpReserved, + LPDWORD lpType, + LPBYTE lpData, + LPDWORD lpcbData + ) ; + +ALIAS: RegEnumValue RegEnumValueW + ! : RegFlushKey ; ! : RegGetKeySecurity ; ! : RegLoadKeyA ; @@ -900,17 +948,33 @@ FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LP FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ; ! : RegOpenKeyA ; ! : RegOpenKeyExA ; -! : RegOpenKeyExW ; +FUNCTION: LONG RegOpenKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD ulOptions, REGSAM samDesired, PHKEY phkResult ) ; +ALIAS: RegOpenKeyEx RegOpenKeyExW ! : RegOpenKeyW ; ! : RegOpenUserClassesRoot ; ! : RegOverridePredefKey ; ! : RegQueryInfoKeyA ; -! : RegQueryInfoKeyW ; +FUNCTION: LONG RegQueryInfoKeyW ( + HKEY hKey, + LPTSTR lpClass, + LPDWORD lpcClass, + LPDWORD lpReserved, + LPDWORD lpcSubKeys, + LPDWORD lpcMaxSubKeyLen, + LPDWORD lpcMaxClassLen, + LPDWORD lpcValues, + LPDWORD lpcMaxValueNameLen, + LPDWORD lpcMaxValueLen, + LPDWORD lpcbSecurityDescriptor, + PFILETIME lpftLastWriteTime + ) ; +ALIAS: RegQueryInfoKey RegQueryInfoKeyW ! : RegQueryMultipleValuesA ; ! : RegQueryMultipleValuesW ; ! : RegQueryValueA ; ! : RegQueryValueExA ; -FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ; +FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPDWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ; +ALIAS: RegQueryValueEx RegQueryValueExW ! : RegQueryValueW ; ! : RegReplaceKeyA ; ! : RegReplaceKeyW ; diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor index af828c9145..d485692a91 100644 --- a/basis/windows/com/com.factor +++ b/basis/windows/com/com.factor @@ -40,6 +40,6 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} IUnknown::Release drop ; inline : with-com-interface ( interface quot -- ) - over [ slip ] [ com-release ] [ ] cleanup ; inline + over [ com-release ] curry [ ] cleanup ; inline DESTRUCTOR: com-release diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index e78c987cd4..9d52378da9 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -93,7 +93,7 @@ unless : compile-alien-callback ( word return parameters abi quot -- word ) '[ _ _ _ _ alien-callback ] - [ [ (( -- alien )) define-declared ] pick slip ] + [ [ (( -- alien )) define-declared ] pick [ call ] dip ] with-compilation-unit ; : (callback-word) ( function-name interface-name counter -- word ) diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index 0f95c6d683..74238abed2 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -842,7 +842,7 @@ SYMBOLS: [ define-constants ] "windows.dinput.constants" add-init-hook : uninitialize ( variable quot -- ) - [ global ] dip '[ _ when* f ] change-at ; inline + '[ _ when* f ] change-global ; inline : free-dinput-constants ( -- ) { diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor index 20a54dff98..e5e32aac0e 100755 --- a/basis/windows/dinput/dinput.factor +++ b/basis/windows/dinput/dinput.factor @@ -444,6 +444,18 @@ CONSTANT: DISCL_FOREGROUND HEX: 00000004 CONSTANT: DISCL_BACKGROUND HEX: 00000008 CONSTANT: DISCL_NOWINKEY HEX: 00000010 +CONSTANT: DIMOFS_X 0 +CONSTANT: DIMOFS_Y 4 +CONSTANT: DIMOFS_Z 8 +CONSTANT: DIMOFS_BUTTON0 12 +CONSTANT: DIMOFS_BUTTON1 13 +CONSTANT: DIMOFS_BUTTON2 14 +CONSTANT: DIMOFS_BUTTON3 15 +CONSTANT: DIMOFS_BUTTON4 16 +CONSTANT: DIMOFS_BUTTON5 17 +CONSTANT: DIMOFS_BUTTON6 18 +CONSTANT: DIMOFS_BUTTON7 19 + CONSTANT: DIK_ESCAPE HEX: 01 CONSTANT: DIK_1 HEX: 02 CONSTANT: DIK_2 HEX: 03 diff --git a/basis/windows/errors/errors-tests.factor b/basis/windows/errors/errors-tests.factor new file mode 100755 index 0000000000..96edb8a379 --- /dev/null +++ b/basis/windows/errors/errors-tests.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test windows.errors strings ; +IN: windows.errors.tests + +[ t ] [ 0 n>win32-error-string string? ] unit-test diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 56bba768de..d180cb20e7 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,9 +1,754 @@ -IN: windows.errors +USING: alien.c-types kernel locals math math.bitwise +windows.kernel32 sequences byte-arrays unicode.categories +io.encodings.string io.encodings.utf16n alien.strings +arrays literals ; +IN: windows.errors -CONSTANT: ERROR_SUCCESS 0 -CONSTANT: ERROR_NO_MORE_FILES 18 -CONSTANT: ERROR_HANDLE_EOF 38 -CONSTANT: ERROR_BROKEN_PIPE 109 -CONSTANT: ERROR_ENVVAR_NOT_FOUND 203 -CONSTANT: ERROR_IO_INCOMPLETE 996 -CONSTANT: ERROR_IO_PENDING 997 +CONSTANT: ERROR_SUCCESS 0 +CONSTANT: ERROR_INVALID_FUNCTION 1 +CONSTANT: ERROR_FILE_NOT_FOUND 2 +CONSTANT: ERROR_PATH_NOT_FOUND 3 +CONSTANT: ERROR_TOO_MANY_OPEN_FILES 4 +CONSTANT: ERROR_ACCESS_DENIED 5 +CONSTANT: ERROR_INVALID_HANDLE 6 +CONSTANT: ERROR_ARENA_TRASHED 7 +CONSTANT: ERROR_NOT_ENOUGH_MEMORY 8 +CONSTANT: ERROR_INVALID_BLOCK 9 +CONSTANT: ERROR_BAD_ENVIRONMENT 10 +CONSTANT: ERROR_BAD_FORMAT 11 +CONSTANT: ERROR_INVALID_ACCESS 12 +CONSTANT: ERROR_INVALID_DATA 13 +CONSTANT: ERROR_OUTOFMEMORY 14 +CONSTANT: ERROR_INVALID_DRIVE 15 +CONSTANT: ERROR_CURRENT_DIRECTORY 16 +CONSTANT: ERROR_NOT_SAME_DEVICE 17 +CONSTANT: ERROR_NO_MORE_FILES 18 +CONSTANT: ERROR_WRITE_PROTECT 19 +CONSTANT: ERROR_BAD_UNIT 20 +CONSTANT: ERROR_NOT_READY 21 +CONSTANT: ERROR_BAD_COMMAND 22 +CONSTANT: ERROR_CRC 23 +CONSTANT: ERROR_BAD_LENGTH 24 +CONSTANT: ERROR_SEEK 25 +CONSTANT: ERROR_NOT_DOS_DISK 26 +CONSTANT: ERROR_SECTOR_NOT_FOUND 27 +CONSTANT: ERROR_OUT_OF_PAPER 28 +CONSTANT: ERROR_WRITE_FAULT 29 +CONSTANT: ERROR_READ_FAULT 30 +CONSTANT: ERROR_GEN_FAILURE 31 +CONSTANT: ERROR_SHARING_VIOLATION 32 +CONSTANT: ERROR_LOCK_VIOLATION 33 +CONSTANT: ERROR_WRONG_DISK 34 +CONSTANT: ERROR_SHARING_BUFFER_EXCEEDED 36 +CONSTANT: ERROR_HANDLE_EOF 38 +CONSTANT: ERROR_HANDLE_DISK_FULL 39 +CONSTANT: ERROR_NOT_SUPPORTED 50 +CONSTANT: ERROR_REM_NOT_LIST 51 +CONSTANT: ERROR_DUP_NAME 52 +CONSTANT: ERROR_BAD_NETPATH 53 +CONSTANT: ERROR_NETWORK_BUSY 54 +CONSTANT: ERROR_DEV_NOT_EXIST 55 +CONSTANT: ERROR_TOO_MANY_CMDS 56 +CONSTANT: ERROR_ADAP_HDW_ERR 57 +CONSTANT: ERROR_BAD_NET_RESP 58 +CONSTANT: ERROR_UNEXP_NET_ERR 59 +CONSTANT: ERROR_BAD_REM_ADAP 60 +CONSTANT: ERROR_PRINTQ_FULL 61 +CONSTANT: ERROR_NO_SPOOL_SPACE 62 +CONSTANT: ERROR_PRINT_CANCELLED 63 +CONSTANT: ERROR_NETNAME_DELETED 64 +CONSTANT: ERROR_NETWORK_ACCESS_DENIED 65 +CONSTANT: ERROR_BAD_DEV_TYPE 66 +CONSTANT: ERROR_BAD_NET_NAME 67 +CONSTANT: ERROR_TOO_MANY_NAMES 68 +CONSTANT: ERROR_TOO_MANY_SESS 69 +CONSTANT: ERROR_SHARING_PAUSED 70 +CONSTANT: ERROR_REQ_NOT_ACCEP 71 +CONSTANT: ERROR_REDIR_PAUSED 72 +CONSTANT: ERROR_FILE_EXISTS 80 +CONSTANT: ERROR_CANNOT_MAKE 82 +CONSTANT: ERROR_FAIL_I24 83 +CONSTANT: ERROR_OUT_OF_STRUCTURES 84 +CONSTANT: ERROR_ALREADY_ASSIGNED 85 +CONSTANT: ERROR_INVALID_PASSWORD 86 +CONSTANT: ERROR_INVALID_PARAMETER 87 +CONSTANT: ERROR_NET_WRITE_FAULT 88 +CONSTANT: ERROR_NO_PROC_SLOTS 89 +CONSTANT: ERROR_TOO_MANY_SEMAPHORES 100 +CONSTANT: ERROR_EXCL_SEM_ALREADY_OWNED 101 +CONSTANT: ERROR_SEM_IS_SET 102 +CONSTANT: ERROR_TOO_MANY_SEM_REQUESTS 103 +CONSTANT: ERROR_INVALID_AT_INTERRUPT_TIME 104 +CONSTANT: ERROR_SEM_OWNER_DIED 105 +CONSTANT: ERROR_SEM_USER_LIMIT 106 +CONSTANT: ERROR_DISK_CHANGE 107 +CONSTANT: ERROR_DRIVE_LOCKED 108 +CONSTANT: ERROR_BROKEN_PIPE 109 +CONSTANT: ERROR_OPEN_FAILED 110 +CONSTANT: ERROR_BUFFER_OVERFLOW 111 +CONSTANT: ERROR_DISK_FULL 112 +CONSTANT: ERROR_NO_MORE_SEARCH_HANDLES 113 +CONSTANT: ERROR_INVALID_TARGET_HANDLE 114 +CONSTANT: ERROR_INVALID_CATEGORY 117 +CONSTANT: ERROR_INVALID_VERIFY_SWITCH 118 +CONSTANT: ERROR_BAD_DRIVER_LEVEL 119 +CONSTANT: ERROR_CALL_NOT_IMPLEMENTED 120 +CONSTANT: ERROR_SEM_TIMEOUT 121 +CONSTANT: ERROR_INSUFFICIENT_BUFFER 122 +CONSTANT: ERROR_INVALID_NAME 123 +CONSTANT: ERROR_INVALID_LEVEL 124 +CONSTANT: ERROR_NO_VOLUME_LABEL 125 +CONSTANT: ERROR_MOD_NOT_FOUND 126 +CONSTANT: ERROR_PROC_NOT_FOUND 127 +CONSTANT: ERROR_WAIT_NO_CHILDREN 128 +CONSTANT: ERROR_CHILD_NOT_COMPLETE 129 +CONSTANT: ERROR_DIRECT_ACCESS_HANDLE 130 +CONSTANT: ERROR_NEGATIVE_SEEK 131 +CONSTANT: ERROR_SEEK_ON_DEVICE 132 +CONSTANT: ERROR_IS_JOIN_TARGET 133 +CONSTANT: ERROR_IS_JOINED 134 +CONSTANT: ERROR_IS_SUBSTED 135 +CONSTANT: ERROR_NOT_JOINED 136 +CONSTANT: ERROR_NOT_SUBSTED 137 +CONSTANT: ERROR_JOIN_TO_JOIN 138 +CONSTANT: ERROR_SUBST_TO_SUBST 139 +CONSTANT: ERROR_JOIN_TO_SUBST 140 +CONSTANT: ERROR_SUBST_TO_JOIN 141 +CONSTANT: ERROR_BUSY_DRIVE 142 +CONSTANT: ERROR_SAME_DRIVE 143 +CONSTANT: ERROR_DIR_NOT_ROOT 144 +CONSTANT: ERROR_DIR_NOT_EMPTY 145 +CONSTANT: ERROR_IS_SUBST_PATH 146 +CONSTANT: ERROR_IS_JOIN_PATH 147 +CONSTANT: ERROR_PATH_BUSY 148 +CONSTANT: ERROR_IS_SUBST_TARGET 149 +CONSTANT: ERROR_SYSTEM_TRACE 150 +CONSTANT: ERROR_INVALID_EVENT_COUNT 151 +CONSTANT: ERROR_TOO_MANY_MUXWAITERS 152 +CONSTANT: ERROR_INVALID_LIST_FORMAT 153 +CONSTANT: ERROR_LABEL_TOO_LONG 154 +CONSTANT: ERROR_TOO_MANY_TCBS 155 +CONSTANT: ERROR_SIGNAL_REFUSED 156 +CONSTANT: ERROR_DISCARDED 157 +CONSTANT: ERROR_NOT_LOCKED 158 +CONSTANT: ERROR_BAD_THREADID_ADDR 159 +CONSTANT: ERROR_BAD_ARGUMENTS 160 +CONSTANT: ERROR_BAD_PATHNAME 161 +CONSTANT: ERROR_SIGNAL_PENDING 162 +CONSTANT: ERROR_MAX_THRDS_REACHED 164 +CONSTANT: ERROR_LOCK_FAILED 167 +CONSTANT: ERROR_BUSY 170 +CONSTANT: ERROR_CANCEL_VIOLATION 173 +CONSTANT: ERROR_ATOMIC_LOCKS_NOT_SUPPORTED 174 +CONSTANT: ERROR_INVALID_SEGMENT_NUMBER 180 +CONSTANT: ERROR_INVALID_ORDINAL 182 +CONSTANT: ERROR_ALREADY_EXISTS 183 +CONSTANT: ERROR_INVALID_FLAG_NUMBER 186 +CONSTANT: ERROR_SEM_NOT_FOUND 187 +CONSTANT: ERROR_INVALID_STARTING_CODESEG 188 +CONSTANT: ERROR_INVALID_STACKSEG 189 +CONSTANT: ERROR_INVALID_MODULETYPE 190 +CONSTANT: ERROR_INVALID_EXE_SIGNATURE 191 +CONSTANT: ERROR_EXE_MARKED_INVALID 192 +CONSTANT: ERROR_BAD_EXE_FORMAT 193 +CONSTANT: ERROR_ITERATED_DATA_EXCEEDS_64k 194 +CONSTANT: ERROR_INVALID_MINALLOCSIZE 195 +CONSTANT: ERROR_DYNLINK_FROM_INVALID_RING 196 +CONSTANT: ERROR_IOPL_NOT_ENABLED 197 +CONSTANT: ERROR_INVALID_SEGDPL 198 +CONSTANT: ERROR_AUTODATASEG_EXCEEDS_64k 199 +CONSTANT: ERROR_RING2SEG_MUST_BE_MOVABLE 200 +CONSTANT: ERROR_RELOC_CHAIN_XEEDS_SEGLIM 201 +CONSTANT: ERROR_INFLOOP_IN_RELOC_CHAIN 202 +CONSTANT: ERROR_ENVVAR_NOT_FOUND 203 +CONSTANT: ERROR_NO_SIGNAL_SENT 205 +CONSTANT: ERROR_FILENAME_EXCED_RANGE 206 +CONSTANT: ERROR_RING2_STACK_IN_USE 207 +CONSTANT: ERROR_META_EXPANSION_TOO_LONG 208 +CONSTANT: ERROR_INVALID_SIGNAL_NUMBER 209 +CONSTANT: ERROR_THREAD_1_INACTIVE 210 +CONSTANT: ERROR_LOCKED 212 +CONSTANT: ERROR_TOO_MANY_MODULES 214 +CONSTANT: ERROR_NESTING_NOT_ALLOWED 215 +CONSTANT: ERROR_EXE_MACHINE_TYPE_MISMATCH 216 +CONSTANT: ERROR_BAD_PIPE 230 +CONSTANT: ERROR_PIPE_BUSY 231 +CONSTANT: ERROR_NO_DATA 232 +CONSTANT: ERROR_PIPE_NOT_CONNECTED 233 +CONSTANT: ERROR_MORE_DATA 234 +CONSTANT: ERROR_VC_DISCONNECTED 240 +CONSTANT: ERROR_INVALID_EA_NAME 254 +CONSTANT: ERROR_EA_LIST_INCONSISTENT 255 +CONSTANT: ERROR_NO_MORE_ITEMS 259 +CONSTANT: ERROR_CANNOT_COPY 266 +CONSTANT: ERROR_DIRECTORY 267 +CONSTANT: ERROR_EAS_DIDNT_FIT 275 +CONSTANT: ERROR_EA_FILE_CORRUPT 276 +CONSTANT: ERROR_EA_TABLE_FULL 277 +CONSTANT: ERROR_INVALID_EA_HANDLE 278 +CONSTANT: ERROR_EAS_NOT_SUPPORTED 282 +CONSTANT: ERROR_NOT_OWNER 288 +CONSTANT: ERROR_TOO_MANY_POSTS 298 +CONSTANT: ERROR_PARTIAL_COPY 299 +CONSTANT: ERROR_MR_MID_NOT_FOUND 317 +CONSTANT: ERROR_INVALID_ADDRESS 487 +CONSTANT: ERROR_ARITHMETIC_OVERFLOW 534 +CONSTANT: ERROR_PIPE_CONNECTED 535 +CONSTANT: ERROR_PIPE_LISTENING 536 +CONSTANT: ERROR_EA_ACCESS_DENIED 994 +CONSTANT: ERROR_OPERATION_ABORTED 995 +CONSTANT: ERROR_IO_INCOMPLETE 996 +CONSTANT: ERROR_IO_PENDING 997 +CONSTANT: ERROR_NOACCESS 998 +CONSTANT: ERROR_SWAPERROR 999 +CONSTANT: ERROR_STACK_OVERFLOW 1001 +CONSTANT: ERROR_INVALID_MESSAGE 1002 +CONSTANT: ERROR_CAN_NOT_COMPLETE 1003 +CONSTANT: ERROR_INVALID_FLAGS 1004 +CONSTANT: ERROR_UNRECOGNIZED_VOLUME 1005 +CONSTANT: ERROR_FILE_INVALID 1006 +CONSTANT: ERROR_FULLSCREEN_MODE 1007 +CONSTANT: ERROR_NO_TOKEN 1008 +CONSTANT: ERROR_BADDB 1009 +CONSTANT: ERROR_BADKEY 1010 +CONSTANT: ERROR_CANTOPEN 1011 +CONSTANT: ERROR_CANTREAD 1012 +CONSTANT: ERROR_CANTWRITE 1013 +CONSTANT: ERROR_REGISTRY_RECOVERED 1014 +CONSTANT: ERROR_REGISTRY_CORRUPT 1015 +CONSTANT: ERROR_REGISTRY_IO_FAILED 1016 +CONSTANT: ERROR_NOT_REGISTRY_FILE 1017 +CONSTANT: ERROR_KEY_DELETED 1018 +CONSTANT: ERROR_NO_LOG_SPACE 1019 +CONSTANT: ERROR_KEY_HAS_CHILDREN 1020 +CONSTANT: ERROR_CHILD_MUST_BE_VOLATILE 1021 +CONSTANT: ERROR_NOTIFY_ENUM_DIR 1022 +CONSTANT: ERROR_DEPENDENT_SERVICES_RUNNING 1051 +CONSTANT: ERROR_INVALID_SERVICE_CONTROL 1052 +CONSTANT: ERROR_SERVICE_REQUEST_TIMEOUT 1053 +CONSTANT: ERROR_SERVICE_NO_THREAD 1054 +CONSTANT: ERROR_SERVICE_DATABASE_LOCKED 1055 +CONSTANT: ERROR_SERVICE_ALREADY_RUNNING 1056 +CONSTANT: ERROR_INVALID_SERVICE_ACCOUNT 1057 +CONSTANT: ERROR_SERVICE_DISABLED 1058 +CONSTANT: ERROR_CIRCULAR_DEPENDENCY 1059 +CONSTANT: ERROR_SERVICE_DOES_NOT_EXIST 1060 +CONSTANT: ERROR_SERVICE_CANNOT_ACCEPT_CTRL 1061 +CONSTANT: ERROR_SERVICE_NOT_ACTIVE 1062 +CONSTANT: ERROR_FAILED_SERVICE_CONTROLLER_CONNECT 1063 +CONSTANT: ERROR_EXCEPTION_IN_SERVICE 1064 +CONSTANT: ERROR_DATABASE_DOES_NOT_EXIST 1065 +CONSTANT: ERROR_SERVICE_SPECIFIC_ERROR 1066 +CONSTANT: ERROR_PROCESS_ABORTED 1067 +CONSTANT: ERROR_SERVICE_DEPENDENCY_FAIL 1068 +CONSTANT: ERROR_SERVICE_LOGON_FAILED 1069 +CONSTANT: ERROR_SERVICE_START_HANG 1070 +CONSTANT: ERROR_INVALID_SERVICE_LOCK 1071 +CONSTANT: ERROR_SERVICE_MARKED_FOR_DELETE 1072 +CONSTANT: ERROR_SERVICE_EXISTS 1073 +CONSTANT: ERROR_ALREADY_RUNNING_LKG 1074 +CONSTANT: ERROR_SERVICE_DEPENDENCY_DELETED 1075 +CONSTANT: ERROR_BOOT_ALREADY_ACCEPTED 1076 +CONSTANT: ERROR_SERVICE_NEVER_STARTED 1077 +CONSTANT: ERROR_DUPLICATE_SERVICE_NAME 1078 +CONSTANT: ERROR_DIFFERENT_SERVICE_ACCOUNT 1079 +CONSTANT: ERROR_END_OF_MEDIA 1100 +CONSTANT: ERROR_FILEMARK_DETECTED 1101 +CONSTANT: ERROR_BEGINNING_OF_MEDIA 1102 +CONSTANT: ERROR_SETMARK_DETECTED 1103 +CONSTANT: ERROR_NO_DATA_DETECTED 1104 +CONSTANT: ERROR_PARTITION_FAILURE 1105 +CONSTANT: ERROR_INVALID_BLOCK_LENGTH 1106 +CONSTANT: ERROR_DEVICE_NOT_PARTITIONED 1107 +CONSTANT: ERROR_UNABLE_TO_LOCK_MEDIA 1108 +CONSTANT: ERROR_UNABLE_TO_UNLOAD_MEDIA 1109 +CONSTANT: ERROR_MEDIA_CHANGED 1110 +CONSTANT: ERROR_BUS_RESET 1111 +CONSTANT: ERROR_NO_MEDIA_IN_DRIVE 1112 +CONSTANT: ERROR_NO_UNICODE_TRANSLATION 1113 +CONSTANT: ERROR_DLL_INIT_FAILED 1114 +CONSTANT: ERROR_SHUTDOWN_IN_PROGRESS 1115 +CONSTANT: ERROR_NO_SHUTDOWN_IN_PROGRESS 1116 +CONSTANT: ERROR_IO_DEVICE 1117 +CONSTANT: ERROR_SERIAL_NO_DEVICE 1118 +CONSTANT: ERROR_IRQ_BUSY 1119 +CONSTANT: ERROR_MORE_WRITES 1120 +CONSTANT: ERROR_COUNTER_TIMEOUT 1121 +CONSTANT: ERROR_FLOPPY_ID_MARK_NOT_FOUND 1122 +CONSTANT: ERROR_FLOPPY_WRONG_CYLINDER 1123 +CONSTANT: ERROR_FLOPPY_UNKNOWN_ERROR 1124 +CONSTANT: ERROR_FLOPPY_BAD_REGISTERS 1125 +CONSTANT: ERROR_DISK_RECALIBRATE_FAILED 1126 +CONSTANT: ERROR_DISK_OPERATION_FAILED 1127 +CONSTANT: ERROR_DISK_RESET_FAILED 1128 +CONSTANT: ERROR_EOM_OVERFLOW 1129 +CONSTANT: ERROR_NOT_ENOUGH_SERVER_MEMORY 1130 +CONSTANT: ERROR_POSSIBLE_DEADLOCK 1131 +CONSTANT: ERROR_MAPPED_ALIGNMENT 1132 +CONSTANT: ERROR_SET_POWER_STATE_VETOED 1140 +CONSTANT: ERROR_SET_POWER_STATE_FAILED 1141 +CONSTANT: ERROR_TOO_MANY_LINKS 1142 +CONSTANT: ERROR_OLD_WIN_VERSION 1150 +CONSTANT: ERROR_APP_WRONG_OS 1151 +CONSTANT: ERROR_SINGLE_INSTANCE_APP 1152 +CONSTANT: ERROR_RMODE_APP 1153 +CONSTANT: ERROR_INVALID_DLL 1154 +CONSTANT: ERROR_NO_ASSOCIATION 1155 +CONSTANT: ERROR_DDE_FAIL 1156 +CONSTANT: ERROR_DLL_NOT_FOUND 1157 +CONSTANT: ERROR_BAD_DEVICE 1200 +CONSTANT: ERROR_CONNECTION_UNAVAIL 1201 +CONSTANT: ERROR_DEVICE_ALREADY_REMEMBERED 1202 +CONSTANT: ERROR_NO_NET_OR_BAD_PATH 1203 +CONSTANT: ERROR_BAD_PROVIDER 1204 +CONSTANT: ERROR_CANNOT_OPEN_PROFILE 1205 +CONSTANT: ERROR_BAD_PROFILE 1206 +CONSTANT: ERROR_NOT_CONTAINER 1207 +CONSTANT: ERROR_EXTENDED_ERROR 1208 +CONSTANT: ERROR_INVALID_GROUPNAME 1209 +CONSTANT: ERROR_INVALID_COMPUTERNAME 1210 +CONSTANT: ERROR_INVALID_EVENTNAME 1211 +CONSTANT: ERROR_INVALID_DOMAINNAME 1212 +CONSTANT: ERROR_INVALID_SERVICENAME 1213 +CONSTANT: ERROR_INVALID_NETNAME 1214 +CONSTANT: ERROR_INVALID_SHARENAME 1215 +CONSTANT: ERROR_INVALID_PASSWORDNAME 1216 +CONSTANT: ERROR_INVALID_MESSAGENAME 1217 +CONSTANT: ERROR_INVALID_MESSAGEDEST 1218 +CONSTANT: ERROR_SESSION_CREDENTIAL_CONFLICT 1219 +CONSTANT: ERROR_REMOTE_SESSION_LIMIT_EXCEEDED 1220 +CONSTANT: ERROR_DUP_DOMAINNAME 1221 +CONSTANT: ERROR_NO_NETWORK 1222 +CONSTANT: ERROR_CANCELLED 1223 +CONSTANT: ERROR_USER_MAPPED_FILE 1224 +CONSTANT: ERROR_CONNECTION_REFUSED 1225 +CONSTANT: ERROR_GRACEFUL_DISCONNECT 1226 +CONSTANT: ERROR_ADDRESS_ALREADY_ASSOCIATED 1227 +CONSTANT: ERROR_ADDRESS_NOT_ASSOCIATED 1228 +CONSTANT: ERROR_CONNECTION_INVALID 1229 +CONSTANT: ERROR_CONNECTION_ACTIVE 1230 +CONSTANT: ERROR_NETWORK_UNREACHABLE 1231 +CONSTANT: ERROR_HOST_UNREACHABLE 1232 +CONSTANT: ERROR_PROTOCOL_UNREACHABLE 1233 +CONSTANT: ERROR_PORT_UNREACHABLE 1234 +CONSTANT: ERROR_REQUEST_ABORTED 1235 +CONSTANT: ERROR_CONNECTION_ABORTED 1236 +CONSTANT: ERROR_RETRY 1237 +CONSTANT: ERROR_CONNECTION_COUNT_LIMIT 1238 +CONSTANT: ERROR_LOGIN_TIME_RESTRICTION 1239 +CONSTANT: ERROR_LOGIN_WKSTA_RESTRICTION 1240 +CONSTANT: ERROR_INCORRECT_ADDRESS 1241 +CONSTANT: ERROR_ALREADY_REGISTERED 1242 +CONSTANT: ERROR_SERVICE_NOT_FOUND 1243 +CONSTANT: ERROR_NOT_AUTHENTICATED 1244 +CONSTANT: ERROR_NOT_LOGGED_ON 1245 +CONSTANT: ERROR_CONTINUE 1246 +CONSTANT: ERROR_ALREADY_INITIALIZED 1247 +CONSTANT: ERROR_NO_MORE_DEVICES 1248 +CONSTANT: ERROR_NOT_ALL_ASSIGNED 1300 +CONSTANT: ERROR_SOME_NOT_MAPPED 1301 +CONSTANT: ERROR_NO_QUOTAS_FOR_ACCOUNT 1302 +CONSTANT: ERROR_LOCAL_USER_SESSION_KEY 1303 +CONSTANT: ERROR_NULL_LM_PASSWORD 1304 +CONSTANT: ERROR_UNKNOWN_REVISION 1305 +CONSTANT: ERROR_REVISION_MISMATCH 1306 +CONSTANT: ERROR_INVALID_OWNER 1307 +CONSTANT: ERROR_INVALID_PRIMARY_GROUP 1308 +CONSTANT: ERROR_NO_IMPERSONATION_TOKEN 1309 +CONSTANT: ERROR_CANT_DISABLE_MANDATORY 1310 +CONSTANT: ERROR_NO_LOGON_SERVERS 1311 +CONSTANT: ERROR_NO_SUCH_LOGON_SESSION 1312 +CONSTANT: ERROR_NO_SUCH_PRIVILEGE 1313 +CONSTANT: ERROR_PRIVILEGE_NOT_HELD 1314 +CONSTANT: ERROR_INVALID_ACCOUNT_NAME 1315 +CONSTANT: ERROR_USER_EXISTS 1316 +CONSTANT: ERROR_NO_SUCH_USER 1317 +CONSTANT: ERROR_GROUP_EXISTS 1318 +CONSTANT: ERROR_NO_SUCH_GROUP 1319 +CONSTANT: ERROR_MEMBER_IN_GROUP 1320 +CONSTANT: ERROR_MEMBER_NOT_IN_GROUP 1321 +CONSTANT: ERROR_LAST_ADMIN 1322 +CONSTANT: ERROR_WRONG_PASSWORD 1323 +CONSTANT: ERROR_ILL_FORMED_PASSWORD 1324 +CONSTANT: ERROR_PASSWORD_RESTRICTION 1325 +CONSTANT: ERROR_LOGON_FAILURE 1326 +CONSTANT: ERROR_ACCOUNT_RESTRICTION 1327 +CONSTANT: ERROR_INVALID_LOGON_HOURS 1328 +CONSTANT: ERROR_INVALID_WORKSTATION 1329 +CONSTANT: ERROR_PASSWORD_EXPIRED 1330 +CONSTANT: ERROR_ACCOUNT_DISABLED 1331 +CONSTANT: ERROR_NONE_MAPPED 1332 +CONSTANT: ERROR_TOO_MANY_LUIDS_REQUESTED 1333 +CONSTANT: ERROR_LUIDS_EXHAUSTED 1334 +CONSTANT: ERROR_INVALID_SUB_AUTHORITY 1335 +CONSTANT: ERROR_INVALID_ACL 1336 +CONSTANT: ERROR_INVALID_SID 1337 +CONSTANT: ERROR_INVALID_SECURITY_DESCR 1338 +CONSTANT: ERROR_BAD_INHERITANCE_ACL 1340 +CONSTANT: ERROR_SERVER_DISABLED 1341 +CONSTANT: ERROR_SERVER_NOT_DISABLED 1342 +CONSTANT: ERROR_INVALID_ID_AUTHORITY 1343 +CONSTANT: ERROR_ALLOTTED_SPACE_EXCEEDED 1344 +CONSTANT: ERROR_INVALID_GROUP_ATTRIBUTES 1345 +CONSTANT: ERROR_BAD_IMPERSONATION_LEVEL 1346 +CONSTANT: ERROR_CANT_OPEN_ANONYMOUS 1347 +CONSTANT: ERROR_BAD_VALIDATION_CLASS 1348 +CONSTANT: ERROR_BAD_TOKEN_TYPE 1349 +CONSTANT: ERROR_NO_SECURITY_ON_OBJECT 1350 +CONSTANT: ERROR_CANT_ACCESS_DOMAIN_INFO 1351 +CONSTANT: ERROR_INVALID_SERVER_STATE 1352 +CONSTANT: ERROR_INVALID_DOMAIN_STATE 1353 +CONSTANT: ERROR_INVALID_DOMAIN_ROLE 1354 +CONSTANT: ERROR_NO_SUCH_DOMAIN 1355 +CONSTANT: ERROR_DOMAIN_EXISTS 1356 +CONSTANT: ERROR_DOMAIN_LIMIT_EXCEEDED 1357 +CONSTANT: ERROR_INTERNAL_DB_CORRUPTION 1358 +CONSTANT: ERROR_INTERNAL_ERROR 1359 +CONSTANT: ERROR_GENERIC_NOT_MAPPED 1360 +CONSTANT: ERROR_BAD_DESCRIPTOR_FORMAT 1361 +CONSTANT: ERROR_NOT_LOGON_PROCESS 1362 +CONSTANT: ERROR_LOGON_SESSION_EXISTS 1363 +CONSTANT: ERROR_NO_SUCH_PACKAGE 1364 +CONSTANT: ERROR_BAD_LOGON_SESSION_STATE 1365 +CONSTANT: ERROR_LOGON_SESSION_COLLISION 1366 +CONSTANT: ERROR_INVALID_LOGON_TYPE 1367 +CONSTANT: ERROR_CANNOT_IMPERSONATE 1368 +CONSTANT: ERROR_RXACT_INVALID_STATE 1369 +CONSTANT: ERROR_RXACT_COMMIT_FAILURE 1370 +CONSTANT: ERROR_SPECIAL_ACCOUNT 1371 +CONSTANT: ERROR_SPECIAL_GROUP 1372 +CONSTANT: ERROR_SPECIAL_USER 1373 +CONSTANT: ERROR_MEMBERS_PRIMARY_GROUP 1374 +CONSTANT: ERROR_TOKEN_ALREADY_IN_USE 1375 +CONSTANT: ERROR_NO_SUCH_ALIAS 1376 +CONSTANT: ERROR_MEMBER_NOT_IN_ALIAS 1377 +CONSTANT: ERROR_MEMBER_IN_ALIAS 1378 +CONSTANT: ERROR_ALIAS_EXISTS 1379 +CONSTANT: ERROR_LOGON_NOT_GRANTED 1380 +CONSTANT: ERROR_TOO_MANY_SECRETS 1381 +CONSTANT: ERROR_SECRET_TOO_LONG 1382 +CONSTANT: ERROR_INTERNAL_DB_ERROR 1383 +CONSTANT: ERROR_TOO_MANY_CONTEXT_IDS 1384 +CONSTANT: ERROR_LOGON_TYPE_NOT_GRANTED 1385 +CONSTANT: ERROR_NT_CROSS_ENCRYPTION_REQUIRED 1386 +CONSTANT: ERROR_NO_SUCH_MEMBER 1387 +CONSTANT: ERROR_INVALID_MEMBER 1388 +CONSTANT: ERROR_TOO_MANY_SIDS 1389 +CONSTANT: ERROR_LM_CROSS_ENCRYPTION_REQUIRED 1390 +CONSTANT: ERROR_NO_INHERITANCE 1391 +CONSTANT: ERROR_FILE_CORRUPT 1392 +CONSTANT: ERROR_DISK_CORRUPT 1393 +CONSTANT: ERROR_NO_USER_SESSION_KEY 1394 +CONSTANT: ERROR_LICENSE_QUOTA_EXCEEDED 1395 +CONSTANT: ERROR_INVALID_WINDOW_HANDLE 1400 +CONSTANT: ERROR_INVALID_MENU_HANDLE 1401 +CONSTANT: ERROR_INVALID_CURSOR_HANDLE 1402 +CONSTANT: ERROR_INVALID_ACCEL_HANDLE 1403 +CONSTANT: ERROR_INVALID_HOOK_HANDLE 1404 +CONSTANT: ERROR_INVALID_DWP_HANDLE 1405 +CONSTANT: ERROR_TLW_WITH_WSCHILD 1406 +CONSTANT: ERROR_CANNOT_FIND_WND_CLASS 1407 +CONSTANT: ERROR_WINDOW_OF_OTHER_THREAD 1408 +CONSTANT: ERROR_HOTKEY_ALREADY_REGISTERED 1409 +CONSTANT: ERROR_CLASS_ALREADY_EXISTS 1410 +CONSTANT: ERROR_CLASS_DOES_NOT_EXIST 1411 +CONSTANT: ERROR_CLASS_HAS_WINDOWS 1412 +CONSTANT: ERROR_INVALID_INDEX 1413 +CONSTANT: ERROR_INVALID_ICON_HANDLE 1414 +CONSTANT: ERROR_PRIVATE_DIALOG_INDEX 1415 +CONSTANT: ERROR_LISTBOX_ID_NOT_FOUND 1416 +CONSTANT: ERROR_NO_WILDCARD_CHARACTERS 1417 +CONSTANT: ERROR_CLIPBOARD_NOT_OPEN 1418 +CONSTANT: ERROR_HOTKEY_NOT_REGISTERED 1419 +CONSTANT: ERROR_WINDOW_NOT_DIALOG 1420 +CONSTANT: ERROR_CONTROL_ID_NOT_FOUND 1421 +CONSTANT: ERROR_INVALID_COMBOBOX_MESSAGE 1422 +CONSTANT: ERROR_WINDOW_NOT_COMBOBOX 1423 +CONSTANT: ERROR_INVALID_EDIT_HEIGHT 1424 +CONSTANT: ERROR_DC_NOT_FOUND 1425 +CONSTANT: ERROR_INVALID_HOOK_FILTER 1426 +CONSTANT: ERROR_INVALID_FILTER_PROC 1427 +CONSTANT: ERROR_HOOK_NEEDS_HMOD 1428 +CONSTANT: ERROR_GLOBAL_ONLY_HOOK 1429 +CONSTANT: ERROR_JOURNAL_HOOK_SET 1430 +CONSTANT: ERROR_HOOK_NOT_INSTALLED 1431 +CONSTANT: ERROR_INVALID_LB_MESSAGE 1432 +CONSTANT: ERROR_LB_WITHOUT_TABSTOPS 1434 +CONSTANT: ERROR_DESTROY_OBJECT_OF_OTHER_THREAD 1435 +CONSTANT: ERROR_CHILD_WINDOW_MENU 1436 +CONSTANT: ERROR_NO_SYSTEM_MENU 1437 +CONSTANT: ERROR_INVALID_MSGBOX_STYLE 1438 +CONSTANT: ERROR_INVALID_SPI_VALUE 1439 +CONSTANT: ERROR_SCREEN_ALREADY_LOCKED 1440 +CONSTANT: ERROR_HWNDS_HAVE_DIFF_PARENT 1441 +CONSTANT: ERROR_NOT_CHILD_WINDOW 1442 +CONSTANT: ERROR_INVALID_GW_COMMAND 1443 +CONSTANT: ERROR_INVALID_THREAD_ID 1444 +CONSTANT: ERROR_NON_MDICHILD_WINDOW 1445 +CONSTANT: ERROR_POPUP_ALREADY_ACTIVE 1446 +CONSTANT: ERROR_NO_SCROLLBARS 1447 +CONSTANT: ERROR_INVALID_SCROLLBAR_RANGE 1448 +CONSTANT: ERROR_INVALID_SHOWWIN_COMMAND 1449 +CONSTANT: ERROR_NO_SYSTEM_RESOURCES 1450 +CONSTANT: ERROR_NONPAGED_SYSTEM_RESOURCES 1451 +CONSTANT: ERROR_PAGED_SYSTEM_RESOURCES 1452 +CONSTANT: ERROR_WORKING_SET_QUOTA 1453 +CONSTANT: ERROR_PAGEFILE_QUOTA 1454 +CONSTANT: ERROR_COMMITMENT_LIMIT 1455 +CONSTANT: ERROR_MENU_ITEM_NOT_FOUND 1456 +CONSTANT: ERROR_INVALID_KEYBOARD_HANDLE 1457 +CONSTANT: ERROR_HOOK_TYPE_NOT_ALLOWED 1458 +CONSTANT: ERROR_REQUIRES_INTERACTIVE_WINDOWSTATION 1459 +CONSTANT: ERROR_TIMEOUT 1460 +CONSTANT: ERROR_EVENTLOG_FILE_CORRUPT 1500 +CONSTANT: ERROR_EVENTLOG_CANT_START 1501 +CONSTANT: ERROR_LOG_FILE_FULL 1502 +CONSTANT: ERROR_EVENTLOG_FILE_CHANGED 1503 +CONSTANT: RPC_S_INVALID_STRING_BINDING 1700 +CONSTANT: RPC_S_WRONG_KIND_OF_BINDING 1701 +CONSTANT: RPC_S_INVALID_BINDING 1702 +CONSTANT: RPC_S_PROTSEQ_NOT_SUPPORTED 1703 +CONSTANT: RPC_S_INVALID_RPC_PROTSEQ 1704 +CONSTANT: RPC_S_INVALID_STRING_UUID 1705 +CONSTANT: RPC_S_INVALID_ENDPOINT_FORMAT 1706 +CONSTANT: RPC_S_INVALID_NET_ADDR 1707 +CONSTANT: RPC_S_NO_ENDPOINT_FOUND 1708 +CONSTANT: RPC_S_INVALID_TIMEOUT 1709 +CONSTANT: RPC_S_OBJECT_NOT_FOUND 1710 +CONSTANT: RPC_S_ALREADY_REGISTERED 1711 +CONSTANT: RPC_S_TYPE_ALREADY_REGISTERED 1712 +CONSTANT: RPC_S_ALREADY_LISTENING 1713 +CONSTANT: RPC_S_NO_PROTSEQS_REGISTERED 1714 +CONSTANT: RPC_S_NOT_LISTENING 1715 +CONSTANT: RPC_S_UNKNOWN_MGR_TYPE 1716 +CONSTANT: RPC_S_UNKNOWN_IF 1717 +CONSTANT: RPC_S_NO_BINDINGS 1718 +CONSTANT: RPC_S_NO_PROTSEQS 1719 +CONSTANT: RPC_S_CANT_CREATE_ENDPOINT 1720 +CONSTANT: RPC_S_OUT_OF_RESOURCES 1721 +CONSTANT: RPC_S_SERVER_UNAVAILABLE 1722 +CONSTANT: RPC_S_SERVER_TOO_BUSY 1723 +CONSTANT: RPC_S_INVALID_NETWORK_OPTIONS 1724 +CONSTANT: RPC_S_NO_CALL_ACTIVE 1725 +CONSTANT: RPC_S_CALL_FAILED 1726 +CONSTANT: RPC_S_CALL_FAILED_DNE 1727 +CONSTANT: RPC_S_PROTOCOL_ERROR 1728 +CONSTANT: RPC_S_UNSUPPORTED_TRANS_SYN 1730 +CONSTANT: RPC_S_UNSUPPORTED_TYPE 1732 +CONSTANT: RPC_S_INVALID_TAG 1733 +CONSTANT: RPC_S_INVALID_BOUND 1734 +CONSTANT: RPC_S_NO_ENTRY_NAME 1735 +CONSTANT: RPC_S_INVALID_NAME_SYNTAX 1736 +CONSTANT: RPC_S_UNSUPPORTED_NAME_SYNTAX 1737 +CONSTANT: RPC_S_UUID_NO_ADDRESS 1739 +CONSTANT: RPC_S_DUPLICATE_ENDPOINT 1740 +CONSTANT: RPC_S_UNKNOWN_AUTHN_TYPE 1741 +CONSTANT: RPC_S_MAX_CALLS_TOO_SMALL 1742 +CONSTANT: RPC_S_STRING_TOO_LONG 1743 +CONSTANT: RPC_S_PROTSEQ_NOT_FOUND 1744 +CONSTANT: RPC_S_PROCNUM_OUT_OF_RANGE 1745 +CONSTANT: RPC_S_BINDING_HAS_NO_AUTH 1746 +CONSTANT: RPC_S_UNKNOWN_AUTHN_SERVICE 1747 +CONSTANT: RPC_S_UNKNOWN_AUTHN_LEVEL 1748 +CONSTANT: RPC_S_INVALID_AUTH_IDENTITY 1749 +CONSTANT: RPC_S_UNKNOWN_AUTHZ_SERVICE 1750 +CONSTANT: EPT_S_INVALID_ENTRY 1751 +CONSTANT: EPT_S_CANT_PERFORM_OP 1752 +CONSTANT: EPT_S_NOT_REGISTERED 1753 +CONSTANT: RPC_S_NOTHING_TO_EXPORT 1754 +CONSTANT: RPC_S_INCOMPLETE_NAME 1755 +CONSTANT: RPC_S_INVALID_VERS_OPTION 1756 +CONSTANT: RPC_S_NO_MORE_MEMBERS 1757 +CONSTANT: RPC_S_NOT_ALL_OBJS_UNEXPORTED 1758 +CONSTANT: RPC_S_INTERFACE_NOT_FOUND 1759 +CONSTANT: RPC_S_ENTRY_ALREADY_EXISTS 1760 +CONSTANT: RPC_S_ENTRY_NOT_FOUND 1761 +CONSTANT: RPC_S_NAME_SERVICE_UNAVAILABLE 1762 +CONSTANT: RPC_S_INVALID_NAF_ID 1763 +CONSTANT: RPC_S_CANNOT_SUPPORT 1764 +CONSTANT: RPC_S_NO_CONTEXT_AVAILABLE 1765 +CONSTANT: RPC_S_INTERNAL_ERROR 1766 +CONSTANT: RPC_S_ZERO_DIVIDE 1767 +CONSTANT: RPC_S_ADDRESS_ERROR 1768 +CONSTANT: RPC_S_FP_DIV_ZERO 1769 +CONSTANT: RPC_S_FP_UNDERFLOW 1770 +CONSTANT: RPC_S_FP_OVERFLOW 1771 +CONSTANT: RPC_X_NO_MORE_ENTRIES 1772 +CONSTANT: RPC_X_SS_CHAR_TRANS_OPEN_FAIL 1773 +CONSTANT: RPC_X_SS_CHAR_TRANS_SHORT_FILE 1774 +CONSTANT: RPC_X_SS_IN_NULL_CONTEXT 1775 +CONSTANT: RPC_X_SS_CONTEXT_DAMAGED 1777 +CONSTANT: RPC_X_SS_HANDLES_MISMATCH 1778 +CONSTANT: RPC_X_SS_CANNOT_GET_CALL_HANDLE 1779 +CONSTANT: RPC_X_NULL_REF_POINTER 1780 +CONSTANT: RPC_X_ENUM_VALUE_OUT_OF_RANGE 1781 +CONSTANT: RPC_X_BYTE_COUNT_TOO_SMALL 1782 +CONSTANT: RPC_X_BAD_STUB_DATA 1783 +CONSTANT: ERROR_INVALID_USER_BUFFER 1784 +CONSTANT: ERROR_UNRECOGNIZED_MEDIA 1785 +CONSTANT: ERROR_NO_TRUST_LSA_SECRET 1786 +CONSTANT: ERROR_NO_TRUST_SAM_ACCOUNT 1787 +CONSTANT: ERROR_TRUSTED_DOMAIN_FAILURE 1788 +CONSTANT: ERROR_TRUSTED_RELATIONSHIP_FAILURE 1789 +CONSTANT: ERROR_TRUST_FAILURE 1790 +CONSTANT: RPC_S_CALL_IN_PROGRESS 1791 +CONSTANT: ERROR_NETLOGON_NOT_STARTED 1792 +CONSTANT: ERROR_ACCOUNT_EXPIRED 1793 +CONSTANT: ERROR_REDIRECTOR_HAS_OPEN_HANDLES 1794 +CONSTANT: ERROR_PRINTER_DRIVER_ALREADY_INSTALLED 1795 +CONSTANT: ERROR_UNKNOWN_PORT 1796 +CONSTANT: ERROR_UNKNOWN_PRINTER_DRIVER 1797 +CONSTANT: ERROR_UNKNOWN_PRINTPROCESSOR 1798 +CONSTANT: ERROR_INVALID_SEPARATOR_FILE 1799 +CONSTANT: ERROR_INVALID_PRIORITY 1800 +CONSTANT: ERROR_INVALID_PRINTER_NAME 1801 +CONSTANT: ERROR_PRINTER_ALREADY_EXISTS 1802 +CONSTANT: ERROR_INVALID_PRINTER_COMMAND 1803 +CONSTANT: ERROR_INVALID_DATATYPE 1804 +CONSTANT: ERROR_INVALID_ENVIRONMENT 1805 +CONSTANT: RPC_S_NO_MORE_BINDINGS 1806 +CONSTANT: ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT 1807 +CONSTANT: ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT 1808 +CONSTANT: ERROR_NOLOGON_SERVER_TRUST_ACCOUNT 1809 +CONSTANT: ERROR_DOMAIN_TRUST_INCONSISTENT 1810 +CONSTANT: ERROR_SERVER_HAS_OPEN_HANDLES 1811 +CONSTANT: ERROR_RESOURCE_DATA_NOT_FOUND 1812 +CONSTANT: ERROR_RESOURCE_TYPE_NOT_FOUND 1813 +CONSTANT: ERROR_RESOURCE_NAME_NOT_FOUND 1814 +CONSTANT: ERROR_RESOURCE_LANG_NOT_FOUND 1815 +CONSTANT: ERROR_NOT_ENOUGH_QUOTA 1816 +CONSTANT: RPC_S_NO_INTERFACES 1817 +CONSTANT: RPC_S_CALL_CANCELLED 1818 +CONSTANT: RPC_S_BINDING_INCOMPLETE 1819 +CONSTANT: RPC_S_COMM_FAILURE 1820 +CONSTANT: RPC_S_UNSUPPORTED_AUTHN_LEVEL 1821 +CONSTANT: RPC_S_NO_PRINC_NAME 1822 +CONSTANT: RPC_S_NOT_RPC_ERROR 1823 +CONSTANT: RPC_S_UUID_LOCAL_ONLY 1824 +CONSTANT: RPC_S_SEC_PKG_ERROR 1825 +CONSTANT: RPC_S_NOT_CANCELLED 1826 +CONSTANT: RPC_X_INVALID_ES_ACTION 1827 +CONSTANT: RPC_X_WRONG_ES_VERSION 1828 +CONSTANT: RPC_X_WRONG_STUB_VERSION 1829 +CONSTANT: RPC_X_INVALID_PIPE_OBJECT 1830 +CONSTANT: RPC_X_INVALID_PIPE_OPERATION 1831 +CONSTANT: RPC_X_WRONG_PIPE_VERSION 1832 +CONSTANT: RPC_S_GROUP_MEMBER_NOT_FOUND 1898 +CONSTANT: EPT_S_CANT_CREATE 1899 +CONSTANT: RPC_S_INVALID_OBJECT 1900 +CONSTANT: ERROR_INVALID_TIME 1901 +CONSTANT: ERROR_INVALID_FORM_NAME 1902 +CONSTANT: ERROR_INVALID_FORM_SIZE 1903 +CONSTANT: ERROR_ALREADY_WAITING 1904 +CONSTANT: ERROR_PRINTER_DELETED 1905 +CONSTANT: ERROR_INVALID_PRINTER_STATE 1906 +CONSTANT: ERROR_PASSWORD_MUST_CHANGE 1907 +CONSTANT: ERROR_DOMAIN_CONTROLLER_NOT_FOUND 1908 +CONSTANT: ERROR_ACCOUNT_LOCKED_OUT 1909 +CONSTANT: OR_INVALID_OXID 1910 +CONSTANT: OR_INVALID_OID 1911 +CONSTANT: OR_INVALID_SET 1912 +CONSTANT: RPC_S_SEND_INCOMPLETE 1913 +CONSTANT: ERROR_INVALID_PIXEL_FORMAT 2000 +CONSTANT: ERROR_BAD_DRIVER 2001 +CONSTANT: ERROR_INVALID_WINDOW_STYLE 2002 +CONSTANT: ERROR_METAFILE_NOT_SUPPORTED 2003 +CONSTANT: ERROR_TRANSFORM_NOT_SUPPORTED 2004 +CONSTANT: ERROR_CLIPPING_NOT_SUPPORTED 2005 +CONSTANT: ERROR_BAD_USERNAME 2202 +CONSTANT: ERROR_NOT_CONNECTED 2250 +CONSTANT: ERROR_OPEN_FILES 2401 +CONSTANT: ERROR_ACTIVE_CONNECTIONS 2402 +CONSTANT: ERROR_DEVICE_IN_USE 2404 +CONSTANT: ERROR_UNKNOWN_PRINT_MONITOR 3000 +CONSTANT: ERROR_PRINTER_DRIVER_IN_USE 3001 +CONSTANT: ERROR_SPOOL_FILE_NOT_FOUND 3002 +CONSTANT: ERROR_SPL_NO_STARTDOC 3003 +CONSTANT: ERROR_SPL_NO_ADDJOB 3004 +CONSTANT: ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED 3005 +CONSTANT: ERROR_PRINT_MONITOR_ALREADY_INSTALLED 3006 +CONSTANT: ERROR_INVALID_PRINT_MONITOR 3007 +CONSTANT: ERROR_PRINT_MONITOR_IN_USE 3008 +CONSTANT: ERROR_PRINTER_HAS_JOBS_QUEUED 3009 +CONSTANT: ERROR_SUCCESS_REBOOT_REQUIRED 3010 +CONSTANT: ERROR_SUCCESS_RESTART_REQUIRED 3011 +CONSTANT: ERROR_WINS_INTERNAL 4000 +CONSTANT: ERROR_CAN_NOT_DEL_LOCAL_WINS 4001 +CONSTANT: ERROR_STATIC_INIT 4002 +CONSTANT: ERROR_INC_BACKUP 4003 +CONSTANT: ERROR_FULL_BACKUP 4004 +CONSTANT: ERROR_REC_NON_EXISTENT 4005 +CONSTANT: ERROR_RPL_NOT_ALLOWED 4006 +CONSTANT: ERROR_NO_BROWSER_SERVERS_FOUND 6118 + +CONSTANT: SUBLANG_NEUTRAL 0 +CONSTANT: LANG_NEUTRAL 0 +CONSTANT: SUBLANG_DEFAULT 1 + +CONSTANT: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 +CONSTANT: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 +CONSTANT: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 +CONSTANT: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 +CONSTANT: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 +CONSTANT: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 +CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF + +: make-lang-id ( lang1 lang2 -- n ) + 10 shift bitor ; inline + +ERROR: error-message-failed id ; +:: n>win32-error-string ( id -- string ) + { + FORMAT_MESSAGE_FROM_SYSTEM + FORMAT_MESSAGE_ARGUMENT_ARRAY + } flags + f + id + LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id + 32768 [ "TCHAR" ] keep + f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip + utf16n alien>string [ blank? ] trim ; + +: win32-error-string ( -- str ) + GetLastError n>win32-error-string ; + +: (win32-error) ( n -- ) + dup zero? [ + drop + ] [ + win32-error-string throw + ] if ; + +: win32-error ( -- ) + GetLastError (win32-error) ; + +: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ; +: win32-error>0 ( n -- ) 0 > [ win32-error ] when ; +: win32-error<0 ( n -- ) 0 < [ win32-error ] when ; +: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ; + +: invalid-handle? ( handle -- ) + INVALID_HANDLE_VALUE = [ + win32-error-string throw + ] when ; + +CONSTANT: expected-io-errors + ${ + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT + } + +: expected-io-error? ( error-code -- ? ) + expected-io-errors member? ; + +: expected-io-error ( error-code -- ) + dup expected-io-error? [ + drop + ] [ + win32-error-string throw + ] if ; + +: io-error ( return-value -- ) + { 0 f } member? [ GetLastError expected-io-error ] when ; diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor index a034856b34..1753ff1ce1 100755 --- a/basis/windows/fonts/fonts.factor +++ b/basis/windows/fonts/fonts.factor @@ -1,5 +1,5 @@ USING: assocs memoize locals kernel accessors init fonts math -combinators windows windows.types windows.gdi32 ; +combinators windows.errors windows.types windows.gdi32 ; IN: windows.fonts : windows-font-name ( string -- string' ) diff --git a/basis/windows/fonts/tags.txt b/basis/windows/fonts/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/windows/fonts/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 9b7cd2e35e..0699c92be3 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1419,7 +1419,7 @@ DESTRUCTOR: DeleteDC ! FUNCTION: DeleteMetaFile FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ; DESTRUCTOR: DeleteObject -! FUNCTION: DescribePixelFormat +FUNCTION: int DescribePixelFormat ( HDC hdc, int iPixelFormat, UINT nBytes, PIXELFORMATDESCRIPTOR* ppfd ) ; ! FUNCTION: DeviceCapabilitiesExA ! FUNCTION: DeviceCapabilitiesExW ! FUNCTION: DPtoLP diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 1a513df186..e654b68bdc 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1110,7 +1110,19 @@ FUNCTION: BOOL FindVolumeMountPointClose ( HANDLE hFindVolumeMountPoint ) ; ! FUNCTION: FoldStringA ! FUNCTION: FoldStringW ! FUNCTION: FormatMessageA -! FUNCTION: FormatMessageW +FUNCTION: DWORD FormatMessageW ( + DWORD dwFlags, + LPCVOID lpSource, + DWORD dwMessageId, + DWORD dwLanguageId, + LPTSTR lpBuffer, + DWORD nSize, + void* Arguments + ) ; + +ALIAS: FormatMessage FormatMessageW + + FUNCTION: BOOL FreeConsole ( ) ; ! FUNCTION: FreeEnvironmentStringsA FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ; diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index e69a9213b0..864700cb0f 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -1,6 +1,6 @@ USING: alien alien.syntax alien.c-types alien.strings math -kernel sequences windows windows.types debugger io accessors -math.order namespaces make math.parser windows.kernel32 +kernel sequences windows.errors windows.types debugger io +accessors math.order namespaces make math.parser windows.kernel32 combinators locals specialized-arrays.direct.uchar ; IN: windows.ole32 @@ -120,7 +120,7 @@ TUPLE: ole32-error error-code ; C: ole32-error M: ole32-error error. - "COM method failed: " print error-code>> (win32-error-string) print ; + "COM method failed: " print error-code>> n>win32-error-string print ; : ole32-error ( hresult -- ) dup succeeded? [ drop ] [ throw ] if ; diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor index d0b396eba2..4173332dc3 100755 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax parser namespaces kernel -math math.bitwise windows.types windows.types init assocs -sequences libc ; +math math.bitwise windows.types init assocs splitting +sequences libc opengl.gl opengl.gl.extensions opengl.gl.windows ; IN: windows.opengl32 ! PIXELFORMATDESCRIPTOR flags @@ -71,22 +71,6 @@ CONSTANT: WGL_SWAP_UNDERLAY13 HEX: 10000000 CONSTANT: WGL_SWAP_UNDERLAY14 HEX: 20000000 CONSTANT: WGL_SWAP_UNDERLAY15 HEX: 40000000 -: windowed-pfd-dwFlags ( -- n ) - { PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ; -: offscreen-pfd-dwFlags ( -- n ) - { PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL } flags ; - -! TODO: compare to http://www.nullterminator.net/opengl32.html -: make-pfd ( flags bits -- pfd ) - "PIXELFORMATDESCRIPTOR" - "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize - 1 over set-PIXELFORMATDESCRIPTOR-nVersion - rot over set-PIXELFORMATDESCRIPTOR-dwFlags - PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType - [ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep - 16 over set-PIXELFORMATDESCRIPTOR-cDepthBits - PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask ; - LIBRARY: gl @@ -100,5 +84,112 @@ LIBRARY: gl FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ; FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ; FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ; -FUNCTION: HGLRC wglGetCurrentContext ( ) ; -FUNCTION: void* wglGetProcAddress ( char* name ) ; + +! WGL_ARB_extensions_string extension + +GL-FUNCTION: char* wglGetExtensionsStringARB { } ( HDC hDC ) ; + +! WGL_ARB_pixel_format extension + +CONSTANT: WGL_NUMBER_PIXEL_FORMATS_ARB HEX: 2000 +CONSTANT: WGL_DRAW_TO_WINDOW_ARB HEX: 2001 +CONSTANT: WGL_DRAW_TO_BITMAP_ARB HEX: 2002 +CONSTANT: WGL_ACCELERATION_ARB HEX: 2003 +CONSTANT: WGL_NEED_PALETTE_ARB HEX: 2004 +CONSTANT: WGL_NEED_SYSTEM_PALETTE_ARB HEX: 2005 +CONSTANT: WGL_SWAP_LAYER_BUFFERS_ARB HEX: 2006 +CONSTANT: WGL_SWAP_METHOD_ARB HEX: 2007 +CONSTANT: WGL_NUMBER_OVERLAYS_ARB HEX: 2008 +CONSTANT: WGL_NUMBER_UNDERLAYS_ARB HEX: 2009 +CONSTANT: WGL_TRANSPARENT_ARB HEX: 200A +CONSTANT: WGL_TRANSPARENT_RED_VALUE_ARB HEX: 2037 +CONSTANT: WGL_TRANSPARENT_GREEN_VALUE_ARB HEX: 2038 +CONSTANT: WGL_TRANSPARENT_BLUE_VALUE_ARB HEX: 2039 +CONSTANT: WGL_TRANSPARENT_ALPHA_VALUE_ARB HEX: 203A +CONSTANT: WGL_TRANSPARENT_INDEX_VALUE_ARB HEX: 203B +CONSTANT: WGL_SHARE_DEPTH_ARB HEX: 200C +CONSTANT: WGL_SHARE_STENCIL_ARB HEX: 200D +CONSTANT: WGL_SHARE_ACCUM_ARB HEX: 200E +CONSTANT: WGL_SUPPORT_GDI_ARB HEX: 200F +CONSTANT: WGL_SUPPORT_OPENGL_ARB HEX: 2010 +CONSTANT: WGL_DOUBLE_BUFFER_ARB HEX: 2011 +CONSTANT: WGL_STEREO_ARB HEX: 2012 +CONSTANT: WGL_PIXEL_TYPE_ARB HEX: 2013 +CONSTANT: WGL_COLOR_BITS_ARB HEX: 2014 +CONSTANT: WGL_RED_BITS_ARB HEX: 2015 +CONSTANT: WGL_RED_SHIFT_ARB HEX: 2016 +CONSTANT: WGL_GREEN_BITS_ARB HEX: 2017 +CONSTANT: WGL_GREEN_SHIFT_ARB HEX: 2018 +CONSTANT: WGL_BLUE_BITS_ARB HEX: 2019 +CONSTANT: WGL_BLUE_SHIFT_ARB HEX: 201A +CONSTANT: WGL_ALPHA_BITS_ARB HEX: 201B +CONSTANT: WGL_ALPHA_SHIFT_ARB HEX: 201C +CONSTANT: WGL_ACCUM_BITS_ARB HEX: 201D +CONSTANT: WGL_ACCUM_RED_BITS_ARB HEX: 201E +CONSTANT: WGL_ACCUM_GREEN_BITS_ARB HEX: 201F +CONSTANT: WGL_ACCUM_BLUE_BITS_ARB HEX: 2020 +CONSTANT: WGL_ACCUM_ALPHA_BITS_ARB HEX: 2021 +CONSTANT: WGL_DEPTH_BITS_ARB HEX: 2022 +CONSTANT: WGL_STENCIL_BITS_ARB HEX: 2023 +CONSTANT: WGL_AUX_BUFFERS_ARB HEX: 2024 + +CONSTANT: WGL_NO_ACCELERATION_ARB HEX: 2025 +CONSTANT: WGL_GENERIC_ACCELERATION_ARB HEX: 2026 +CONSTANT: WGL_FULL_ACCELERATION_ARB HEX: 2027 + +CONSTANT: WGL_SWAP_EXCHANGE_ARB HEX: 2028 +CONSTANT: WGL_SWAP_COPY_ARB HEX: 2029 +CONSTANT: WGL_SWAP_UNDEFINED_ARB HEX: 202A + +CONSTANT: WGL_TYPE_RGBA_ARB HEX: 202B +CONSTANT: WGL_TYPE_COLORINDEX_ARB HEX: 202C + +GL-FUNCTION: BOOL wglGetPixelFormatAttribivARB { } ( + HDC hdc, + int iPixelFormat, + int iLayerPlane, + UINT nAttributes, + int* piAttributes, + int* piValues + ) ; + +GL-FUNCTION: BOOL wglGetPixelFormatAttribfvARB { } ( + HDC hdc, + int iPixelFormat, + int iLayerPlane, + UINT nAttributes, + int* piAttributes, + FLOAT* pfValues + ) ; + +GL-FUNCTION: BOOL wglChoosePixelFormatARB { } ( + HDC hdc, + int* piAttribIList, + FLOAT* pfAttribFList, + UINT nMaxFormats, + int* piFormats, + UINT* nNumFormats + ) ; + +! WGL_ARB_multisample extension + +CONSTANT: WGL_SAMPLE_BUFFERS_ARB HEX: 2041 +CONSTANT: WGL_SAMPLES_ARB HEX: 2042 + +! WGL_ARB_pixel_format_float extension + +CONSTANT: WGL_TYPE_RGBA_FLOAT_ARB HEX: 21A0 + +! wgl extensions querying + +: has-wglGetExtensionsStringARB? ( -- ? ) + "wglGetExtensionsStringARB" wglGetProcAddress >boolean ; + +: wgl-extensions ( hdc -- extensions ) + has-wglGetExtensionsStringARB? [ wglGetExtensionsStringARB " " split ] [ drop { } ] if ; + +: has-wgl-extensions? ( hdc extensions -- ? ) + swap wgl-extensions [ member? ] curry all? ; + +: has-wgl-pixel-format-extension? ( hdc -- ? ) + { "WGL_ARB_pixel_format" } has-wgl-extensions? ; diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor index 7802ceb297..016f5ab149 100644 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax combinators io.encodings.utf16n io.files io.pathnames kernel -windows windows.com windows.com.syntax windows.user32 -windows.ole32 ; +windows.errors windows.com windows.com.syntax windows.user32 +windows.ole32 windows ; IN: windows.shell32 CONSTANT: CSIDL_DESKTOP HEX: 00 diff --git a/basis/windows/time/time.factor b/basis/windows/time/time.factor index e63834d369..71726a554a 100644 --- a/basis/windows/time/time.factor +++ b/basis/windows/time/time.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types kernel math windows windows.kernel32 -namespaces calendar math.bitwise ; +USING: alien alien.c-types kernel math windows.errors +windows.kernel32 namespaces calendar math.bitwise ; IN: windows.time : >64bit ( lo hi -- n ) - 32 shift bitor ; + 32 shift bitor ; inline : windows-1601 ( -- timestamp ) 1601 1 1 0 0 0 instant ; diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 20bae06f30..062196c3f8 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -100,7 +100,7 @@ TYPEDEF: HANDLE HGDIOBJ TYPEDEF: HANDLE HGLOBAL TYPEDEF: HANDLE HHOOK TYPEDEF: HANDLE HINSTANCE -TYPEDEF: HANDLE HKEY +TYPEDEF: DWORD HKEY TYPEDEF: HANDLE HKL TYPEDEF: HANDLE HLOCAL TYPEDEF: HANDLE HMENU diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index fb0c134b9a..feb0bef7a8 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs math sequences fry io.encodings.string io.encodings.utf16n accessors arrays combinators destructors -cache namespaces init fonts alien.c-types windows windows.usp10 +cache namespaces init fonts alien.c-types windows.usp10 windows.offscreen windows.gdi32 windows.ole32 windows.types -windows.fonts opengl.textures locals ; +windows.fonts opengl.textures locals windows.errors ; IN: windows.uniscribe TUPLE: script-string font string metrics ssa size image disposed ; diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor old mode 100644 new mode 100755 index f3bc1becb2..2272695953 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -542,12 +542,46 @@ C-STRUCT: DEV_BROADCAST_HDR { "DWORD" "dbch_size" } { "DWORD" "dbch_devicetype" } { "DWORD" "dbch_reserved" } ; + C-STRUCT: DEV_BROADCAST_DEVICEW { "DWORD" "dbcc_size" } { "DWORD" "dbcc_devicetype" } { "DWORD" "dbcc_reserved" } { "GUID" "dbcc_classguid" } - { "WCHAR[1]" "dbcc_name" } ; + { { "WCHAR" 1 } "dbcc_name" } ; + +CONSTANT: CCHDEVICENAME 32 + +C-STRUCT: MONITORINFOEX + { "DWORD" "cbSize" } + { "RECT" "rcMonitor" } + { "RECT" "rcWork" } + { "DWORD" "dwFlags" } + { { "TCHAR" CCHDEVICENAME } "szDevice" } ; + +TYPEDEF: MONITORINFOEX* LPMONITORINFOEX +TYPEDEF: MONITORINFOEX* LPMONITORINFO + +CONSTANT: MONITOR_DEFAULTTONULL 0 +CONSTANT: MONITOR_DEFAULTTOPRIMARY 1 +CONSTANT: MONITOR_DEFAULTTONEAREST 2 +CONSTANT: MONITORINFOF_PRIMARY 1 +CONSTANT: SWP_NOSIZE 1 +CONSTANT: SWP_NOMOVE 2 +CONSTANT: SWP_NOZORDER 4 +CONSTANT: SWP_NOREDRAW 8 +CONSTANT: SWP_NOACTIVATE 16 +CONSTANT: SWP_FRAMECHANGED 32 +CONSTANT: SWP_SHOWWINDOW 64 +CONSTANT: SWP_HIDEWINDOW 128 +CONSTANT: SWP_NOCOPYBITS 256 +CONSTANT: SWP_NOOWNERZORDER 512 +CONSTANT: SWP_NOSENDCHANGING 1024 +CONSTANT: SWP_DRAWFRAME SWP_FRAMECHANGED +CONSTANT: SWP_NOREPOSITION SWP_NOOWNERZORDER +CONSTANT: SWP_DEFERERASE 8192 +CONSTANT: SWP_ASYNCWINDOWPOS 16384 + LIBRARY: user32 @@ -618,9 +652,9 @@ FUNCTION: HDC BeginPaint ( HWND hwnd, LPPAINTSTRUCT lpPaint ) ; FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ; ! FUNCTION: ChildWindowFromPointEx ! FUNCTION: ClientThreadSetup -! FUNCTION: ClientToScreen +FUNCTION: BOOL ClientToScreen ( HWND hWnd, POINT* point ) ; ! FUNCTION: CliImmSetHotKey -! FUNCTION: ClipCursor +FUNCTION: int ClipCursor ( RECT* clipRect ) ; FUNCTION: BOOL CloseClipboard ( ) ; ! FUNCTION: CloseDesktop ! FUNCTION: CloseWindow @@ -910,7 +944,10 @@ ALIAS: GetMessage GetMessageW ! FUNCTION: GetMessagePos ! FUNCTION: GetMessageTime ! FUNCTION: GetMonitorInfoA -! FUNCTION: GetMonitorInfoW + +FUNCTION: BOOL GetMonitorInfoW ( HMONITOR hMonitor, LPMONITORINFO lpmi ) ; +ALIAS: GetMonitorInfo GetMonitorInfoW + ! FUNCTION: GetMouseMovePointsEx ! FUNCTION: GetNextDlgGroupItem ! FUNCTION: GetNextDlgTabItem @@ -961,6 +998,8 @@ FUNCTION: HWND GetWindow ( HWND hWnd, UINT uCmd ) ; ! FUNCTION: GetWindowInfo ! FUNCTION: GetWindowLongA ! FUNCTION: GetWindowLongW +FUNCTION: LONG_PTR GetWindowLongW ( HANDLE hWnd, int index ) ; +ALIAS: GetWindowLong GetWindowLongW ! FUNCTION: GetWindowModuleFileName ! FUNCTION: GetWindowModuleFileNameA ! FUNCTION: GetWindowModuleFileNameW @@ -1127,7 +1166,7 @@ ALIAS: MessageBoxEx MessageBoxExW ! FUNCTION: ModifyMenuW ! FUNCTION: MonitorFromPoint ! FUNCTION: MonitorFromRect -! FUNCTION: MonitorFromWindow +FUNCTION: HMONITOR MonitorFromWindow ( HWND hWnd, DWORD dwFlags ) ; ! FUNCTION: mouse_event @@ -1303,12 +1342,14 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ; ! FUNCTION: SetWindowContextHelpId ! FUNCTION: SetWindowLongA ! FUNCTION: SetWindowLongW +FUNCTION: LONG_PTR SetWindowLongW ( HANDLE hWnd, int index, LONG_PTR dwNewLong ) ; +ALIAS: SetWindowLong SetWindowLongW ! FUNCTION: SetWindowPlacement FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ; : HWND_BOTTOM ( -- alien ) 1 ; : HWND_NOTOPMOST ( -- alien ) -2 ; -: HWND_TOP ( -- alien ) 0 ; +CONSTANT: HWND_TOP f : HWND_TOPMOST ( -- alien ) -1 ; ! FUNCTION: SetWindowRgn @@ -1322,7 +1363,7 @@ FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int ! FUNCTION: SetWindowWord ! FUNCTION: SetWinEventHook ! FUNCTION: ShowCaret -! FUNCTION: ShowCursor +FUNCTION: int ShowCursor ( BOOL show ) ; ! FUNCTION: ShowOwnedPopups ! FUNCTION: ShowScrollBar ! FUNCTION: ShowStartGlass diff --git a/basis/windows/windows.factor b/basis/windows/windows.factor index 902b1bec8d..92ba8b638a 100755 --- a/basis/windows/windows.factor +++ b/basis/windows/windows.factor @@ -1,61 +1,5 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax alien.c-types alien.strings arrays -combinators kernel math namespaces parser sequences -windows.errors windows.types windows.kernel32 words -io.encodings.utf16n ; IN: windows -: lo-word ( wparam -- lo ) *short ; inline -: hi-word ( wparam -- hi ) -16 shift lo-word ; inline CONSTANT: MAX_UNICODE_PATH 32768 - -! You must LocalFree the return value! -FUNCTION: void* error_message ( DWORD id ) ; - -: (win32-error-string) ( n -- string ) - error_message - dup utf16n alien>string - swap LocalFree drop ; - -: win32-error-string ( -- str ) - GetLastError (win32-error-string) ; - -: (win32-error) ( n -- ) - dup zero? [ - drop - ] [ - win32-error-string throw - ] if ; - -: win32-error ( -- ) - GetLastError (win32-error) ; - -: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ; -: win32-error>0 ( n -- ) 0 > [ win32-error ] when ; -: win32-error<0 ( n -- ) 0 < [ win32-error ] when ; -: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ; - -: invalid-handle? ( handle -- ) - INVALID_HANDLE_VALUE = [ - win32-error-string throw - ] when ; - -: expected-io-errors ( -- seq ) - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT 4array ; foldable - -: expected-io-error? ( error-code -- ? ) - expected-io-errors member? ; - -: expected-io-error ( error-code -- ) - dup expected-io-error? [ - drop - ] [ - (win32-error-string) throw - ] if ; - -: io-error ( return-value -- ) - { 0 f } member? [ GetLastError expected-io-error ] when ; diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 06df74cd4c..f0d32588f5 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax arrays byte-arrays kernel math sequences windows.types windows.kernel32 -windows.errors windows math.bitwise io.encodings.utf16n ; +windows.errors math.bitwise io.encodings.utf16n ; IN: windows.winsock USE: libc @@ -403,7 +403,7 @@ CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090 : (winsock-error-string) ( n -- str ) ! #! WSAStartup returns the error code 'n' directly dup winsock-expected-error? - [ drop f ] [ error_message utf16n alien>string ] if ; + [ drop f ] [ n>win32-error-string ] if ; : winsock-error-string ( -- string/f ) WSAGetLastError (winsock-error-string) ; diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index dc6157b87f..67ac0e8cc1 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -84,20 +84,17 @@ X-FUNCTION: void* glXGetProcAddress ( char* procname ) ; ! GLX_ARB_get_proc_address extension X-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; +! GLX_ARB_multisample +CONSTANT: GLX_SAMPLE_BUFFERS 100000 +CONSTANT: GLX_SAMPLES 100001 + +! GLX_ARB_fbconfig_float +CONSTANT: GLX_RGBA_FLOAT_TYPE HEX: 20B9 +CONSTANT: GLX_RGBA_FLOAT_BIT HEX: 0004 + ! GLX Events ! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks) -: choose-visual ( flags -- XVisualInfo* ) - [ dpy get scr get ] dip - [ - % - GLX_RGBA , - GLX_DEPTH_SIZE , 16 , - 0 , - ] int-array{ } make - glXChooseVisual - [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ; - : create-glx ( XVisualInfo* -- GLXContext ) [ dpy get ] dip f 1 glXCreateContext [ "Failed to create GLX context" throw ] unless* ; diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 37da51e9b8..54cf205c14 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -53,11 +53,8 @@ IN: x11.windows dup ] dip auto-position ; -: glx-window ( loc dim -- window glx ) - GLX_DOUBLEBUFFER 1array choose-visual - [ create-window ] keep - [ create-glx ] keep - XFree ; +: glx-window ( loc dim visual -- window glx ) + [ create-window ] [ create-glx ] bi ; : create-pixmap ( dim visual -- pixmap ) [ [ { 0 0 } swap ] dip create-window ] [ @@ -74,9 +71,8 @@ IN: x11.windows : create-glx-pixmap ( dim visual -- pixmap glx-pixmap ) [ create-pixmap ] [ (create-glx-pixmap) ] bi ; -: glx-pixmap ( dim -- glx pixmap glx-pixmap ) - { } choose-visual - [ nip create-glx ] [ create-glx-pixmap ] [ nip XFree ] 2tri ; +: glx-pixmap ( dim visual -- glx pixmap glx-pixmap ) + [ nip create-glx ] [ create-glx-pixmap ] 2bi ; : destroy-window ( win -- ) dpy get swap XDestroyWindow drop ; diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index fba2eafaba..9df7165e6c 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -143,7 +143,7 @@ PRIVATE> <-> XML] ; :: htmlize-stream ( path stream -- xml ) - stream lines + stream stream-lines [ "" ] [ path over first find-mode htmlize-lines ] if-empty :> input default-stylesheet :> stylesheet diff --git a/build-support/factor.sh b/build-support/factor.sh index 3ece72306a..ba5815cfc1 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -205,7 +205,7 @@ find_architecture() { write_test_program() { echo "#include " > $C_WORD.c - echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c } c_find_word_size() { diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor new file mode 100644 index 0000000000..388b9842db --- /dev/null +++ b/core/alien/strings/strings-docs.factor @@ -0,0 +1,20 @@ +USING: help.markup help.syntax strings byte-arrays alien libc +debugger io.encodings.string sequences ; +IN: alien.strings + +HELP: string>alien +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } } +{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." } +{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ; + +HELP: alien>string +{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } } +{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ; + +HELP: string>symbol +{ $values { "str" string } { "alien" alien } } +{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory." +$nl +"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ; + +ABOUT: "c-strings" diff --git a/basis/alien/strings/strings-tests.factor b/core/alien/strings/strings-tests.factor similarity index 93% rename from basis/alien/strings/strings-tests.factor rename to core/alien/strings/strings-tests.factor index 263453ba1c..6a0a42253b 100644 --- a/basis/alien/strings/strings-tests.factor +++ b/core/alien/strings/strings-tests.factor @@ -1,4 +1,4 @@ -USING: alien.strings tools.test kernel libc +USING: alien.strings alien.c-types tools.test kernel libc io.encodings.8-bit io.encodings.utf8 io.encodings.utf16 io.encodings.utf16n io.encodings.ascii alien io.encodings.string ; IN: alien.strings.tests diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor new file mode 100644 index 0000000000..c74c325726 --- /dev/null +++ b/core/alien/strings/strings.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2008, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays sequences kernel kernel.private accessors math +alien.accessors byte-arrays io io.encodings io.encodings.utf8 +io.encodings.utf16n io.streams.byte-array io.streams.memory system +system.private alien strings combinators namespaces init ; +IN: alien.strings + +GENERIC# alien>string 1 ( c-ptr encoding -- string/f ) + +M: c-ptr alien>string + [ ] [ ] bi* + "\0" swap stream-read-until drop ; + +M: f alien>string + drop ; + +ERROR: invalid-c-string string ; + +: check-string ( string -- ) + 0 over memq? [ invalid-c-string ] [ drop ] if ; + +GENERIC# string>alien 1 ( string encoding -- byte-array ) + +M: c-ptr string>alien drop ; + +M: string string>alien + over check-string + + [ stream-write ] + [ 0 swap stream-write1 ] + [ stream>> >byte-array ] + tri ; + +HOOK: alien>native-string os ( alien -- string ) + +M: windows alien>native-string utf16n alien>string ; + +M: unix alien>native-string utf8 alien>string ; + +HOOK: native-string>alien os ( string -- alien ) + +M: windows native-string>alien utf16n string>alien ; + +M: unix native-string>alien utf8 string>alien ; + +: dll-path ( dll -- string ) + path>> alien>native-string ; + +HOOK: string>symbol* os ( str/seq -- alien ) + +M: winnt string>symbol* utf8 string>alien ; + +M: wince string>symbol* utf16n string>alien ; + +M: unix string>symbol* utf8 string>alien ; + +GENERIC: string>symbol ( str -- alien ) + +M: string string>symbol string>symbol* ; + +M: sequence string>symbol [ string>symbol* ] map ; + +[ + 8 getenv utf8 alien>string string>cpu \ cpu set-global + 9 getenv utf8 alien>string string>os \ os set-global +] "alien.strings" add-init-hook + diff --git a/basis/alien/strings/summary.txt b/core/alien/strings/summary.txt similarity index 100% rename from basis/alien/strings/summary.txt rename to core/alien/strings/summary.txt diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ec56cffff7..e783ef81c4 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -32,7 +32,7 @@ M: assoc assoc-like drop ; 3drop f ] [ 3dup nth-unsafe at* - [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if + [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if ] if ; inline recursive : search-alist ( key alist -- pair/f i/f ) @@ -105,7 +105,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) assoc-size 0 = ; : assoc-stack ( key seq -- value ) - [ length 1- ] keep (assoc-stack) ; flushable + [ length 1 - ] keep (assoc-stack) ; flushable : assoc-subset? ( assoc1 assoc2 -- ? ) [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ; diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 26100277a8..5ed92b7776 100644 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel alien byte-arrays hashtables vectors strings sbufs arrays @@ -9,28 +9,28 @@ BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -17 num-types set +15 num-types set + +32 mega-cache-size set H{ { fixnum BIN: 000 } { bignum BIN: 001 } - { tuple BIN: 010 } - { object BIN: 011 } - { hi-tag BIN: 011 } - { ratio BIN: 100 } - { float BIN: 101 } - { complex BIN: 110 } - { POSTPONE: f BIN: 111 } + { array BIN: 010 } + { float BIN: 011 } + { quotation BIN: 100 } + { POSTPONE: f BIN: 101 } + { object BIN: 110 } + { hi-tag BIN: 110 } + { tuple BIN: 111 } } tag-numbers set tag-numbers get H{ - { array 8 } - { wrapper 9 } - { byte-array 10 } - { callstack 11 } - { string 12 } - { word 13 } - { quotation 14 } - { dll 15 } - { alien 16 } + { wrapper 8 } + { byte-array 9 } + { callstack 10 } + { string 11 } + { word 12 } + { dll 13 } + { alien 14 } } assoc-union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 1258da8a4d..57bc61a005 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math math.private math.order @@ -69,6 +69,8 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" + "generic.single" + "generic.single.private" "growable" "hashtables" "hashtables.private" @@ -80,8 +82,10 @@ bootstrapping? on "kernel" "kernel.private" "math" + "math.parser.private" "math.private" "memory" + "memory.private" "quotations" "quotations.private" "sbufs" @@ -97,7 +101,6 @@ bootstrapping? on "threads.private" "tools.profiler.private" "words" - "words.private" "vectors" "vectors.private" } [ create-vocab drop ] each @@ -125,9 +128,7 @@ bootstrapping? on "fixnum" "math" create register-builtin "bignum" "math" create register-builtin "tuple" "kernel" create register-builtin -"ratio" "math" create register-builtin "float" "math" create register-builtin -"complex" "math" create register-builtin "f" "syntax" lookup register-builtin "array" "arrays" create register-builtin "wrapper" "kernel" create register-builtin @@ -146,24 +147,6 @@ bootstrapping? on "f?" "syntax" vocab-words delete-at ! Some unions -"integer" "math" create -"fixnum" "math" lookup -"bignum" "math" lookup -2array -define-union-class - -"rational" "math" create -"integer" "math" lookup -"ratio" "math" lookup -2array -define-union-class - -"real" "math" create -"rational" "math" lookup -"float" "math" lookup -2array -define-union-class - "c-ptr" "alien" create [ "alien" "alien" lookup , "f" "syntax" lookup , @@ -210,19 +193,9 @@ bi "bignum" "math" create { } define-builtin "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop -"ratio" "math" create { - { "numerator" { "integer" "math" } read-only } - { "denominator" { "integer" "math" } read-only } -} define-builtin - "float" "math" create { } define-builtin "float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop -"complex" "math" create { - { "real" { "real" "math" } read-only } - { "imaginary" { "real" "math" } read-only } -} define-builtin - "array" "arrays" create { { "length" { "array-capacity" "sequences.private" } read-only } } define-builtin @@ -258,7 +231,8 @@ bi "vocabulary" { "def" { "quotation" "quotations" } initial: [ ] } "props" - { "optimized" read-only } + "pic-def" + "pic-tail-def" { "counter" { "fixnum" "math" } } { "sub-primitive" read-only } } define-builtin @@ -338,7 +312,7 @@ tuple [ create dup 1quotation ] dip define-declared ; { - { "(execute)" "words.private" (( word -- )) } + { "(execute)" "kernel.private" (( word -- )) } { "(call)" "kernel.private" (( quot -- )) } { "both-fixnums?" "math.private" (( x y -- ? )) } { "fixnum+fast" "math.private" (( x y -- z )) } @@ -378,6 +352,7 @@ tuple { "get-local" "locals.backend" (( n -- obj )) } { "load-local" "locals.backend" (( obj -- )) } { "drop-locals" "locals.backend" (( n -- )) } + { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) } } [ first3 make-sub-primitive ] each ! Primitive words @@ -394,14 +369,12 @@ tuple { "float>bignum" "math.private" (( x -- y )) } { "fixnum>float" "math.private" (( x -- y )) } { "bignum>float" "math.private" (( x -- y )) } - { "" "math.private" (( a b -- a/b )) } - { "string>float" "math.private" (( str -- n/f )) } - { "float>string" "math.private" (( n -- str )) } + { "(string>float)" "math.parser.private" (( str -- n/f )) } + { "(float>string)" "math.parser.private" (( n -- str )) } { "float>bits" "math" (( x -- n )) } { "double>bits" "math" (( x -- n )) } { "bits>float" "math" (( n -- x )) } { "bits>double" "math" (( n -- x )) } - { "" "math.private" (( x y -- z )) } { "fixnum+" "math.private" (( x y -- z )) } { "fixnum-" "math.private" (( x y -- z )) } { "fixnum*" "math.private" (( x y -- z )) } @@ -444,8 +417,8 @@ tuple { "(exists?)" "io.files.private" (( path -- ? )) } { "gc" "memory" (( -- )) } { "gc-stats" "memory" f } - { "save-image" "memory" (( path -- )) } - { "save-image-and-exit" "memory" (( path -- )) } + { "(save-image)" "memory.private" (( path -- )) } + { "(save-image-and-exit)" "memory.private" (( path -- )) } { "datastack" "kernel" (( -- ds )) } { "retainstack" "kernel" (( -- rs )) } { "callstack" "kernel" (( -- cs )) } @@ -457,38 +430,38 @@ tuple { "code-room" "memory" (( -- code-free code-total )) } { "micros" "system" (( -- us )) } { "modify-code-heap" "compiler.units" (( alist -- )) } - { "dlopen" "alien.libraries" (( path -- dll )) } - { "dlsym" "alien.libraries" (( name dll -- alien )) } + { "(dlopen)" "alien.libraries" (( path -- dll )) } + { "(dlsym)" "alien.libraries" (( name dll -- alien )) } { "dlclose" "alien.libraries" (( dll -- )) } { "" "byte-arrays" (( n -- byte-array )) } { "(byte-array)" "byte-arrays" (( n -- byte-array )) } { "" "alien" (( displacement c-ptr -- alien )) } - { "alien-signed-cell" "alien.accessors" f } - { "set-alien-signed-cell" "alien.accessors" f } - { "alien-unsigned-cell" "alien.accessors" f } - { "set-alien-unsigned-cell" "alien.accessors" f } - { "alien-signed-8" "alien.accessors" f } - { "set-alien-signed-8" "alien.accessors" f } - { "alien-unsigned-8" "alien.accessors" f } - { "set-alien-unsigned-8" "alien.accessors" f } - { "alien-signed-4" "alien.accessors" f } - { "set-alien-signed-4" "alien.accessors" f } - { "alien-unsigned-4" "alien.accessors" f } - { "set-alien-unsigned-4" "alien.accessors" f } - { "alien-signed-2" "alien.accessors" f } - { "set-alien-signed-2" "alien.accessors" f } - { "alien-unsigned-2" "alien.accessors" f } - { "set-alien-unsigned-2" "alien.accessors" f } - { "alien-signed-1" "alien.accessors" f } - { "set-alien-signed-1" "alien.accessors" f } - { "alien-unsigned-1" "alien.accessors" f } - { "set-alien-unsigned-1" "alien.accessors" f } - { "alien-float" "alien.accessors" f } - { "set-alien-float" "alien.accessors" f } - { "alien-double" "alien.accessors" f } - { "set-alien-double" "alien.accessors" f } - { "alien-cell" "alien.accessors" f } - { "set-alien-cell" "alien.accessors" f } + { "alien-signed-cell" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-cell" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-cell" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-cell" "alien.accessors" (( value c-ptr n -- )) } + { "alien-signed-8" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-8" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-8" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-8" "alien.accessors" (( value c-ptr n -- )) } + { "alien-signed-4" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-4" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-4" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-4" "alien.accessors" (( value c-ptr n -- )) } + { "alien-signed-2" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-2" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-2" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-2" "alien.accessors" (( value c-ptr n -- )) } + { "alien-signed-1" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-signed-1" "alien.accessors" (( value c-ptr n -- )) } + { "alien-unsigned-1" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-unsigned-1" "alien.accessors" (( value c-ptr n -- )) } + { "alien-float" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-float" "alien.accessors" (( value c-ptr n -- )) } + { "alien-double" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-double" "alien.accessors" (( value c-ptr n -- )) } + { "alien-cell" "alien.accessors" (( c-ptr n -- value )) } + { "set-alien-cell" "alien.accessors" (( value c-ptr n -- )) } { "alien-address" "alien" (( c-ptr -- addr )) } { "set-slot" "slots.private" (( value obj n -- )) } { "string-nth" "strings.private" (( n string -- ch )) } @@ -502,7 +475,7 @@ tuple { "end-scan" "memory" (( -- )) } { "size" "memory" (( obj -- n )) } { "die" "kernel" (( -- )) } - { "fopen" "io.streams.c" (( path mode -- alien )) } + { "(fopen)" "io.streams.c" (( path mode -- alien )) } { "fgetc" "io.streams.c" (( alien -- ch/f )) } { "fread" "io.streams.c" (( n alien -- str/f )) } { "fputc" "io.streams.c" (( ch alien -- )) } @@ -521,18 +494,27 @@ tuple { "(sleep)" "threads.private" (( us -- )) } { "" "classes.tuple.private" (( ... layout -- tuple )) } { "callstack>array" "kernel" (( callstack -- array )) } - { "innermost-frame-quot" "kernel.private" (( callstack -- quot )) } + { "innermost-frame-executing" "kernel.private" (( callstack -- obj )) } { "innermost-frame-scan" "kernel.private" (( callstack -- n )) } { "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) } { "call-clear" "kernel" (( quot -- )) } { "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) } - { "dll-valid?" "alien" (( dll -- ? )) } + { "dll-valid?" "alien.libraries" (( dll -- ? )) } { "unimplemented" "kernel.private" (( -- * )) } { "gc-reset" "memory" (( -- )) } { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } + { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) } + { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) } + { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) } + { "lookup-method" "generic.single.private" (( object methods -- method )) } + { "reset-dispatch-stats" "generic.single" (( -- )) } + { "dispatch-stats" "generic.single" (( -- stats )) } + { "reset-inline-cache-stats" "generic.single" (( -- )) } + { "inline-cache-stats" "generic.single" (( -- stats )) } + { "optimized?" "words" (( word -- ? )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number -"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared +"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index a0b349be51..55b92df215 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -16,6 +16,7 @@ IN: bootstrap.syntax " ; -SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ; - -M: byte-vector pprint* pprint-object ; -M: byte-vector pprint-delims drop \ BV{ \ } ; -M: byte-vector >pprint-sequence ; - INSTANCE: byte-vector growable diff --git a/basis/byte-vectors/summary.txt b/core/byte-vectors/summary.txt similarity index 100% rename from basis/byte-vectors/summary.txt rename to core/byte-vectors/summary.txt diff --git a/core/byte-vectors/tags.txt b/core/byte-vectors/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/byte-vectors/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 98d36b21c3..82918b6f81 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -13,7 +13,7 @@ GENERIC: checksum-stream ( stream checksum -- value ) GENERIC: checksum-lines ( lines checksum -- value ) M: checksum checksum-stream - [ contents ] dip checksum-bytes ; + [ stream-contents ] dip checksum-bytes ; M: checksum checksum-lines [ B{ CHAR: \n } join ] dip checksum-bytes ; diff --git a/core/checksums/crc32/crc32.factor b/core/checksums/crc32/crc32.factor index 47da144d4d..209de83763 100644 --- a/core/checksums/crc32/crc32.factor +++ b/core/checksums/crc32/crc32.factor @@ -9,15 +9,15 @@ CONSTANT: crc32-polynomial HEX: edb88320 CONSTANT: crc32-table V{ } -256 [ +256 iota [ 8 [ [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless - ] times >bignum + ] times ] map 0 crc32-table copy : (crc32) ( crc ch -- crc ) - >bignum dupd bitxor - mask-byte crc32-table nth-unsafe >bignum + dupd bitxor + mask-byte crc32-table nth-unsafe swap -8 shift bitxor ; inline SINGLETON: crc32 diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index a6af5b8c29..3069c4b555 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -305,7 +305,16 @@ SINGLETON: sc [ sa ] [ sa { sa sb sc } min-class ] unit-test +[ f ] [ sa sb classes-intersect? ] unit-test + [ +lt+ ] [ integer sequence class<=> ] unit-test [ +lt+ ] [ sequence object class<=> ] unit-test [ +gt+ ] [ object sequence class<=> ] unit-test [ +eq+ ] [ integer integer class<=> ] unit-test + +! Limitations: + +! UNION: u1 sa sb ; +! UNION: u2 sc ; + +! [ f ] [ u1 u2 classes-intersect? ] unit-test \ No newline at end of file diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index f95d66fd05..32f7af8113 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -33,13 +33,13 @@ M: lo-tag-class define-builtin-predicate M: hi-tag-class define-builtin-predicate dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation - [ dup tag 3 eq? ] [ [ drop f ] if ] surround + [ dup tag 6 eq? ] [ [ drop f ] if ] surround define-predicate ; M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ; M: hi-tag-class instance? - over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ; + over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ; M: builtin-class (flatten-class) dup set ; diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index cd11591d6c..f44642fdd5 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -119,3 +119,13 @@ MIXIN: move-instance-declaration-mixin [ ] [ "IN: classes.mixin.tests.a" "move-mixin-test-1" parse-stream drop ] unit-test [ { string } ] [ move-instance-declaration-mixin members ] unit-test + +MIXIN: silly-mixin +SYMBOL: not-a-class + +[ [ \ not-a-class \ silly-mixin add-mixin-instance ] with-compilation-unit ] must-fail + +SYMBOL: not-a-mixin +TUPLE: a-class ; + +[ [ \ a-class \ not-a-mixin add-mixin-instance ] with-compilation-unit ] must-fail diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 4bdb893d9a..6cf95716be 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -50,7 +50,9 @@ TUPLE: check-mixin-class class ; [ [ f ] 2dip "instances" word-prop set-at ] 2bi ; -: add-mixin-instance ( class mixin -- ) +GENERIC# add-mixin-instance 1 ( class mixin -- ) + +M: class add-mixin-instance #! Note: we call update-classes on the new member, not the #! mixin. This ensures that we only have to update the #! methods whose specializer intersects the new member, not diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 5e12322a48..85a6249dd3 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -89,11 +89,14 @@ ERROR: bad-literal-tuple ; swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map [ dup ] dip update boa>tuple ; -: parse-tuple-literal ( -- tuple ) - scan-word scan { +: parse-tuple-literal-slots ( class -- tuple ) + scan { { f [ unexpected-eof ] } { "f" [ \ } parse-until boa>tuple ] } { "{" [ parse-slot-values assoc>tuple ] } { "}" [ new ] } [ bad-literal-tuple ] } case ; + +: parse-tuple-literal ( -- tuple ) + scan-word parse-tuple-literal-slots ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index d76faddf15..4c55001aa1 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -254,7 +254,7 @@ ARTICLE: "tuple-examples" "Tuple examples" " } ;" "" ": next-position ( role -- newrole )" - " positions [ index 1+ ] keep nth ;" + " positions [ index 1 + ] keep nth ;" "" ": promote ( employee -- employee )" " [ 1.2 * ] change-salary" diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index c180807b0c..466b221877 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -1,11 +1,11 @@ -USING: definitions generic kernel kernel.private math -math.constants parser sequences tools.test words assocs -namespaces quotations sequences.private classes continuations -generic.standard effects classes.tuple classes.tuple.private -arrays vectors strings compiler.units accessors classes.algebra -calendar prettyprint io.streams.string splitting summary -columns math.order classes.private slots slots.private eval see -words.symbol compiler.errors ; +USING: definitions generic kernel kernel.private math math.constants +parser sequences tools.test words assocs namespaces quotations +sequences.private classes continuations generic.single +generic.standard effects classes.tuple classes.tuple.private arrays +vectors strings compiler.units accessors classes.algebra calendar +prettyprint io.streams.string splitting summary columns math.order +classes.private slots slots.private eval see words.symbol +compiler.errors ; IN: classes.tuple.tests TUPLE: rect x y w h ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index fb1e613b3e..225176f4e5 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -165,7 +165,7 @@ ERROR: bad-superclass class ; { [ , ] [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ] - [ superclasses length 1- , ] + [ superclasses length 1 - , ] [ superclasses [ [ , ] [ hashcode , ] bi ] each ] } cleave ] { } make ; @@ -331,7 +331,7 @@ GENERIC: tuple-hashcode ( n tuple -- x ) M: tuple tuple-hashcode [ - [ class hashcode ] [ tuple-size ] [ ] tri + [ class hashcode ] [ tuple-size iota ] [ ] tri [ rot ] dip [ swapd array-nth hashcode* sequence-hashcode-step ] 2curry each diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor old mode 100644 new mode 100755 index cbef25ac38..1a17e8c1fb --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -62,9 +62,6 @@ $nl ": dip [ ] bi* ;" ": 2dip [ ] [ ] tri* ;" "" - ": slip [ call ] [ ] bi* ;" - ": 2slip [ call ] [ ] [ ] tri* ;" - "" ": nip [ drop ] [ ] bi* ;" ": 2nip [ drop ] [ drop ] [ ] tri* ;" "" @@ -121,7 +118,7 @@ $nl { $subsection both? } { $subsection either? } ; -ARTICLE: "slip-keep-combinators" "Retain stack combinators" +ARTICLE: "retainstack-combinators" "Retain stack combinators" "Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators." $nl "The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:" @@ -129,10 +126,6 @@ $nl { $subsection 2dip } { $subsection 3dip } { $subsection 4dip } -"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:" -{ $subsection slip } -{ $subsection 2slip } -{ $subsection 3slip } "The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:" { $subsection keep } { $subsection 2keep } @@ -259,7 +252,7 @@ ARTICLE: "conditionals" "Conditional combinators" ARTICLE: "dataflow-combinators" "Data flow combinators" "Data flow combinators pass values between quotations:" -{ $subsection "slip-keep-combinators" } +{ $subsection "retainstack-combinators" } { $subsection "cleave-combinators" } { $subsection "spread-combinators" } { $subsection "apply-combinators" } @@ -290,7 +283,6 @@ $nl "The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:" { $subsection call-effect } { $subsection execute-effect } -{ $subsection "call-unsafe" } "The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "." { $subsection "call-unsafe" } { $see-also "effects" "inference" } ; @@ -306,6 +298,7 @@ ARTICLE: "combinators" "Combinators" { $subsection "combinators.smart" } "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." { $subsection "combinators-quot" } +{ $subsection "generalizations" } { $see-also "quotations" } ; ABOUT: "combinators" diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor old mode 100644 new mode 100755 index dd5fa06031..aae6618ee8 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -16,12 +16,12 @@ IN: combinators.tests : compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ; -[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test +[ t ] [ \ compile-execute(-test-1 optimized? ] unit-test [ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test : compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ; -[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test +[ t ] [ \ compile-execute(-test-2 optimized? ] unit-test [ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test [ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test [ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test @@ -29,7 +29,7 @@ IN: combinators.tests : compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ; -[ t ] [ \ compile-call(-test-1 optimized>> ] unit-test +[ t ] [ \ compile-call(-test-1 optimized? ] unit-test [ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test [ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test [ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test @@ -352,7 +352,7 @@ DEFER: corner-case-1 << \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >> -[ t ] [ \ corner-case-1 optimized>> ] unit-test +[ t ] [ \ corner-case-1 optimized? ] unit-test [ 4 ] [ 2 corner-case-1 ] unit-test [ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 1438edf3fa..7bf76fea30 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -123,7 +123,7 @@ ERROR: no-case object ; [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ; : hash-dispatch-quot ( table -- quot ) - [ length 1- [ fixnum-bitand ] curry ] keep + [ length 1 - [ fixnum-bitand ] curry ] keep [ dispatch ] curry append ; : hash-case-quot ( default assoc -- quot ) @@ -162,7 +162,7 @@ ERROR: no-case object ; ! recursive-hashcode : recursive-hashcode ( n obj quot -- code ) - pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline + pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline ! These go here, not in sequences and hashtables, since those ! two cannot depend on us diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index da2dce128f..8dce12f411 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -19,7 +19,7 @@ IN: compiler.units.tests ] unit-test [ "A" "B" ] [ - disable-compiler + disable-optimizer gensym "a" set gensym "b" set @@ -33,7 +33,7 @@ IN: compiler.units.tests ] with-compilation-unit "b" get execute - enable-compiler + enable-optimizer ] unit-test ! Check that we notify observers diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index c4a137b2ba..f1f9131f08 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -43,6 +43,9 @@ HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler M: f recompile [ dup def>> ] { } map>assoc ; +: without-optimizer ( quot -- ) + [ f compiler-impl ] dip with-variable ; inline + ! Trivial compiler. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. SINGLETON: dummy-compiler @@ -58,6 +61,10 @@ GENERIC: definitions-changed ( assoc obj -- ) [ V{ } clone definition-observers set-global ] "compiler.units" add-init-hook +! This goes here because vocabs cannot depend on init +[ V{ } clone vocab-observers set-global ] +"vocabs" add-init-hook + : add-definition-observer ( obj -- ) definition-observers get push ; diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 2c91981f13..fa8ecbe385 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -79,7 +79,6 @@ $nl { $subsection continue-with } "Continuations as control-flow:" { $subsection attempt-all } -{ $subsection retry } { $subsection with-return } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -232,21 +231,6 @@ HELP: attempt-all } } ; -HELP: retry -{ $values - { "quot" quotation } { "n" integer } -} -{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." } -{ $examples - "Try to get a 0 as a random number:" - { $unchecked-example "USING: continuations math prettyprint random ;" - "[ 5 random 0 = ] 5 retry" - "t" - } -} ; - -{ attempt-all retry } related-words - HELP: return { $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index f4eeeefb77..a2617d0ebb 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -4,7 +4,7 @@ kernel.private accessors eval ; IN: continuations.tests : (callcc1-test) ( n obj -- n' obj ) - [ 1- dup ] dip ?push + [ 1 - dup ] dip ?push over 0 = [ "test-cc" get continue-with ] when (callcc1-test) ; @@ -64,7 +64,7 @@ IN: continuations.tests [ 1 2 ] [ bar ] unit-test -[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test +[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 56ac4a71e9..7681c2b089 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -155,8 +155,6 @@ ERROR: attempt-all-error ; ] { } make peek swap [ rethrow ] when ] if ; inline -: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline - TUPLE: condition error restarts continuation ; C: condition ( error restarts cc -- condition ) diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index 495aeb39c1..38b8ab4dad 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -42,8 +42,15 @@ HELP: effect-height { $description "Outputs the number of objects added to the data stack by the stack effect. This will be negative if the stack effect only removes objects from the stack." } ; HELP: effect<= -{ $values { "eff1" effect } { "eff2" effect } { "?" "a boolean" } } -{ $description "Tests if " { $snippet "eff1" } " is substitutable for " { $snippet "eff2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ; +{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "effect1" } " is substitutable for " { $snippet "effect2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ; + +HELP: effect= +{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "effect1" } " and " { $snippet "effect2" } " represent the same stack transformation, without looking parameter names." } +{ $examples + { $example "USING: effects prettyprint ;" "(( a -- b )) (( x -- y )) effect= ." "t" } +} ; HELP: effect>string { $values { "obj" object } { "str" string } } diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 316add54c0..3eb9273859 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -18,4 +18,8 @@ USING: effects tools.test prettyprint accessors sequences ; [ { "x" "y" } ] [ { "y" "x" } (( a b -- b a )) shuffle ] unit-test [ { "y" "x" "y" } ] [ { "y" "x" } (( a b -- a b a )) shuffle ] unit-test -[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test \ No newline at end of file +[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test + +[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test +[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test +[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test \ No newline at end of file diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 142b9120a8..cab1e531b7 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser namespaces make sequences strings +USING: kernel math math.parser math.order namespaces make sequences strings words assocs combinators accessors arrays ; IN: effects @@ -13,7 +13,7 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ; : effect-height ( effect -- n ) [ out>> length ] [ in>> length ] bi - ; inline -: effect<= ( eff1 eff2 -- ? ) +: effect<= ( effect1 effect2 -- ? ) { { [ over terminated?>> ] [ t ] } { [ dup terminated?>> ] [ f ] } @@ -22,6 +22,12 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ; [ t ] } cond 2nip ; inline +: effect= ( effect1 effect2 -- ? ) + [ [ in>> length ] bi@ = ] + [ [ out>> length ] bi@ = ] + [ [ terminated?>> ] bi@ = ] + 2tri and and ; + GENERIC: effect>string ( obj -- str ) M: string effect>string ; M: object effect>string drop "object" ; @@ -66,3 +72,13 @@ M: effect clone : add-effect-input ( effect -- effect' ) [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ; + +: compose-effects ( effect1 effect2 -- effect' ) + over terminated?>> [ + drop + ] [ + [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ] + [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ] + [ nip terminated?>> ] 2tri + effect boa + ] if ; inline diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index e8b5e6d69c..73002a5d89 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -1,6 +1,7 @@ USING: help.markup help.syntax words classes classes.algebra definitions kernel alien sequences math quotations -generic.standard generic.math combinators prettyprint effects ; +generic.single generic.standard generic.hook generic.math +combinators prettyprint effects ; IN: generic ARTICLE: "method-order" "Method precedence" diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e7ae583aa6..a63cab1c5c 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -96,15 +96,6 @@ M: shit big-generic-test "shit" ; [ t ] [ \ + math-generic? ] unit-test -! Test math-combination -[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test -[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test -[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test -[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test -[ number ] [ \ number \ float math-class-max ] unit-test -[ float ] [ \ real \ float math-class-max ] unit-test -[ fixnum ] [ \ fixnum \ null math-class-max ] unit-test - ! Regression TUPLE: first-one ; TUPLE: second-one ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 965be91642..4b398f6532 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -164,8 +164,8 @@ M: sequence update-methods ( class seq -- ) drop 2dup [ "combination" word-prop ] dip = [ 2drop ] [ { + [ drop reset-generic ] [ "combination" set-word-prop ] - [ drop "methods" word-prop values forget-all ] [ drop H{ } clone "methods" set-word-prop ] [ define-default-method ] } diff --git a/core/generic/hook/authors.txt b/core/generic/hook/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/hook/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/hook/hook-docs.factor b/core/generic/hook/hook-docs.factor new file mode 100644 index 0000000000..9b57d941c0 --- /dev/null +++ b/core/generic/hook/hook-docs.factor @@ -0,0 +1,10 @@ +USING: generic generic.single generic.standard help.markup help.syntax sequences math +math.parser effects ; +IN: generic.hook + +HELP: hook-combination +{ $class-description + "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." +} ; + +{ standard-combination hook-combination } related-words \ No newline at end of file diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor new file mode 100644 index 0000000000..5edbc54bd8 --- /dev/null +++ b/core/generic/hook/hook.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors definitions generic generic.single +generic.single.private kernel namespaces words kernel.private +quotations sequences ; +IN: generic.hook + +TUPLE: hook-combination < single-combination var ; + +C: hook-combination + +PREDICATE: hook-generic < generic + "combination" word-prop hook-combination? ; + +M: hook-combination picker + combination get var>> [ get ] curry ; + +M: hook-combination dispatch# drop 0 ; + +M: hook-combination mega-cache-quot + 1quotation picker [ lookup-method (execute) ] surround ; + +M: hook-generic definer drop \ HOOK: f ; + +M: hook-generic effective-method + [ "combination" word-prop var>> get ] keep (effective-method) ; \ No newline at end of file diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor index 60fa745339..7d7d6e725b 100644 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -1,5 +1,5 @@ USING: kernel generic help.markup help.syntax math classes -sequences quotations ; +sequences quotations generic.math.private ; IN: generic.math HELP: math-upgrade diff --git a/core/generic/math/math-tests.factor b/core/generic/math/math-tests.factor new file mode 100644 index 0000000000..51e122431c --- /dev/null +++ b/core/generic/math/math-tests.factor @@ -0,0 +1,21 @@ +IN: generic.math.tests +USING: generic.math math tools.test kernel ; + +! Test math-combination +[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test +[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test +[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test +[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test + +[ number ] [ number float math-class-max ] unit-test +[ number ] [ float number math-class-max ] unit-test +[ float ] [ real float math-class-max ] unit-test +[ float ] [ float real math-class-max ] unit-test +[ fixnum ] [ fixnum null math-class-max ] unit-test +[ fixnum ] [ null fixnum math-class-max ] unit-test +[ bignum ] [ fixnum bignum math-class-max ] unit-test +[ bignum ] [ bignum fixnum math-class-max ] unit-test +[ number ] [ fixnum number math-class-max ] unit-test +[ number ] [ number fixnum math-class-max ] unit-test + + diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 8d4610dabe..c96050ad03 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math -namespaces make sequences words quotations layouts combinators +namespaces sequences words quotations layouts combinators sequences.private classes classes.builtin classes.algebra -definitions math.order math.private ; +definitions math.order math.private assocs ; IN: generic.math PREDICATE: math-class < class @@ -13,24 +13,30 @@ PREDICATE: math-class < class number bootstrap-word class<= ] if ; + ( class1 class2 -- class ) - [ math-precedence ] compare +gt+ eq? ; +: bootstrap-words ( classes -- classes' ) + [ bootstrap-word ] map ; -: math-class-max ( class1 class2 -- class ) - [ math-class<=> ] most ; +: math-precedence ( class -- pair ) + [ + { fixnum integer rational real number object } bootstrap-words + swap [ swap class<= ] curry find drop -1 or + ] [ + { fixnum bignum ratio float complex object } bootstrap-words + swap [ class<= ] curry find drop -1 or + ] bi 2array ; : (math-upgrade) ( max class -- quot ) dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ; +PRIVATE> + +: math-class-max ( class1 class2 -- class ) + [ [ math-precedence ] bi@ after? ] most ; + : math-upgrade ( class1 class2 -- quot ) [ math-class-max ] 2keep [ @@ -44,33 +50,57 @@ ERROR: no-math-method left right generic ; : default-math-method ( generic -- quot ) [ no-math-method ] curry [ ] like ; + + : object-method ( generic -- quot ) object bootstrap-word applicable-method ; : math-method ( word class1 class2 -- quot ) 2dup and [ - [ - 2dup 2array , \ declare , - 2dup math-upgrade % - math-class-max over order min-class applicable-method % - ] [ ] make + [ 2array [ declare ] curry nip ] + [ math-upgrade nip ] + [ math-class-max over order min-class applicable-method ] + 3tri 3append ] [ 2drop object-method ] if ; -SYMBOL: picker +class ] prepose map , ] bi* - \ dispatch , - ] [ ] make ; inline +SYMBOL: generic-word + +: make-math-method-table ( classes quot: ( class -- quot ) -- alist ) + [ bootstrap-words ] dip + [ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline + +: math-alist>quot ( alist -- quot ) + [ generic-word get object-method ] dip alist>quot ; + +: tag-dispatch-entry ( tag picker -- quot ) + [ "type" word-prop 1quotation [ tag ] [ eq? ] surround ] dip prepend ; + +: tag-dispatch ( picker alist -- alist' ) + swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; + +: tuple-dispatch-entry ( class picker -- quot ) + [ 1quotation [ { tuple } declare class ] [ eq? ] surround ] dip prepend ; + +: tuple-dispatch ( picker alist -- alist' ) + swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; + +: math-dispatch-step ( picker quot: ( class -- quot ) -- quot ) + [ [ { bignum float fixnum } ] dip make-math-method-table ] + [ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi + tuple swap 2array prefix tag-dispatch ; inline + +PRIVATE> SINGLETON: math-combination @@ -78,20 +108,21 @@ M: math-combination make-default-method drop default-math-method ; M: math-combination perform-combination - drop - dup - [ - [ 2dup both-fixnums? ] % - dup fixnum bootstrap-word dup math-method , - \ over [ - dup math-class? [ - \ dup [ [ 2dup ] dip math-method ] math-vtable - ] [ - over object-method - ] if nip - ] math-vtable nip , - \ if , - ] [ ] make define ; + drop dup generic-word [ + dup + [ fixnum bootstrap-word dup math-method ] + [ + [ over ] [ + dup math-class? [ + [ dup ] [ math-method ] with with math-dispatch-step + ] [ + drop object-method + ] if + ] with math-dispatch-step + ] bi + [ if ] 2curry [ 2dup both-fixnums? ] prepend + define + ] with-variable ; PREDICATE: math-generic < generic ( word -- ? ) "combination" word-prop math-combination? ; diff --git a/core/generic/single/authors.txt b/core/generic/single/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/single/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/single/single-docs.factor b/core/generic/single/single-docs.factor new file mode 100644 index 0000000000..8f81be762c --- /dev/null +++ b/core/generic/single/single-docs.factor @@ -0,0 +1,27 @@ +USING: generic help.markup help.syntax sequences math +math.parser effects ; +IN: generic.single + +HELP: no-method +{ $values { "object" "an object" } { "generic" "a generic word" } } +{ $description "Throws a " { $link no-method } " error." } +{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; + +HELP: inconsistent-next-method +{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } +{ $examples + "The following code throws this error:" + { $code + "GENERIC: error-test ( object -- )" + "" + "M: string error-test print ;" + "" + "M: integer error-test number>string call-next-method ;" + "" + "123 error-test" + } + "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." + $nl + "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" + { $code "M: integer error-test number>string error-test ;" } +} ; \ No newline at end of file diff --git a/core/generic/standard/standard-tests.factor b/core/generic/single/single-tests.factor similarity index 88% rename from core/generic/standard/standard-tests.factor rename to core/generic/single/single-tests.factor index 58007f795f..e48d404b92 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/single/single-tests.factor @@ -1,11 +1,10 @@ -IN: generic.standard.tests -USING: tools.test math math.functions math.constants -generic.standard strings sequences arrays kernel accessors words -specialized-arrays.double byte-arrays bit-arrays parser -namespaces make quotations stack-checker vectors growable -hashtables sbufs prettyprint byte-vectors bit-vectors -specialized-vectors.double definitions generic sets graphs assocs -grouping see ; +IN: generic.single.tests +USING: tools.test math math.functions math.constants generic.standard +generic.single strings sequences arrays kernel accessors words +specialized-arrays.double byte-arrays bit-arrays parser namespaces +make quotations stack-checker vectors growable hashtables sbufs +prettyprint byte-vectors bit-vectors specialized-vectors.double +definitions generic sets graphs assocs grouping see eval ; GENERIC: lo-tag-test ( obj -- obj' ) @@ -249,23 +248,6 @@ M: string my-hook "a string" ; [ "a string" ] [ my-hook my-var set my-hook ] unit-test [ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with -HOOK: my-tuple-hook my-var ( -- x ) - -M: sequence my-tuple-hook my-hook ; - -TUPLE: m-t-h-a ; - -M: m-t-h-a my-tuple-hook "foo" ; - -TUPLE: m-t-h-b < m-t-h-a ; - -M: m-t-h-b my-tuple-hook "bar" ; - -[ f ] [ - \ my-tuple-hook [ "engines" word-prop ] keep prefix - [ 1quotation infer ] map all-equal? -] unit-test - HOOK: call-next-hooker my-var ( -- x ) M: sequence call-next-hooker "sequence" ; @@ -281,9 +263,15 @@ M: growable call-next-hooker call-next-method "growable " prepend ; ] unit-test [ t ] [ - { } \ nth effective-method nip \ sequence \ nth method eq? + { } \ nth effective-method nip M\ sequence nth eq? ] unit-test [ t ] [ \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and ] unit-test + +[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test +[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test + +[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test +[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test \ No newline at end of file diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor new file mode 100644 index 0000000000..8d84b21bf7 --- /dev/null +++ b/core/generic/single/single.factor @@ -0,0 +1,260 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes classes.algebra +combinators definitions generic hashtables kernel +kernel.private layouts math namespaces quotations +sequences words generic.single.private effects make ; +IN: generic.single + +ERROR: no-method object generic ; + +ERROR: inconsistent-next-method class generic ; + +TUPLE: single-combination ; + +PREDICATE: single-generic < generic + "combination" word-prop single-combination? ; + +GENERIC: dispatch# ( word -- n ) + +M: generic dispatch# "combination" word-prop dispatch# ; + +SYMBOL: assumed +SYMBOL: default +SYMBOL: generic-word +SYMBOL: combination + +: with-combination ( combination quot -- ) + [ combination ] dip with-variable ; inline + +HOOK: picker combination ( -- quot ) + +M: single-combination next-method-quot* ( class generic combination -- quot ) + [ + 2dup next-method dup [ + [ + pick "predicate" word-prop % + 1quotation , + [ inconsistent-next-method ] 2curry , + \ if , + ] [ ] make picker prepend + ] [ 3drop f ] if + ] with-combination ; + +: (effective-method) ( obj word -- method ) + [ [ order [ instance? ] with find-last nip ] keep method ] + [ "default-method" word-prop ] + bi or ; + +M: single-combination make-default-method + [ [ picker ] dip [ no-method ] curry append ] with-combination ; + +! ! ! Build an engine ! ! ! + +: find-default ( methods -- default ) + #! Side-effects methods. + [ object bootstrap-word ] dip delete-at* [ + drop generic-word get "default-method" word-prop + ] unless ; + +! 1. Flatten methods +TUPLE: predicate-engine methods ; + +: ( methods -- engine ) predicate-engine boa ; + +: push-method ( method specializer atomic assoc -- ) + [ + [ H{ } clone ] unless* + [ methods>> set-at ] keep + ] change-at ; + +: flatten-method ( class method assoc -- ) + [ [ flatten-class keys ] keep ] 2dip [ + [ spin ] dip push-method + ] 3curry each ; + +: flatten-methods ( assoc -- assoc' ) + H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; + +! 2. Convert methods +: split-methods ( assoc class -- first second ) + [ [ nip class<= not ] curry assoc-filter ] + [ [ nip class<= ] curry assoc-filter ] 2bi ; + +: convert-methods ( assoc class word -- assoc' ) + over [ split-methods ] 2dip pick assoc-empty? + [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline + +! 2.1 Convert tuple methods +TUPLE: echelon-dispatch-engine n methods ; + +C: echelon-dispatch-engine + +TUPLE: tuple-dispatch-engine echelons ; + +: push-echelon ( class method assoc -- ) + [ swap dup "layout" word-prop third ] dip + [ ?set-at ] change-at ; + +: echelon-sort ( assoc -- assoc' ) + #! Convert an assoc mapping classes to methods into an + #! assoc mapping echelons to assocs. The first echelon + #! is always there + H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ; + +: ( methods -- engine ) + echelon-sort + [ dupd ] assoc-map + \ tuple-dispatch-engine boa ; + +: convert-tuple-methods ( assoc -- assoc' ) + tuple bootstrap-word + \ convert-methods ; + +! 2.2 Convert hi-tag methods +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ convert-methods ; + +! 3 Tag methods +TUPLE: tag-dispatch-engine methods ; + +C: tag-dispatch-engine + +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; + +! ! ! Compile engine ! ! ! +GENERIC: compile-engine ( engine -- obj ) + +: compile-engines ( assoc -- assoc' ) + [ compile-engine ] assoc-map ; + +: compile-engines* ( assoc -- assoc' ) + [ over assumed [ compile-engine ] with-variable ] assoc-map ; + +: direct-dispatch-table ( assoc n -- table ) + default get [ swap update ] keep ; + +: lo-tag-number ( class -- n ) + "type" word-prop dup num-tags get member? + [ drop object tag-number ] unless ; + +M: tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ lo-tag-number ] dip ] assoc-map + num-tags get direct-dispatch-table ; + +: num-hi-tags ( -- n ) num-types get num-tags get - ; + +: hi-tag-number ( class -- n ) "type" word-prop ; + +M: hi-tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ hi-tag-number num-tags get - ] dip ] assoc-map + num-hi-tags direct-dispatch-table ; + +: build-fast-hash ( methods -- buckets ) + >alist V{ } clone [ hashcode 1array ] distribute-buckets + [ compile-engines* >alist { } join ] map ; + +M: echelon-dispatch-engine compile-engine + dup n>> 0 = [ + methods>> dup assoc-size { + { 0 [ drop default get ] } + { 1 [ >alist first second compile-engine ] } + } case + ] [ + methods>> compile-engines* build-fast-hash + ] if ; + +M: tuple-dispatch-engine compile-engine + tuple assumed [ + echelons>> compile-engines + dup keys supremum 1 + f + [ swap update ] keep + ] with-variable ; + +: sort-methods ( assoc -- assoc' ) + >alist [ keys sort-classes ] keep extract-keys ; + +: quote-methods ( assoc -- assoc' ) + [ 1quotation \ drop prefix ] assoc-map ; + +: methods-with-default ( engine -- assoc ) + methods>> clone default get object bootstrap-word pick set-at ; + +: keep-going? ( assoc -- ? ) + assumed get swap second first class<= ; + +: prune-redundant-predicates ( assoc -- default assoc' ) + { + { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } + { [ dup length 1 = ] [ first second { } ] } + { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } + [ [ first second ] [ rest-slice ] bi ] + } cond ; + +: class-predicates ( assoc -- assoc ) + [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ; + +PREDICATE: predicate-engine-word < word "owner-generic" word-prop ; + +: ( -- word ) + generic-word get name>> "/predicate-engine" append f + dup generic-word get "owner-generic" set-word-prop ; + +M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ; + +: define-predicate-engine ( alist -- word ) + [ ] dip + [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ; + +M: predicate-engine compile-engine + methods-with-default + sort-methods + quote-methods + prune-redundant-predicates + class-predicates + [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ; + +M: word compile-engine ; + +M: f compile-engine ; + +: build-decision-tree ( generic -- methods ) + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] + [ + "methods" word-prop clone + [ find-default default set ] + [ compile-engine ] bi + ] tri ; + +HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f ) + +M: single-combination inline-cache-quots 2drop f f ; + +: define-inline-cache-quot ( word methods -- ) + [ drop ] [ inline-cache-quots ] 2bi + [ >>pic-def ] [ >>pic-tail-def ] bi* + drop ; + +HOOK: mega-cache-quot combination ( methods -- quot/f ) + +M: single-combination perform-combination + [ + dup generic-word set + dup build-decision-tree + [ "decision-tree" set-word-prop ] + [ mega-cache-quot define ] + [ define-inline-cache-quot ] + 2tri + ] with-combination ; diff --git a/core/generic/standard/authors.txt b/core/generic/standard/authors.txt index 1901f27a24..d4f5d6b3ae 100644 --- a/core/generic/standard/authors.txt +++ b/core/generic/standard/authors.txt @@ -1 +1 @@ -Slava Pestov +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor deleted file mode 100644 index b6cb9fc9f7..0000000000 --- a/core/generic/standard/engines/engines.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel kernel.private namespaces quotations -generic math sequences combinators words classes.algebra arrays -; -IN: generic.standard.engines - -SYMBOL: default -SYMBOL: assumed -SYMBOL: (dispatch#) - -GENERIC: engine>quot ( engine -- quot ) - -: engines>quots ( assoc -- assoc' ) - [ engine>quot ] assoc-map ; - -: engines>quots* ( assoc -- assoc' ) - [ over assumed [ engine>quot ] with-variable ] assoc-map ; - -: if-small? ( assoc true false -- ) - [ dup assoc-size 4 <= ] 2dip if ; inline - -: linear-dispatch-quot ( alist -- quot ) - default get [ drop ] prepend swap - [ - [ [ dup ] swap [ eq? ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: split-methods ( assoc class -- first second ) - [ [ nip class<= not ] curry assoc-filter ] - [ [ nip class<= ] curry assoc-filter ] 2bi ; - -: convert-methods ( assoc class word -- assoc' ) - over [ split-methods ] 2dip pick assoc-empty? [ - 3drop - ] [ - [ execute ] dip pick set-at - ] if ; inline - -: (picker) ( n -- quot ) - { - { 0 [ [ dup ] ] } - { 1 [ [ over ] ] } - { 2 [ [ pick ] ] } - [ 1- (picker) [ dip swap ] curry ] - } case ; - -: picker ( -- quot ) \ (dispatch#) get (picker) ; - -GENERIC: extra-values ( generic -- n ) diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor deleted file mode 100644 index 152b112c2a..0000000000 --- a/core/generic/standard/engines/predicate/predicate.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: generic.standard.engines generic namespaces kernel -kernel.private sequences classes.algebra accessors words -combinators assocs arrays ; -IN: generic.standard.engines.predicate - -TUPLE: predicate-dispatch-engine methods ; - -C: predicate-dispatch-engine - -: class-predicates ( assoc -- assoc ) - [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; - -: keep-going? ( assoc -- ? ) - assumed get swap second first class<= ; - -: prune-redundant-predicates ( assoc -- default assoc' ) - { - { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } - { [ dup length 1 = ] [ first second { } ] } - { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } - [ [ first second ] [ rest-slice ] bi ] - } cond ; - -: sort-methods ( assoc -- assoc' ) - >alist [ keys sort-classes ] keep extract-keys ; - -: methods-with-default ( engine -- assoc ) - methods>> clone default get object bootstrap-word pick set-at ; - -M: predicate-dispatch-engine engine>quot - methods-with-default - engines>quots - sort-methods - prune-redundant-predicates - class-predicates - alist>quot ; diff --git a/core/generic/standard/engines/predicate/summary.txt b/core/generic/standard/engines/predicate/summary.txt deleted file mode 100644 index 47fee09ee5..0000000000 --- a/core/generic/standard/engines/predicate/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Chained-conditional dispatch strategy diff --git a/core/generic/standard/engines/summary.txt b/core/generic/standard/engines/summary.txt deleted file mode 100644 index 209190799b..0000000000 --- a/core/generic/standard/engines/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Generic word dispatch strategy implementation diff --git a/core/generic/standard/engines/tag/summary.txt b/core/generic/standard/engines/tag/summary.txt deleted file mode 100644 index 3eea4b11cf..0000000000 --- a/core/generic/standard/engines/tag/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Jump table keyed by pointer tag dispatch strategy diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor deleted file mode 100644 index 5ed33009c0..0000000000 --- a/core/generic/standard/engines/tag/tag.factor +++ /dev/null @@ -1,71 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: classes.private generic.standard.engines namespaces make -arrays assocs sequences.private quotations kernel.private -math slots.private math.private kernel accessors words -layouts sorting sequences combinators ; -IN: generic.standard.engines.tag - -TUPLE: lo-tag-dispatch-engine methods ; - -C: lo-tag-dispatch-engine - -: direct-dispatch-quot ( alist n -- quot ) - default get - [ swap update ] keep - [ dispatch ] curry >quotation ; - -: lo-tag-number ( class -- n ) - dup \ hi-tag bootstrap-word eq? [ - drop \ hi-tag tag-number - ] [ - "type" word-prop - ] if ; - -: sort-tags ( assoc -- alist ) >alist sort-keys reverse ; - -: tag-dispatch-test ( tag# -- quot ) - picker [ tag ] append swap [ eq? ] curry append ; - -: tag-dispatch-quot ( alist -- quot ) - [ default get ] dip - [ [ tag-dispatch-test ] dip ] assoc-map - alist>quot ; - -M: lo-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ lo-tag-number ] dip ] assoc-map - [ - [ sort-tags tag-dispatch-quot ] - [ picker % [ tag ] % num-tags get direct-dispatch-quot ] - if-small? % - ] [ ] make ; - -TUPLE: hi-tag-dispatch-engine methods ; - -C: hi-tag-dispatch-engine - -: convert-hi-tag-methods ( assoc -- assoc' ) - \ hi-tag bootstrap-word - \ convert-methods ; - -: num-hi-tags ( -- n ) num-types get num-tags get - ; - -: hi-tag-number ( class -- n ) - "type" word-prop ; - -: hi-tag-quot ( -- quot ) - \ hi-tag def>> ; - -M: hi-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ hi-tag-number ] dip ] assoc-map - [ - picker % hi-tag-quot % [ - sort-tags linear-dispatch-quot - ] [ - num-tags get , \ fixnum-fast , - [ [ num-tags get - ] dip ] assoc-map - num-hi-tags direct-dispatch-quot - ] if-small? % - ] [ ] make ; diff --git a/core/generic/standard/engines/tuple/summary.txt b/core/generic/standard/engines/tuple/summary.txt deleted file mode 100644 index cb18ac5c78..0000000000 --- a/core/generic/standard/engines/tuple/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Tuple class dispatch strategy diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor deleted file mode 100644 index a0711af095..0000000000 --- a/core/generic/standard/engines/tuple/tuple.factor +++ /dev/null @@ -1,167 +0,0 @@ -! Copyright (c) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes.tuple.private hashtables assocs sorting -accessors combinators sequences slots.private math.parser words -effects namespaces make generic generic.standard.engines -classes.algebra math math.private kernel.private -quotations arrays definitions ; -IN: generic.standard.engines.tuple - -: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline - -: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline - -: tuple-layout% ( -- ) - [ { tuple } declare 1 slot { array } declare ] % ; inline - -: tuple-layout-echelon% ( -- ) - [ 4 slot ] % ; inline - -TUPLE: echelon-dispatch-engine n methods ; - -C: echelon-dispatch-engine - -TUPLE: trivial-tuple-dispatch-engine n methods ; - -C: trivial-tuple-dispatch-engine - -TUPLE: tuple-dispatch-engine echelons ; - -: push-echelon ( class method assoc -- ) - [ swap dup "layout" word-prop third ] dip - [ ?set-at ] change-at ; - -: echelon-sort ( assoc -- assoc' ) - V{ } clone [ - [ - push-echelon - ] curry assoc-each - ] keep sort-keys ; - -: ( methods -- engine ) - echelon-sort - [ dupd ] assoc-map - \ tuple-dispatch-engine boa ; - -: convert-tuple-methods ( assoc -- assoc' ) - tuple bootstrap-word - \ convert-methods ; - -M: trivial-tuple-dispatch-engine engine>quot - [ n>> ] [ methods>> ] bi dup assoc-empty? [ - 2drop default get [ drop ] prepend - ] [ - [ - [ nth-superclass% ] - [ engines>quots* linear-dispatch-quot % ] bi* - ] [ ] make - ] if ; - -: hash-methods ( n methods -- buckets ) - >alist V{ } clone [ hashcode 1array ] distribute-buckets - [ ] with map ; - -: class-hash-dispatch-quot ( n methods -- quot ) - [ - \ dup , - [ drop nth-hashcode% ] - [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi - ] [ ] make ; - -: engine-word-name ( -- string ) - generic get name>> "/tuple-dispatch-engine" append ; - -PREDICATE: engine-word < word - "tuple-dispatch-generic" word-prop generic? ; - -M: engine-word stack-effect - "tuple-dispatch-generic" word-prop - [ extra-values ] [ stack-effect ] bi - dup [ - [ in>> length + ] [ out>> ] [ terminated?>> ] tri - effect boa - ] [ 2drop f ] if ; - -M: engine-word where "tuple-dispatch-generic" word-prop where ; - -M: engine-word crossref? "forgotten" word-prop not ; - -: remember-engine ( word -- ) - generic get "engines" word-prop push ; - -: ( -- word ) - engine-word-name f - dup generic get "tuple-dispatch-generic" set-word-prop ; - -: define-engine-word ( quot -- word ) - [ dup ] dip define ; - -: tuple-dispatch-engine-body ( engine -- quot ) - [ - picker % - tuple-layout% - [ n>> ] [ methods>> ] bi - [ engine>quot ] - [ class-hash-dispatch-quot ] - if-small? % - ] [ ] make ; - -M: echelon-dispatch-engine engine>quot - dup n>> zero? [ - methods>> dup assoc-empty? - [ drop default get ] [ values first engine>quot ] if - ] [ - tuple-dispatch-engine-body - ] if ; - -: >=-case-quot ( default alist -- quot ) - [ [ drop ] prepend ] dip - [ - [ [ dup ] swap [ fixnum>= ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: simplify-echelon-alist ( default alist -- default' alist' ) - dup empty? [ - dup first first 1 <= [ - nip unclip second swap - simplify-echelon-alist - ] when - ] unless ; - -: echelon-case-quot ( alist -- quot ) - #! We don't have to test for echelon 1 since all tuple - #! classes are at least at depth 1 in the inheritance - #! hierarchy. - default get swap simplify-echelon-alist - [ - [ - picker % - tuple-layout% - tuple-layout-echelon% - >=-case-quot % - ] [ ] make - ] unless-empty ; - -M: tuple-dispatch-engine engine>quot - [ - [ - tuple assumed set - echelons>> unclip-last - [ - [ - engine>quot - over 0 = [ - define-engine-word - [ remember-engine ] [ 1quotation ] bi - ] unless - dup default set - ] assoc-map - ] - [ first2 engine>quot 2array ] bi* - suffix - ] with-scope - echelon-case-quot % - ] [ ] make ; diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index 6e788eb947..33da0037b3 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,12 +1,7 @@ -USING: generic help.markup help.syntax sequences math +USING: generic generic.single help.markup help.syntax sequences math math.parser effects ; IN: generic.standard -HELP: no-method -{ $values { "object" "an object" } { "generic" "a generic word" } } -{ $description "Throws a " { $link no-method } " error." } -{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; - HELP: standard-combination { $class-description "Performs standard method combination." @@ -22,32 +17,6 @@ HELP: standard-combination } } ; -HELP: hook-combination -{ $class-description - "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." -} ; - HELP: define-simple-generic { $values { "word" "a word" } { "effect" effect } } -{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; - -{ standard-combination hook-combination } related-words - -HELP: inconsistent-next-method -{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } -{ $examples - "The following code throws this error:" - { $code - "GENERIC: error-test ( object -- )" - "" - "M: string error-test print ;" - "" - "M: integer error-test number>string call-next-method ;" - "" - "123 error-test" - } - "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." - $nl - "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" - { $code "M: integer error-test number>string error-test ;" } -} ; +{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; \ No newline at end of file diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 5dbc0d17a1..b76bcaa582 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,100 +1,12 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel kernel.private slots.private math -namespaces make sequences vectors words quotations definitions -hashtables layouts combinators sequences.private generic -classes classes.algebra classes.private generic.standard.engines -generic.standard.engines.tag generic.standard.engines.predicate -generic.standard.engines.tuple accessors ; +USING: accessors definitions generic generic.single kernel +namespaces words math math.order combinators sequences +generic.single.private quotations kernel.private +assocs arrays layouts make ; IN: generic.standard -GENERIC: dispatch# ( word -- n ) - -M: generic dispatch# - "combination" word-prop dispatch# ; - -GENERIC: method-declaration ( class generic -- quot ) - -M: generic method-declaration - "combination" word-prop method-declaration ; - -M: quotation engine>quot - assumed get generic get method-declaration prepend ; - -ERROR: no-method object generic ; - -: error-method ( word -- quot ) - [ picker ] dip [ no-method ] curry append ; - -: push-method ( method specializer atomic assoc -- ) - [ - [ H{ } clone ] unless* - [ methods>> set-at ] keep - ] change-at ; - -: flatten-method ( class method assoc -- ) - [ [ flatten-class keys ] keep ] 2dip [ - [ spin ] dip push-method - ] 3curry each ; - -: flatten-methods ( assoc -- assoc' ) - H{ } clone [ - [ - flatten-method - ] curry assoc-each - ] keep ; - -: ( assoc -- engine ) - flatten-methods - convert-tuple-methods - convert-hi-tag-methods - ; - -: mangle-method ( method -- quot ) - 1quotation generic get extra-values \ drop - prepend [ ] like ; - -: find-default ( methods -- quot ) - #! Side-effects methods. - [ object bootstrap-word ] dip delete-at* [ - drop generic get "default-method" word-prop mangle-method - ] unless ; - -: ( word -- engine ) - object bootstrap-word assumed set { - [ generic set ] - [ "engines" word-prop forget-all ] - [ V{ } clone "engines" set-word-prop ] - [ - "methods" word-prop - [ mangle-method ] assoc-map - [ find-default default set ] - [ ] - bi - ] - } cleave ; - -: single-combination ( word -- quot ) - [ engine>quot ] with-scope ; - -ERROR: inconsistent-next-method class generic ; - -: single-next-method-quot ( class generic -- quot/f ) - 2dup next-method dup [ - [ - pick "predicate" word-prop % - 1quotation , - [ inconsistent-next-method ] 2curry , - \ if , - ] [ ] make - ] [ 3drop f ] if ; - -: single-effective-method ( obj word -- method ) - [ [ order [ instance? ] with find-last nip ] keep method ] - [ "default-method" word-prop ] - bi or ; - -TUPLE: standard-combination # ; +TUPLE: standard-combination < single-combination # ; C: standard-combination @@ -102,79 +14,47 @@ PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; PREDICATE: simple-generic < standard-generic - "combination" word-prop #>> zero? ; + "combination" word-prop #>> 0 = ; CONSTANT: simple-combination T{ standard-combination f 0 } : define-simple-generic ( word effect -- ) [ simple-combination ] dip define-generic ; -: with-standard ( combination quot -- quot' ) - [ #>> (dispatch#) ] dip with-variable ; inline +: (picker) ( n -- quot ) + { + { 0 [ [ dup ] ] } + { 1 [ [ over ] ] } + { 2 [ [ pick ] ] } + [ 1 - (picker) [ dip swap ] curry ] + } case ; -M: standard-generic extra-values drop 0 ; - -M: standard-combination make-default-method - [ error-method ] with-standard ; - -M: standard-combination perform-combination - [ drop ] [ [ single-combination ] with-standard ] 2bi define ; +M: standard-combination picker + combination get #>> (picker) ; M: standard-combination dispatch# #>> ; -M: standard-combination method-declaration - dispatch# object swap prefix [ declare ] curry [ ] like ; - -M: standard-combination next-method-quot* - [ - single-next-method-quot - dup [ picker prepend ] when - ] with-standard ; - M: standard-generic effective-method - [ dispatch# (picker) call ] keep single-effective-method ; + [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep + (effective-method) ; -TUPLE: hook-combination var ; +: inline-cache-quot ( word methods miss-word -- quot ) + [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ; -C: hook-combination +M: standard-combination inline-cache-quots + #! Direct calls to the generic word (not tail calls or indirect calls) + #! will jump to the inline cache entry point instead of the megamorphic + #! dispatch entry point. + [ \ inline-cache-miss inline-cache-quot ] + [ \ inline-cache-miss-tail inline-cache-quot ] + 2bi ; -PREDICATE: hook-generic < generic - "combination" word-prop hook-combination? ; +: make-empty-cache ( -- array ) + mega-cache-size get f ; -: with-hook ( combination quot -- quot' ) - 0 (dispatch#) [ - [ hook-combination ] dip with-variable - ] with-variable ; inline - -: prepend-hook-var ( quot -- quot' ) - hook-combination get var>> [ get ] curry prepend ; - -M: hook-combination dispatch# drop 0 ; - -M: hook-combination method-declaration 2drop [ ] ; - -M: hook-generic extra-values drop 1 ; - -M: hook-generic effective-method - [ "combination" word-prop var>> get ] keep - single-effective-method ; - -M: hook-combination make-default-method - [ error-method prepend-hook-var ] with-hook ; - -M: hook-combination perform-combination - [ drop ] [ - [ single-combination prepend-hook-var ] with-hook - ] 2bi define ; - -M: hook-combination next-method-quot* - [ - single-next-method-quot - dup [ prepend-hook-var ] when - ] with-hook ; - -M: simple-generic definer drop \ GENERIC: f ; +M: standard-combination mega-cache-quot + combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ; M: standard-generic definer drop \ GENERIC# f ; -M: hook-generic definer drop \ HOOK: f ; +M: simple-generic definer drop \ GENERIC: f ; diff --git a/core/generic/standard/summary.txt b/core/generic/standard/summary.txt deleted file mode 100644 index 5e731c6f15..0000000000 --- a/core/generic/standard/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Standard method combination used for most generic words diff --git a/core/growable/growable.factor b/core/growable/growable.factor index c4970f98bd..684aab1158 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -35,7 +35,7 @@ M: growable set-length ( n seq -- ) ] if (>>length) ; -: new-size ( old -- new ) 1+ 3 * ; inline +: new-size ( old -- new ) 1 + 3 * ; inline : ensure ( n seq -- n seq ) growable-check diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor old mode 100644 new mode 100755 index 5a19cce351..0619e798dc --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -116,7 +116,7 @@ HELP: ?set-at { $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ; HELP: >hashtable -{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } } +{ $values { "assoc" assoc } { "hashtable" hashtable } } { $description "Constructs a hashtable from any assoc." } ; HELP: rehash diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index f95a7a7e67..03bc3e01fd 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -34,7 +34,7 @@ TUPLE: hashtable [ no-key ] [ 2dup hash@ (key@) ] if ; inline : ( n -- array ) - 1+ next-power-of-2 4 * ((empty)) ; inline + 1 + next-power-of-2 4 * ((empty)) ; inline : init-hash ( hash -- ) 0 >>count 0 >>deleted drop ; inline @@ -61,10 +61,10 @@ TUPLE: hashtable 1 fixnum+fast set-slot ; inline : hash-count+ ( hash -- ) - [ 1+ ] change-count drop ; inline + [ 1 + ] change-count drop ; inline : hash-deleted+ ( hash -- ) - [ 1+ ] change-deleted drop ; inline + [ 1 + ] change-deleted drop ; inline : (rehash) ( hash alist -- ) swap [ swapd set-at ] curry assoc-each ; inline @@ -77,7 +77,7 @@ TUPLE: hashtable [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline : grow-hash ( hash -- ) - [ [ >alist ] [ assoc-size 1+ ] bi ] keep + [ [ >alist ] [ assoc-size 1 + ] bi ] keep [ reset-hash ] keep swap (rehash) ; @@ -146,7 +146,7 @@ M: hashtable >alist [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi ] dip pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if - ] 2curry each + ] 2curry each-integer ] keep { } like ; M: hashtable clone diff --git a/core/init/init.factor b/core/init/init.factor index 5d8e88b85f..0140fcc0e8 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations continuations.private kernel -kernel.private sequences assocs namespaces namespaces.private ; +kernel.private sequences assocs namespaces namespaces.private +continuations continuations.private ; IN: init SYMBOL: init-hooks diff --git a/basis/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt similarity index 100% rename from basis/io/encodings/utf16/authors.txt rename to core/io/encodings/utf16/authors.txt diff --git a/basis/io/encodings/utf16/summary.txt b/core/io/encodings/utf16/summary.txt similarity index 100% rename from basis/io/encodings/utf16/summary.txt rename to core/io/encodings/utf16/summary.txt diff --git a/basis/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor similarity index 100% rename from basis/io/encodings/utf16/utf16-docs.factor rename to core/io/encodings/utf16/utf16-docs.factor diff --git a/basis/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor similarity index 100% rename from basis/io/encodings/utf16/utf16-tests.factor rename to core/io/encodings/utf16/utf16-tests.factor diff --git a/basis/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor similarity index 94% rename from basis/io/encodings/utf16/utf16.factor rename to core/io/encodings/utf16/utf16.factor index d61c07f806..a6ccc95bf5 100644 --- a/basis/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -1,21 +1,15 @@ ! Copyright (C) 2006, 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary -io.encodings combinators splitting io byte-arrays io.encodings.iana ; +io.encodings combinators splitting io byte-arrays ; IN: io.encodings.utf16 SINGLETON: utf16be -utf16be "UTF-16BE" register-encoding - SINGLETON: utf16le -utf16le "UTF-16LE" register-encoding - SINGLETON: utf16 -utf16 "UTF-16" register-encoding - ERROR: missing-bom ; drop utf16n ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 8f0fb9e97a..f57dafbdc6 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,7 @@ USING: arrays debugger.threads destructors io io.directories io.encodings.8-bit io.encodings.ascii io.encodings.binary io.files io.files.private io.files.temp io.files.unique kernel -make math sequences system threads tools.test generic.standard ; +make math sequences system threads tools.test generic.single ; IN: io.files.tests [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1bc282e956..6779c6d094 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private sequences init namespaces system io -io.backend io.pathnames io.encodings io.files.private ; +io.backend io.pathnames io.encodings io.files.private +alien.strings ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -20,13 +21,13 @@ HOOK: (file-appender) io-backend ( path -- stream ) swap normalize-path (file-appender) swap ; : file-lines ( path encoding -- seq ) - lines ; + stream-lines ; : with-file-reader ( path encoding quot -- ) [ ] dip with-input-stream ; inline : file-contents ( path encoding -- seq ) - contents ; + stream-contents ; : with-file-writer ( path encoding quot -- ) [ ] dip with-output-stream ; inline @@ -40,7 +41,8 @@ HOOK: (file-appender) io-backend ( path -- stream ) : with-file-appender ( path encoding quot -- ) [ ] dip with-output-stream ; inline -: exists? ( path -- ? ) normalize-path (exists?) ; +: exists? ( path -- ? ) + normalize-path native-string>alien (exists?) ; ! Current directory [ cwd current-directory set-global - 13 getenv cwd prepend-path \ image set-global - 14 getenv cwd prepend-path \ vm set-global + 13 getenv alien>native-string cwd prepend-path \ image set-global + 14 getenv alien>native-string cwd prepend-path \ vm set-global image parent-directory "resource-path" set-global ] "io.files" add-init-hook diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 740152f294..ac74e6b11e 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -117,6 +117,7 @@ HELP: seek-relative } { $description "Seeks to an offset from the current position of the stream pointer." } ; +{ seek-absolute seek-relative seek-end } related-words HELP: seek-input { $values @@ -221,10 +222,14 @@ HELP: bl { $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." } $io-error ; -HELP: lines +HELP: stream-lines { $values { "stream" "an input stream" } { "seq" "a sequence of strings" } } { $description "Reads lines of text until the stream is exhausted, collecting them in a sequence of strings." } ; +HELP: lines +{ $values { "seq" "a sequence of strings" } } +{ $description "Reads lines of text until from the " { $link input-stream } " until it is exhausted, collecting them in a sequence of strings." } ; + HELP: each-line { $values { "quot" { $quotation "( str -- )" } } } { $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ; @@ -233,9 +238,14 @@ HELP: each-block { $values { "quot" { $quotation "( block -- )" } } } { $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ; +HELP: stream-contents +{ $values { "stream" "an input stream" } { "seq" { $or string byte-array } } } +{ $description "Reads all elements in the given stream until the stream is exhausted. The type of the sequence depends on the stream's element type." } +$io-error ; + HELP: contents -{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } } -{ $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." } +{ $values { "seq" { $or string byte-array } } } +{ $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." } $io-error ; ARTICLE: "stream-protocol" "Stream protocol" @@ -334,6 +344,10 @@ $nl { $subsection bl } "Seeking on the default output stream:" { $subsection seek-output } +"Seeking descriptors:" +{ $subsection seek-absolute } +{ $subsection seek-relative } +{ $subsection seek-end } "A pair of combinators for rebinding the " { $link output-stream } " variable:" { $subsection with-output-stream } { $subsection with-output-stream* } @@ -347,9 +361,11 @@ $nl "First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":" { $subsection stream-print } "Processing lines one by one:" +{ $subsection stream-lines } { $subsection lines } { $subsection each-line } "Processing blocks of data:" +{ $subsection stream-contents } { $subsection contents } { $subsection each-block } "Copying the contents of one stream to another:" diff --git a/core/io/io.factor b/core/io/io.factor index 74bba7769e..669f104a5f 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables generic kernel math namespaces make sequences -continuations destructors assocs ; +continuations destructors assocs combinators ; IN: io SYMBOLS: +byte+ +character+ ; @@ -20,7 +20,9 @@ GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) ERROR: bad-seek-type type ; + SINGLETONS: seek-absolute seek-relative seek-end ; + GENERIC: stream-seek ( n seek-type stream -- ) : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; @@ -68,23 +70,39 @@ SYMBOL: error-stream : bl ( -- ) " " write ; -: lines ( stream -- seq ) - [ [ readln dup ] [ ] produce nip ] with-input-stream ; - : each-line ( quot -- ) [ readln ] each-morsel ; inline -: contents ( stream -- seq ) - [ - [ 65536 read-partial dup ] [ ] produce nip concat f like - ] with-input-stream ; +: lines ( -- seq ) + [ ] accumulator [ each-line ] dip { } like ; + +: stream-lines ( stream -- seq ) + [ lines ] with-input-stream ; + +: contents ( -- seq ) + [ 65536 read-partial dup ] [ ] produce nip + element-exemplar concat-as ; + +: stream-contents ( stream -- seq ) + [ contents ] with-input-stream ; : each-block ( quot: ( block -- ) -- ) [ 8192 read-partial ] each-morsel ; inline diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index eba3e6a19f..30e9e6c206 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -17,7 +17,7 @@ SYMBOL: current-directory [ path-separator? ] trim-head ; : last-path-separator ( path -- n ? ) - [ length 1- ] keep [ path-separator? ] find-last-from ; + [ length 1 - ] keep [ path-separator? ] find-last-from ; HOOK: root-directory? io-backend ( path -- ? ) @@ -30,7 +30,7 @@ ERROR: no-parent-directory path ; dup root-directory? [ trim-tail-separators dup last-path-separator [ - 1+ cut + 1 + cut ] [ drop "." swap ] if @@ -113,7 +113,7 @@ PRIVATE> : file-name ( path -- string ) dup root-directory? [ trim-tail-separators - dup last-path-separator [ 1+ tail ] [ + dup last-path-separator [ 1 + tail ] [ drop special-path? [ file-name ] when ] if ] unless ; diff --git a/basis/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor similarity index 100% rename from basis/io/streams/byte-array/byte-array-docs.factor rename to core/io/streams/byte-array/byte-array-docs.factor diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor similarity index 85% rename from basis/io/streams/byte-array/byte-array-tests.factor rename to core/io/streams/byte-array/byte-array-tests.factor index 3cf52c6a78..43a8373232 100644 --- a/basis/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -1,12 +1,13 @@ USING: tools.test io.streams.byte-array io.encodings.binary io.encodings.utf8 io kernel arrays strings namespaces ; +[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test [ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test -[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 contents dup >array swap string? ] unit-test +[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 stream-contents dup >array swap string? ] unit-test [ B{ 121 120 } 0 ] [ B{ 0 121 120 0 0 0 0 0 0 } binary @@ -26,4 +27,4 @@ io.encodings.utf8 io kernel arrays strings namespaces ; 0 seek-end input-stream get stream-seek read1 ] with-byte-reader -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor similarity index 90% rename from basis/io/streams/byte-array/byte-array.factor rename to core/io/streams/byte-array/byte-array.factor index 2ffb9b9a63..4cb50dfbc1 100644 --- a/basis/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays byte-vectors kernel io.encodings io.streams.string -sequences io namespaces io.encodings.private accessors sequences.private +USING: byte-arrays byte-vectors kernel io.encodings sequences io +namespaces io.encodings.private accessors sequences.private io.streams.sequence destructors math combinators ; IN: io.streams.byte-array diff --git a/basis/io/streams/byte-array/summary.txt b/core/io/streams/byte-array/summary.txt similarity index 100% rename from basis/io/streams/byte-array/summary.txt rename to core/io/streams/byte-array/summary.txt diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor index 41cc878c79..d23e8c2b16 100644 --- a/core/io/streams/c/c-docs.factor +++ b/core/io/streams/c/c-docs.factor @@ -30,7 +30,7 @@ HELP: { $description "Creates a stream which writes data by calling C standard library functions." } { $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ; -HELP: fopen ( path mode -- alien ) +HELP: fopen { $values { "path" "a pathname string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } } { $description "Opens a file named by " { $snippet "path" } ". The " { $snippet "mode" } " parameter should be something like " { $snippet "\"r\"" } " or " { $snippet "\"rw\"" } "; consult the " { $snippet "fopen(3)" } " manual page for details." } { $errors "Throws an error if the file could not be opened." } diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 3dde9152d0..6a82d6d545 100644 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -5,6 +5,6 @@ IN: io.streams.c.tests [ "hello world" ] [ "hello world" "test.txt" temp-file ascii set-file-contents - "test.txt" temp-file "rb" fopen contents + "test.txt" temp-file "rb" fopen stream-contents >string ] unit-test diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index bec3bdc6bf..d3fd593a7b 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private namespaces make io io.encodings -sequences math generic threads.private classes io.backend -io.files continuations destructors byte-arrays accessors -combinators ; +USING: kernel kernel.private namespaces make io io.encodings sequences +math generic threads.private classes io.backend io.files +io.encodings.utf8 alien.strings continuations destructors byte-arrays +accessors combinators ; IN: io.streams.c TUPLE: c-stream handle disposed ; @@ -69,6 +69,9 @@ M: c-io-backend (init-stdio) init-c-stdio t ; M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ; +: fopen ( path mode -- alien ) + [ utf8 string>alien ] bi@ (fopen) ; + M: c-io-backend (file-reader) "rb" fopen ; diff --git a/basis/io/streams/memory/memory.factor b/core/io/streams/memory/memory.factor similarity index 62% rename from basis/io/streams/memory/memory.factor rename to core/io/streams/memory/memory.factor index 52169de6f8..ad5453af61 100644 --- a/basis/io/streams/memory/memory.factor +++ b/core/io/streams/memory/memory.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors alien alien.c-types alien.accessors math io ; +USING: kernel accessors alien alien.accessors math io ; IN: io.streams.memory TUPLE: memory-stream alien index ; @@ -13,9 +13,3 @@ M: memory-stream stream-element-type drop +byte+ ; M: memory-stream stream-read1 [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ] [ [ 1+ ] change-index drop ] bi ; - -M: memory-stream stream-read - [ - [ index>> ] [ alien>> ] bi - swap memory>byte-array - ] [ [ + ] change-index drop ] 2bi ; diff --git a/basis/io/streams/memory/summary.txt b/core/io/streams/memory/summary.txt similarity index 100% rename from basis/io/streams/memory/summary.txt rename to core/io/streams/memory/summary.txt diff --git a/core/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor index 0f922a37cc..036bab2213 100644 --- a/core/io/streams/sequence/sequence.factor +++ b/core/io/streams/sequence/sequence.factor @@ -12,7 +12,7 @@ SLOT: i [ i>> ] [ underlying>> ] bi ; inline : next ( stream -- ) - [ 1+ ] change-i drop ; inline + [ 1 + ] change-i drop ; inline : sequence-read1 ( stream -- elt/f ) [ >sequence-stream< ?nth ] [ next ] bi ; inline @@ -45,4 +45,4 @@ M: growable stream-write1 push ; M: growable stream-write push-all ; M: growable stream-flush drop ; -INSTANCE: growable plain-writer \ No newline at end of file +INSTANCE: growable plain-writer diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 1d8c09a9b2..22e0e76451 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -183,6 +183,20 @@ HELP: either? { $example "USING: kernel math prettyprint ;" "5 7 [ even? ] either? ." "f" } } ; +HELP: execute +{ $values { "word" word } } +{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." } +{ $examples + { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } +} ; + +{ execute POSTPONE: execute( } related-words + +HELP: (execute) +{ $values { "word" word } } +{ $description "Executes a word without checking if it is a word first." } +{ $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is unsafe. Calling with a parameter that is not a word will crash Factor. Use " { $link execute } " instead." } ; + HELP: call { $values { "callable" callable } } { $description "Calls a quotation. Words which " { $link call } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal quotation can have a static stack effect." } @@ -198,18 +212,6 @@ HELP: call-clear ( quot -- ) { $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." } { $notes "Used to implement " { $link "threads" } "." } ; -HELP: slip -{ $values { "quot" quotation } { "x" object } } -{ $description "Calls a quotation while hiding the top of the stack." } ; - -HELP: 2slip -{ $values { "quot" quotation } { "x" object } { "y" object } } -{ $description "Calls a quotation while hiding the top two stack elements." } ; - -HELP: 3slip -{ $values { "quot" quotation } { "x" object } { "y" object } { "z" object } } -{ $description "Calls a quotation while hiding the top three stack elements." } ; - HELP: keep { $values { "quot" { $quotation "( x -- ... )" } } { "x" object } } { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." } diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index b58c744b05..c8e0fcd2a9 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -61,20 +61,16 @@ IN: kernel.tests [ 2 ] [ f 2 xor ] unit-test [ f ] [ f f xor ] unit-test -[ slip ] must-fail +[ dip ] must-fail [ ] [ :c ] unit-test -[ 1 slip ] must-fail +[ 1 [ call ] dip ] must-fail [ ] [ :c ] unit-test -[ 1 2 slip ] must-fail +[ 1 2 [ call ] dip ] must-fail [ ] [ :c ] unit-test -[ 1 2 3 slip ] must-fail -[ ] [ :c ] unit-test - - -[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test +[ 5 ] [ 1 [ 2 2 + ] dip + ] unit-test [ [ ] keep ] must-fail @@ -114,7 +110,7 @@ IN: kernel.tests ! Regression : (loop) ( a b c d -- ) [ pick ] dip swap [ pick ] dip swap - < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive + < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive : loop ( obj -- ) H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 6245080225..d6350e0420 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -58,37 +58,19 @@ DEFER: if : ?if ( default cond true false -- ) pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline -! Slippers and dippers. +! Dippers. ! Not declared inline because the compiler special-cases them -: slip ( quot x -- x ) - #! 'slip' and 'dip' can be defined in terms of each other - #! because the JIT special-cases a 'dip' preceeded by - #! a literal quotation. - [ call ] dip ; +: dip ( x quot -- x ) swap [ call ] dip ; -: 2slip ( quot x y -- x y ) - #! '2slip' and '2dip' can be defined in terms of each other - #! because the JIT special-cases a '2dip' preceeded by - #! a literal quotation. - [ call ] 2dip ; +: 2dip ( x y quot -- x y ) -rot [ call ] 2dip ; -: 3slip ( quot x y z -- x y z ) - #! '3slip' and '3dip' can be defined in terms of each other - #! because the JIT special-cases a '3dip' preceeded by - #! a literal quotation. - [ call ] 3dip ; - -: dip ( x quot -- x ) swap slip ; - -: 2dip ( x y quot -- x y ) -rot 2slip ; - -: 3dip ( x y z quot -- x y z ) -roll 3slip ; +: 3dip ( x y z quot -- x y z ) -roll [ call ] 3dip ; : 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline ! Keepers -: keep ( x quot -- x ) over slip ; inline +: keep ( x quot -- x ) over [ call ] dip ; inline : 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 5a32ca2dce..42898fc085 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel assocs classes math.order kernel.private ; @@ -16,12 +16,14 @@ SYMBOL: tag-numbers SYMBOL: type-numbers -: tag-number ( class -- n ) - tag-numbers get at [ object tag-number ] unless* ; +SYMBOL: mega-cache-size : type-number ( class -- n ) type-numbers get at ; +: tag-number ( class -- n ) + type-number dup num-tags get >= [ drop object tag-number ] when ; + : tag-fixnum ( n -- tagged ) tag-bits get shift ; @@ -47,13 +49,13 @@ SYMBOL: type-numbers cell-bits (first-bignum) ; inline : most-positive-fixnum ( -- n ) - first-bignum 1- ; inline + first-bignum 1 - ; inline : most-negative-fixnum ( -- n ) first-bignum neg ; inline : (max-array-capacity) ( b -- n ) - 5 - 2^ 1- ; inline + 5 - 2^ 1 - ; inline : max-array-capacity ( -- n ) cell-bits (max-array-capacity) ; inline @@ -62,7 +64,7 @@ SYMBOL: type-numbers bootstrap-cell-bits (first-bignum) ; : bootstrap-most-positive-fixnum ( -- n ) - bootstrap-first-bignum 1- ; + bootstrap-first-bignum 1 - ; : bootstrap-most-negative-fixnum ( -- n ) bootstrap-first-bignum neg ; diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 75341f0204..60157033d7 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -9,7 +9,7 @@ TUPLE: lexer text line line-text line-length column ; : next-line ( lexer -- ) dup [ line>> ] [ text>> ] bi ?nth >>line-text dup line-text>> length >>line-length - [ 1+ ] change-line + [ 1 + ] change-line 0 >>column drop ; @@ -39,7 +39,7 @@ GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if + 2dup nth CHAR: " eq? [ drop 1 + ] [ f skip ] if ] change-lexer-column ; : still-parsing? ( lexer -- ? ) diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 9f8f7b06fc..097e2c14aa 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -50,8 +50,8 @@ IN: math.floats.tests [ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ] unit-test -[ 2.0 ] [ 1.0 1+ ] unit-test -[ 0.0 ] [ 1.0 1- ] unit-test +[ 2.0 ] [ 1.0 1 + ] unit-test +[ 0.0 ] [ 1.0 1 - ] unit-test [ t ] [ 0.0 zero? ] unit-test [ t ] [ -0.0 zero? ] unit-test diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 6bd3e9b094..a9469ae91a 100644 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -206,8 +206,8 @@ unit-test [ 2. ] [ 2 1 ratio>float ] unit-test [ .5 ] [ 1 2 ratio>float ] unit-test [ .75 ] [ 3 4 ratio>float ] unit-test -[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test -[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test +[ 1. ] [ 2000 2^ 2000 2^ 1 + ratio>float ] unit-test +[ -1. ] [ 2000 2^ neg 2000 2^ 1 + ratio>float ] unit-test [ 0.4 ] [ 6 15 ratio>float ] unit-test [ HEX: 3fe553522d230931 ] diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 868d9fc02e..bb7fc107b2 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ; M: fixnum bit? neg shift 1 bitand 0 > ; : fixnum-log2 ( x -- n ) - 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ; + 0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ; M: fixnum (log2) fixnum-log2 ; @@ -86,7 +86,7 @@ M: bignum (log2) bignum-log2 ; ! provided with absolutely no warranty." ! First step: pre-scaling -: twos ( x -- y ) dup 1- bitxor log2 ; inline +: twos ( x -- y ) dup 1 - bitxor log2 ; inline : scale-denonimator ( den -- scaled-den scale' ) dup twos neg [ shift ] keep ; inline @@ -98,7 +98,7 @@ M: bignum (log2) bignum-log2 ; ! Second step: loop : shift-mantissa ( scale mantissa -- scale' mantissa' ) - [ 1+ ] [ 2/ ] bi* ; inline + [ 1 + ] [ 2/ ] bi* ; inline : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem ) [ 2dup /i log2 53 > ] @@ -107,7 +107,7 @@ M: bignum (log2) bignum-log2 ; ! Third step: post-scaling : unscaled-float ( mantissa -- n ) - 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline + 52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline : scale-float ( scale mantissa -- float' ) [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline @@ -126,7 +126,7 @@ M: bignum (log2) bignum-log2 ; ] [ pre-scale /f-loop over odd? - [ zero? [ 1+ ] unless ] [ drop ] if + [ zero? [ 1 + ] unless ] [ drop ] if post-scale ] if ] if ; inline diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index c28bf062c1..e5f68a511c 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -245,10 +245,22 @@ HELP: times { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" } } ; +HELP: fp-special? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; + HELP: fp-nan? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; +HELP: fp-qnan? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE Quiet Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; + +HELP: fp-snan? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE Signaling Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; + HELP: fp-infinity? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } @@ -257,7 +269,26 @@ HELP: fp-infinity? { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; -{ fp-nan? fp-infinity? } related-words +HELP: fp-nan-payload +{ $values { "x" real } { "bits" integer } } +{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ; + +HELP: +{ $values { "payload" integer } { "nan" float } } +{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." } +{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ; + +{ fp-special? fp-nan? fp-qnan? fp-snan? fp-infinity? fp-nan-payload } related-words + +HELP: next-float +{ $values { "m" float } { "n" float } } +{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ; + +HELP: prev-float +{ $values { "m" float } { "n" float } } +{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ; + +{ next-float prev-float } related-words HELP: real-part { $values { "z" number } { "x" real } } diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index c2077eb790..b7cc51e669 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -12,7 +12,24 @@ IN: math.tests [ f ] [ 1/0. fp-nan? ] unit-test [ f ] [ -1/0. fp-nan? ] unit-test [ t ] [ -0/0. fp-nan? ] unit-test +[ t ] [ 1 fp-nan? ] unit-test +! [ t ] [ 1 fp-snan? ] unit-test +! [ f ] [ 1 fp-qnan? ] unit-test +[ t ] [ HEX: 8000000000001 fp-nan? ] unit-test +[ f ] [ HEX: 8000000000001 fp-snan? ] unit-test +[ t ] [ HEX: 8000000000001 fp-qnan? ] unit-test [ t ] [ 1/0. fp-infinity? ] unit-test [ t ] [ -1/0. fp-infinity? ] unit-test [ f ] [ -0/0. fp-infinity? ] unit-test + +[ f ] [ 0 fp-nan? ] unit-test +[ t ] [ 0 fp-infinity? ] unit-test + +[ 0.0 ] [ -0.0 next-float ] unit-test +[ t ] [ 1.0 dup next-float < ] unit-test +[ t ] [ -1.0 dup next-float < ] unit-test + +[ -0.0 ] [ 0.0 prev-float ] unit-test +[ t ] [ 1.0 dup prev-float > ] unit-test +[ t ] [ -1.0 dup prev-float > ] unit-test diff --git a/core/math/math.factor b/core/math/math.factor index 42786ffc9d..da9bc4d1b5 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private ; IN: math @@ -63,54 +63,91 @@ PRIVATE> : neg ( x -- -x ) 0 swap - ; inline : recip ( x -- y ) 1 swap / ; inline : sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline - -: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline - +: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline : rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable - : 2^ ( n -- 2^n ) 1 swap shift ; inline - : even? ( n -- ? ) 1 bitand zero? ; - : odd? ( n -- ? ) 1 bitand 1 number= ; UNION: integer fixnum bignum ; +TUPLE: ratio { numerator integer read-only } { denominator integer read-only } ; + UNION: rational integer ratio ; UNION: real rational float ; +TUPLE: complex { real real read-only } { imaginary real read-only } ; + UNION: number real complex ; -GENERIC: fp-nan? ( x -- ? ) +: fp-bitwise= ( x y -- ? ) [ double>bits ] bi@ = ; inline +GENERIC: fp-special? ( x -- ? ) +GENERIC: fp-nan? ( x -- ? ) +GENERIC: fp-qnan? ( x -- ? ) +GENERIC: fp-snan? ( x -- ? ) +GENERIC: fp-infinity? ( x -- ? ) +GENERIC: fp-nan-payload ( x -- bits ) + +M: object fp-special? + drop f ; M: object fp-nan? drop f ; - -M: float fp-nan? - double>bits -51 shift HEX: fff [ bitand ] keep = ; - -GENERIC: fp-infinity? ( x -- ? ) - +M: object fp-qnan? + drop f ; +M: object fp-snan? + drop f ; M: object fp-infinity? drop f ; +M: object fp-nan-payload + drop f ; -M: float fp-infinity? ( float -- ? ) +M: float fp-special? + double>bits -52 shift HEX: 7ff [ bitand ] keep = ; + +M: float fp-nan-payload + double>bits HEX: fffffffffffff bitand ; foldable flushable + +M: float fp-nan? + dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; + +M: float fp-qnan? + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; + +M: float fp-snan? + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; + +M: float fp-infinity? + dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; + +: ( payload -- nan ) + HEX: 7ff0000000000000 bitor bits>double ; foldable flushable + +: next-float ( m -- n ) double>bits - dup -52 shift HEX: 7ff [ bitand ] keep = [ - HEX: fffffffffffff bitand 0 = - ] [ - drop f - ] if ; + dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero + dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero + 1 + bits>double ! positive + ] if + ] if ; foldable flushable + +: prev-float ( m -- n ) + double>bits + dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative + dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero + 1 - bits>double ! positive non-zero + ] if + ] if ; foldable flushable : next-power-of-2 ( m -- n ) - dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline + dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline : power-of-2? ( n -- ? ) - dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable + dup 0 <= [ drop f ] [ dup 1 - bitand zero? ] if ; foldable : align ( m w -- n ) - 1- [ + ] keep bitnot bitand ; inline + 1 - [ + ] keep bitnot bitand ; inline @@ -161,6 +198,6 @@ PRIVATE> [ call ] 2keep rot [ drop ] [ - [ 1- ] dip find-last-integer + [ 1 - ] dip find-last-integer ] if ] if ; inline recursive diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index ba0df3e357..1e3ff4f996 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax math math.private prettyprint +USING: help.markup help.syntax math math.parser.private prettyprint namespaces make strings ; IN: math.parser @@ -102,7 +102,7 @@ HELP: string>float ( str -- n/f ) $nl "Outputs " { $link f } " if the string does not represent a float." } ; -HELP: float>string ( n -- str ) +HELP: float>string { $values { "n" real } { "str" string } } { $description "Primitive for getting a string representation of a float." } { $notes "The " { $link number>string } " word is more general." } ; diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 3fd62e69a0..437308d53f 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private namespaces sequences sequences.private -strings arrays combinators splitting math assocs make ; +strings arrays combinators splitting math assocs byte-arrays make ; IN: math.parser : digit> ( ch -- n ) @@ -79,6 +79,9 @@ SYMBOL: negative? string>natural ] if ; inline +: string>float ( str -- n/f ) + >byte-array 0 suffix (string>float) ; + PRIVATE> : base> ( str radix -- n/f ) @@ -149,13 +152,18 @@ M: ratio >base [ ".0" append ] } cond ; +: float>string ( n -- str ) + (float>string) + [ 0 = ] trim-tail >string + fix-float ; + M: float >base drop { { [ dup fp-nan? ] [ drop "0/0." ] } { [ dup 1/0. = ] [ drop "1/0." ] } { [ dup -1/0. = ] [ drop "-1/0." ] } { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] } - [ float>string fix-float ] + [ float>string ] } cond ; : number>string ( n -- str ) 10 >base ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 4b873ef6ec..1c61e33d83 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel continuations sequences vectors arrays system math ; +USING: kernel continuations sequences vectors arrays system math +io.backend alien.strings memory.private ; IN: memory : (each-object) ( quot: ( obj -- ) -- ) @@ -21,4 +22,10 @@ IN: memory [ count-instances 100 + ] keep swap [ [ push-if ] 2curry each-object ] keep >array ; inline +: save-image ( path -- ) + normalize-path native-string>alien (save-image) ; + +: save-image-and-exit ( path -- ) + normalize-path native-string>alien (save-image-and-exit) ; + : save ( -- ) image save-image ; diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor old mode 100644 new mode 100755 index 74d7c58963..cd66e781d2 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private sequences words namespaces.private quotations vectors -math.parser math words.symbol ; +math.parser math words.symbol assocs ; IN: namespaces ARTICLE: "namespaces-combinators" "Namespace combinators" @@ -14,7 +14,8 @@ ARTICLE: "namespaces-change" "Changing variable values" { $subsection off } { $subsection inc } { $subsection dec } -{ $subsection change } ; +{ $subsection change } +{ $subsection change-global } ; ARTICLE: "namespaces-global" "Global variables" { $subsection namespace } @@ -73,6 +74,11 @@ HELP: change { $description "Applies the quotation to the old value of the variable, and assigns the resulting value to the variable." } { $side-effects "variable" } ; +HELP: change-global +{ $values { "variable" "a variable, by convention a symbol" } { "quot" { $quotation "( old -- new )" } } } +{ $description "Applies the quotation to the old value of the global variable, and assigns the resulting value to the global variable." } +{ $side-effects "variable" } ; + HELP: +@ { $values { "n" "a number" } { "variable" "a variable, by convention a symbol" } } { $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." } @@ -113,19 +119,19 @@ HELP: with-variable } ; HELP: make-assoc -{ $values { "quot" quotation } { "exemplar" "an assoc" } { "hash" "a new hashtable" } } +{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } } { $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ; HELP: bind -{ $values { "ns" "a hashtable" } { "quot" quotation } } +{ $values { "ns" assoc } { "quot" quotation } } { $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ; HELP: namespace -{ $values { "namespace" "an assoc" } } +{ $values { "namespace" assoc } } { $description "Outputs the current namespace. Calls to " { $link set } " modify this namespace." } ; HELP: global -{ $values { "g" "an assoc" } } +{ $values { "g" assoc } } { $description "Outputs the global namespace. The global namespace is always checked last when looking up variable values." } ; HELP: get-global @@ -150,7 +156,7 @@ HELP: set-namestack { $description "Replaces the name stack with a copy of the given vector." } ; HELP: >n -{ $values { "namespace" "an assoc" } } +{ $values { "namespace" assoc } } { $description "Pushes a namespace on the name stack." } ; HELP: ndrop diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index b0e764c94d..64cc328d19 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -24,12 +24,13 @@ PRIVATE> : get-global ( variable -- value ) global at ; : set-global ( value variable -- ) global set-at ; : change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline +: change-global ( variable quot -- ) [ global ] dip change-at ; inline : +@ ( n variable -- ) [ 0 or + ] change ; : inc ( variable -- ) 1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline : bind ( ns quot -- ) swap >n call ndrop ; inline -: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ; +: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ; : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline : with-scope ( quot -- ) 5 swap bind ; inline : with-variable ( value key quot -- ) [ associate ] dip bind ; inline -: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline \ No newline at end of file +: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7908f40cbe..01e0b18887 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -198,9 +198,10 @@ SYMBOL: interactive-vocabs "tools.test" "tools.threads" "tools.time" - "tools.vocabs" "vocabs" "vocabs.loader" + "vocabs.refresh" + "vocabs.hierarchy" "words" "scratchpad" } interactive-vocabs set-global @@ -272,7 +273,7 @@ print-use-hook [ [ ] ] initialize : parse-stream ( stream name -- quot ) [ [ - lines dup parse-fresh + stream-lines dup parse-fresh [ nip ] [ finish-parsing ] 2bi forget-smudged ] with-source-file diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 2c3b41ca4e..af3c110d61 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -19,7 +19,7 @@ M: quotation call (call) ; M: curry call uncurry call ; -M: compose call uncompose slip call ; +M: compose call uncompose [ call ] dip call ; M: wrapper equal? over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ; @@ -48,12 +48,12 @@ M: object literalize ; M: wrapper literalize ; -M: curry length quot>> length 1+ ; +M: curry length quot>> length 1 + ; M: curry nth over 0 = [ nip obj>> literalize ] - [ [ 1- ] dip quot>> nth ] + [ [ 1 - ] dip quot>> nth ] if ; INSTANCE: curry immutable-sequence diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 556e41249e..b6cfface12 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1,6 +1,6 @@ USING: arrays help.markup help.syntax math sequences.private vectors strings kernel math.order layouts -quotations generic.standard ; +quotations generic.single ; IN: sequences HELP: sequence @@ -533,12 +533,18 @@ HELP: concat { $description "Concatenates a sequence of sequences together into one sequence. If " { $snippet "seq" } " is empty, outputs " { $snippet "{ }" } ", otherwise the resulting sequence is of the same class as the first element of " { $snippet "seq" } "." } { $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as the first element of " { $snippet "seq" } "." } ; +HELP: concat-as +{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" sequence } } +{ $description "Concatenates a sequence of sequences together into one sequence with the same type as " { $snippet "exemplar" } "." } +{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." } ; + HELP: join { $values { "seq" sequence } { "glue" sequence } { "newseq" sequence } } { $description "Concatenates a sequence of sequences together into one sequence, placing a copy of " { $snippet "glue" } " between each pair of sequences. The resulting sequence is of the same class as " { $snippet "glue" } "." } +{ $notes "If the " { $snippet "glue" } " sequence is empty, this word calls " { $link concat-as } "." } { $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "glue" } "." } ; -{ join concat } related-words +{ join concat concat-as } related-words HELP: peek { $values { "seq" sequence } { "elt" object } } @@ -1466,8 +1472,8 @@ ARTICLE: "sequences-combinators" "Sequence combinators" { $subsection produce } { $subsection produce-as } "Filtering:" -{ $subsection push-if } { $subsection filter } +{ $subsection partition } "Testing if a sequence contains elements satisfying a predicate:" { $subsection any? } { $subsection all? } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 79195d1938..dd48501fa0 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -198,7 +198,7 @@ C: reversed M: reversed virtual-seq seq>> ; -M: reversed virtual@ seq>> [ length swap - 1- ] keep ; +M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; M: reversed length seq>> length ; @@ -276,7 +276,7 @@ INSTANCE: repetition immutable-sequence ] 3keep ; inline : (copy) ( dst i src j n -- dst ) - dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; + dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ; inline recursive : prepare-subseq ( from to seq -- dst i src j n ) @@ -460,7 +460,7 @@ PRIVATE> [ nip find-last-integer ] (find-from) ; inline : find-last ( seq quot -- i elt ) - [ [ 1- ] dip find-last-integer ] (find) ; inline + [ [ 1 - ] dip find-last-integer ] (find) ; inline : all? ( seq quot -- ? ) (each) all-integers? ; inline @@ -556,7 +556,7 @@ PRIVATE> [ empty? not ] filter ; : mismatch ( seq1 seq2 -- i ) - [ min-length ] 2keep + [ min-length iota ] 2keep [ 2nth-unsafe = not ] 2curry find drop ; inline @@ -595,8 +595,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : (filter-here) ( quot: ( elt -- ? ) store scan seq -- ) 2dup length < [ [ move ] 3keep - [ nth-unsafe pick call [ 1+ ] when ] 2keep - [ 1+ ] dip + [ nth-unsafe pick call [ 1 + ] when ] 2keep + [ 1 + ] dip (filter-here) ] [ nip set-length drop ] if ; inline recursive @@ -612,20 +612,20 @@ PRIVATE> [ eq? not ] with filter-here ; : prefix ( seq elt -- newseq ) - over [ over length 1+ ] dip [ + over [ over length 1 + ] dip [ [ 0 swap set-nth-unsafe ] keep [ 1 swap copy ] keep ] new-like ; : suffix ( seq elt -- newseq ) - over [ over length 1+ ] dip [ + over [ over length 1 + ] dip [ [ [ over length ] dip set-nth-unsafe ] keep [ 0 swap copy ] keep ] new-like ; -: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ; +: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ; -: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ; +: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ; 2over = [ 2drop 2drop ] [ - [ [ 2over + pick ] dip move [ 1+ ] dip ] keep + [ [ 2over + pick ] dip move [ 1 + ] dip ] keep move-backward ] if ; @@ -641,13 +641,13 @@ PRIVATE> 2over = [ 2drop 2drop ] [ - [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep + [ [ pick [ dup dup ] dip + swap ] dip move 1 - ] keep move-forward ] if ; : (open-slice) ( shift from to seq ? -- ) [ - [ [ 1- ] bi@ ] dip move-forward + [ [ 1 - ] bi@ ] dip move-forward ] [ [ over - ] 2dip move-backward ] if ; @@ -667,7 +667,7 @@ PRIVATE> check-slice [ over [ - ] dip ] dip open-slice ; : delete-nth ( n seq -- ) - [ dup 1+ ] dip delete-slice ; + [ dup 1 + ] dip delete-slice ; : snip ( from to seq -- head tail ) [ swap head ] [ swap tail ] bi-curry bi* ; inline @@ -679,10 +679,10 @@ PRIVATE> snip-slice surround ; : remove-nth ( n seq -- seq' ) - [ [ { } ] dip dup 1+ ] dip replace-slice ; + [ [ { } ] dip dup 1 + ] dip replace-slice ; : pop ( seq -- elt ) - [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; + [ length 1 - ] [ [ nth ] [ shorten ] 2bi ] bi ; : exchange ( m n seq -- ) [ nip bounds-check 2drop ] @@ -692,7 +692,7 @@ PRIVATE> : reverse-here ( seq -- ) [ length 2/ ] [ length ] [ ] tri - [ [ over - 1- ] dip exchange-unsafe ] 2curry each ; + [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ; : reverse ( seq -- newseq ) [ @@ -704,13 +704,14 @@ PRIVATE> : sum-lengths ( seq -- n ) 0 [ length + ] reduce ; +: concat-as ( seq exemplar -- newseq ) + swap [ { } ] [ + [ sum-lengths over new-resizable ] keep + [ over push-all ] each + ] if-empty swap like ; + : concat ( seq -- newseq ) - [ { } ] [ - [ sum-lengths ] keep - [ first new-resizable ] keep - [ [ over push-all ] each ] keep - first like - ] if-empty ; + [ { } ] [ dup first concat-as ] if-empty ; PRIVATE> : join ( seq glue -- newseq ) - [ - 2dup joined-length over new-resizable [ - [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi - interleave - ] keep - ] keep like ; + dup empty? [ concat-as ] [ + [ + 2dup joined-length over new-resizable [ + [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi + interleave + ] keep + ] keep like + ] if ; : padding ( seq n elt quot -- newseq ) [ @@ -799,7 +802,7 @@ PRIVATE> PRIVATE> : start* ( subseq seq n -- i ) - pick length pick length swap - 1+ + pick length pick length swap - 1 + [ (start) ] find-from swap [ 3drop ] dip ; diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index a122aa1240..3670b10d3c 100755 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -1,4 +1,4 @@ -USING: kernel help.markup help.syntax sequences quotations ; +USING: kernel help.markup help.syntax sequences quotations assocs ; IN: sets ARTICLE: "sets" "Set-theoretic operations on sequences" @@ -42,7 +42,7 @@ HELP: adjoin { $side-effects "seq" } ; HELP: conjoin -{ $values { "elt" object } { "assoc" "an assoc" } } +{ $values { "elt" object } { "assoc" assoc } } { $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." } { $examples { $example @@ -54,7 +54,7 @@ HELP: conjoin { $side-effects "assoc" } ; HELP: unique -{ $values { "seq" "a sequence" } { "assoc" "an assoc" } } +{ $values { "seq" "a sequence" } { "assoc" assoc } } { $description "Outputs a new assoc where the keys and values are equal." } { $examples { $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" } diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 7ac8446842..1365e81524 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -1,5 +1,5 @@ IN: slots.tests -USING: math accessors slots strings generic.standard kernel +USING: math accessors slots strings generic.single kernel tools.test generic words parser eval math.functions ; TUPLE: r/w-test foo ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 63c0319c1c..6bb854daf6 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -122,7 +122,7 @@ ERROR: bad-slot-value value class ; [ \ over , over reader-word 1quotation - [ dip call ] curry [ dip swap ] curry % + [ dip call ] curry [ ] like [ dip swap ] curry % swap setter-word , ] [ ] make (( object quot -- object )) define-inline ] [ 2drop ] if ; diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 30ecb70ed9..f2fa6b8771 100644 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -29,13 +29,13 @@ TUPLE: merge [ [ [ 2drop ] dip nth-unsafe ] dip push ] [ pick 2 = [ [ - [ 2drop dup 1+ ] dip + [ 2drop dup 1 + ] dip [ nth-unsafe ] curry bi@ ] dip [ push ] curry bi@ ] [ pick 3 = [ [ - [ 2drop dup 1+ dup 1+ ] dip + [ 2drop dup 1 + dup 1 + ] dip [ nth-unsafe ] curry tri@ ] dip [ push ] curry tri@ ] [ [ nip subseq ] dip push-all ] if @@ -57,10 +57,10 @@ TUPLE: merge [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline : l-next ( merge -- ) - [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline + [ [ l-elt ] [ [ 1 + ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline : r-next ( merge -- ) - [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline + [ [ r-elt ] [ [ 1 + ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline : decide ( merge -- ? ) [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline @@ -129,8 +129,8 @@ TUPLE: merge while 2drop ; inline : each-pair ( seq quot -- ) - [ [ length 1+ 2/ ] keep ] dip - [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline + [ [ length 1 + 2/ ] keep ] dip + [ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline : (sort-pairs) ( i1 i2 seq quot accum -- ) [ 2dup length = ] 2dip rot [ diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index eb1284cd25..91c039dbae 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -3,7 +3,7 @@ definitions quotations compiler.units ; IN: source-files ARTICLE: "source-files" "Source files" -"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "." +"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "vocabs.refresh" } "." $nl "The source file database:" { $subsection source-files } @@ -41,7 +41,7 @@ HELP: record-checksum $low-level-note ; HELP: reset-checksums -{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ; +{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "vocabs.refresh" } "." } ; HELP: forget-source { $values { "path" "a pathname string" } } diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 6d833c792e..c55a75baa6 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -55,7 +55,7 @@ PRIVATE> : (split) ( separators n seq -- ) 3dup rot [ member? ] curry find-from drop - [ [ swap subseq , ] 2keep 1+ swap (split) ] + [ [ swap subseq , ] 2keep 1 + swap (split) ] [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive : split, ( seq separators -- ) 0 rot (split) ; diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 5b71b13552..22bf7bb821 100644 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -58,7 +58,7 @@ unit-test [ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test ! Random tester found this -[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with +[ 2 -7 resize-string ] [ { "kernel-error" 3 11 -7 } = ] must-fail-with ! Make sure 24-bit strings work "hello world" "s" set diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 7ab287fd20..fff355fb95 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,7 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math -generic.standard arrays io.pathnames vocabs.loader io sequences -assocs words.symbol words.alias words.constant combinators ; +generic.standard generic.single arrays io.pathnames vocabs.loader io +sequences assocs words.symbol words.alias words.constant combinators ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" @@ -749,7 +749,7 @@ HELP: " "" @@ -760,7 +760,7 @@ HELP: array ] parse-literal ] define-core-syntax "V{" [ \ } [ >vector ] parse-literal ] define-core-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax + "BV{" [ \ } [ >byte-vector ] parse-literal ] define-core-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax "T{" [ parse-tuple-literal parsed ] define-core-syntax "W{" [ \ } [ first ] parse-literal ] define-core-syntax diff --git a/core/system/system.factor b/core/system/system.factor index 8f587d28c2..38b4a5fd9b 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -1,29 +1,20 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: system USING: kernel kernel.private sequences math namespaces init splitting assocs system.private layouts words ; +IN: system -SINGLETON: x86.32 -SINGLETON: x86.64 -SINGLETON: arm -SINGLETON: ppc +SINGLETONS: x86.32 x86.64 arm ppc ; UNION: x86 x86.32 x86.64 ; : cpu ( -- class ) \ cpu get-global ; foldable -SINGLETON: winnt -SINGLETON: wince +SINGLETONS: winnt wince ; UNION: windows winnt wince ; -SINGLETON: freebsd -SINGLETON: netbsd -SINGLETON: openbsd -SINGLETON: solaris -SINGLETON: macosx -SINGLETON: linux +SINGLETONS: freebsd netbsd openbsd solaris macosx linux ; SINGLETON: haiku @@ -62,11 +53,6 @@ PRIVATE> : vm ( -- path ) \ vm get-global ; -[ - 8 getenv string>cpu \ cpu set-global - 9 getenv string>os \ os set-global -] "system" add-init-hook - : embedded? ( -- ? ) 15 getenv ; : millis ( -- ms ) micros 1000 /i ; diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index e0d6fd4493..03d234807d 100644 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -106,7 +106,7 @@ HELP: reload HELP: require { $values { "vocab" "a vocabulary specifier" } } { $description "Loads a vocabulary if it has not already been loaded." } -{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ; +{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "vocabs.refresh" } "." } ; HELP: run { $values { "vocab" "a vocabulary specifier" } } diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index f7c8a89e8c..09f28541e0 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -1,9 +1,9 @@ -IN: vocabs.loader.tests USING: vocabs.loader tools.test continuations vocabs math kernel arrays sequences namespaces io.streams.string parser source-files words assocs classes.tuple definitions -debugger compiler.units tools.vocabs accessors eval -combinators vocabs.parser grouping ; +debugger compiler.units accessors eval +combinators vocabs.parser grouping vocabs.files vocabs.refresh ; +IN: vocabs.loader.tests ! This vocab should not exist, but just in case... [ ] [ @@ -18,13 +18,6 @@ combinators vocabs.parser grouping ; [ t ] [ "kernel" >vocab-link "kernel" vocab = ] unit-test -[ t ] [ - "kernel" vocab-files - "kernel" vocab vocab-files - "kernel" vocab-files - 3array all-equal? -] unit-test - IN: vocabs.loader.test.2 : hello ( -- ) ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 2b978e8666..6c12b7b325 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -65,8 +65,22 @@ M: object vocab-main vocab vocab-main ; M: f vocab-main ; +SYMBOL: vocab-observers + +GENERIC: vocabs-changed ( obj -- ) + +: add-vocab-observer ( obj -- ) + vocab-observers get push ; + +: remove-vocab-observer ( obj -- ) + vocab-observers get delq ; + +: notify-vocab-observers ( -- ) + vocab-observers get [ vocabs-changed ] each ; + : create-vocab ( name -- vocab ) - dictionary get [ ] cache ; + dictionary get [ ] cache + notify-vocab-observers ; ERROR: no-vocab name ; @@ -99,7 +113,8 @@ M: string >vocab-link dup vocab [ ] [ ] ?if ; : forget-vocab ( vocab -- ) dup words forget-all - vocab-name dictionary get delete-at ; + vocab-name dictionary get delete-at + notify-vocab-observers ; M: vocab-spec forget* forget-vocab ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 94609a06e5..3725086f70 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -1,5 +1,5 @@ USING: definitions help.markup help.syntax kernel parser -kernel.private words.private vocabs classes quotations +kernel.private vocabs classes quotations strings effects compiler.units ; IN: words @@ -163,15 +163,6 @@ $nl ABOUT: "words" -HELP: execute ( word -- ) -{ $values { "word" word } } -{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." } -{ $examples - { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } -} ; - -{ execute POSTPONE: execute( } related-words - HELP: deferred { $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ; diff --git a/core/words/words.factor b/core/words/words.factor index eb0599db78..c01cf13bcd 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions graphs assocs kernel -kernel.private slots.private math namespaces sequences strings -vectors sbufs quotations assocs hashtables sorting words.private -vocabs math.order sets ; +kernel.private kernel.private slots.private math namespaces sequences +strings vectors sbufs quotations assocs hashtables sorting vocabs +math.order sets ; IN: words : word ( -- word ) \ word get-global ; @@ -154,8 +154,17 @@ M: word reset-word : reset-generic ( word -- ) [ subwords forget-all ] [ reset-word ] - [ { "methods" "combination" "default-method" } reset-props ] - tri ; + [ + f >>pic-def + f >>pic-tail-def + { + "methods" + "combination" + "default-method" + "engines" + "decision-tree" + } reset-props + ] tri ; : gensym ( -- word ) "( gensym )" f ; diff --git a/extra/audio/audio.factor b/extra/audio/audio.factor new file mode 100644 index 0000000000..04df36ebd6 --- /dev/null +++ b/extra/audio/audio.factor @@ -0,0 +1,23 @@ +USING: accessors alien arrays combinators kernel math openal ; +IN: audio + +TUPLE: audio + { channels integer } + { sample-bits integer } + { sample-rate integer } + { size integer } + { data c-ptr } ; + +C:
@@ -89,8 +89,8 @@ IN: mason.report timings-table "Load failures" - load-everything-vocabs-file - load-everything-errors-file + load-all-vocabs-file + load-all-errors-file error-dump "Compiler errors" @@ -112,15 +112,14 @@ IN: mason.report benchmark-error-vocabs-file benchmark-error-messages-file error-dump - - "Benchmark timings" + benchmarks-file eval-file benchmarks-table ] output>array ] with-report ; : build-clean? ( -- ? ) { - [ load-everything-vocabs-file eval-file empty? ] + [ load-all-vocabs-file eval-file empty? ] [ test-all-vocabs-file eval-file empty? ] [ help-lint-vocabs-file eval-file empty? ] [ compiler-errors-file eval-file empty? ] diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 22b932ac5b..d50c77f71b 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -3,14 +3,15 @@ USING: accessors assocs benchmark bootstrap.stage2 compiler.errors source-files.errors generic help.html help.lint io.directories io.encodings.utf8 io.files kernel mason.common math namespaces -prettyprint sequences sets sorting tools.test tools.time tools.vocabs -words system io tools.errors locals ; +prettyprint sequences sets sorting tools.test tools.time +words system io tools.errors vocabs.hierarchy vocabs.errors +vocabs.refresh locals ; IN: mason.test : do-load ( -- ) - try-everything - [ keys load-everything-vocabs-file to-file ] - [ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ] + "" (load) + [ keys load-all-vocabs-file to-file ] + [ load-all-errors-file utf8 [ load-failures. ] with-file-writer ] bi ; GENERIC: word-vocabulary ( word -- vocabulary ) diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor index 20b73ba678..d1fd602f72 100644 --- a/extra/math/affine-transforms/affine-transforms.factor +++ b/extra/math/affine-transforms/affine-transforms.factor @@ -17,6 +17,8 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0 [ drop origin>> ] 2tri v+ v+ ; +: ( -- a ) + { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } ; : ( origin -- a ) [ { 1.0 0.0 } { 0.0 1.0 } ] dip ; : ( theta -- transform ) diff --git a/extra/merger/deploy.factor b/extra/merger/deploy.factor new file mode 100644 index 0000000000..54535d5bc8 --- /dev/null +++ b/extra/merger/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-math? t } + { deploy-io 2 } + { deploy-unicode? t } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { deploy-ui? t } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-name "Merger" } + { deploy-word-props? f } + { deploy-threads? t } + { deploy-word-defs? f } +} diff --git a/extra/merger/merger.factor b/extra/merger/merger.factor new file mode 100644 index 0000000000..c4986bf47f --- /dev/null +++ b/extra/merger/merger.factor @@ -0,0 +1,30 @@ +USING: accessors arrays fry io.directories kernel models sequences sets ui +ui.gadgets ui.gadgets.buttons ui.gadgets.labeled +ui.gadgets.tracks ui.gadgets.labels ui.gadgets.glass +math.rectangles cocoa.dialogs ; +IN: merger +: main ( -- ) [ + vertical + { "From:" "To:" } f f 2array + [ + [ + "…" [ + open-panel [ first + [