diff --git a/.gitignore b/.gitignore index 22dda8efb4..b52c593b49 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,5 @@ build-support/wordsize .#* *.swo checksums.txt +*.so +a.out diff --git a/Makefile b/Makefile old mode 100644 new mode 100755 index 5e63017218..18cb7d15c7 --- a/Makefile +++ b/Makefile @@ -1,4 +1,5 @@ CC = gcc +CPP = g++ AR = ar LD = ld @@ -7,18 +8,18 @@ CONSOLE_EXECUTABLE = factor-console TEST_LIBRARY = factor-ffi-test VERSION = 0.92 -IMAGE = factor.image 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 @@ -27,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) @@ -151,22 +163,28 @@ macosx.app: factor @executable_path/../Frameworks/libfactor.dylib \ Factor.app/Contents/MacOS/factor -factor: $(DLL_OBJS) $(EXE_OBJS) +$(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) -factor-console: $(DLL_OBJS) $(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) -factor-ffi-test: vm/ffi_test.o +$(TEST_LIBRARY): vm/ffi_test.o $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS) clean: rm -f vm/*.o - rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,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 @@ -177,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 c5d53de842..addbe38f0d 100755 --- a/README.txt +++ b/README.txt @@ -20,7 +20,7 @@ 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 +The Factor runtime is written in GNU C++, and is built with GNU make and gcc. Factor supports various platforms. For an up-to-date list, see @@ -59,10 +59,10 @@ On Unix, Factor can either run a graphical user interface using X11, or a terminal listener. For X11 support, you need recent development libraries for libc, -Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution +Pango, X11, and OpenGL. On a Debian-derived Linux distribution (like Ubuntu), you can use the following line to grab everything: - sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev + sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev If your DISPLAY environment variable is set, the UI will start automatically: @@ -138,7 +138,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/ - sources for the Factor VM, written in C++ core/ - Factor core library basis/ - Factor basis library, compiler, tools extra/ - more libraries and applications diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor index d1161e4cee..7c64680a83 100644 --- a/basis/alarms/alarms-tests.factor +++ b/basis/alarms/alarms-tests.factor @@ -15,5 +15,3 @@ tools.test threads concurrency.count-downs ; [ resume ] curry instant later drop ] "test" suspend drop ] unit-test - -\ alarm-thread-loop must-infer 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-tests.factor b/basis/alien/c-types/c-types-tests.factor index 988dc180e0..ea9e881fd4 100644 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -2,8 +2,6 @@ IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc alien.strings io.encodings.utf8 ; -\ expand-constants must-infer - CONSTANT: xyz 123 [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index dc35f8bbb0..9cd57f61ab 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 ; diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor index 71efa1aa24..b27c62b9a1 100644 --- a/basis/alien/fortran/fortran.factor +++ b/basis/alien/fortran/fortran.factor @@ -8,7 +8,7 @@ io.encodings.ascii io.encodings.string shuffle effects math.ranges math.order sorting strings system alien.libraries ; IN: alien.fortran -SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ; +SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ; << : add-f2c-libraries ( -- ) @@ -42,30 +42,35 @@ library-fortran-abis [ H{ } clone ] initialize HOOK: fortran-c-abi fortran-abi ( -- abi ) M: f2c-abi fortran-c-abi "cdecl" ; +M: g95-abi fortran-c-abi "cdecl" ; M: gfortran-abi fortran-c-abi "cdecl" ; M: intel-unix-abi fortran-c-abi "cdecl" ; M: intel-windows-abi fortran-c-abi "cdecl" ; HOOK: real-functions-return-double? fortran-abi ( -- ? ) M: f2c-abi real-functions-return-double? t ; +M: g95-abi real-functions-return-double? f ; M: gfortran-abi real-functions-return-double? f ; M: intel-unix-abi real-functions-return-double? f ; M: intel-windows-abi real-functions-return-double? f ; HOOK: complex-functions-return-by-value? fortran-abi ( -- ? ) M: f2c-abi complex-functions-return-by-value? f ; +M: g95-abi complex-functions-return-by-value? f ; M: gfortran-abi complex-functions-return-by-value? t ; M: intel-unix-abi complex-functions-return-by-value? f ; M: intel-windows-abi complex-functions-return-by-value? f ; HOOK: character(1)-maps-to-char? fortran-abi ( -- ? ) M: f2c-abi character(1)-maps-to-char? f ; +M: g95-abi character(1)-maps-to-char? f ; M: gfortran-abi character(1)-maps-to-char? f ; M: intel-unix-abi character(1)-maps-to-char? t ; M: intel-windows-abi character(1)-maps-to-char? t ; HOOK: mangle-name fortran-abi ( name -- name' ) M: f2c-abi mangle-name lowercase-name-with-extra-underscore ; +M: g95-abi mangle-name lowercase-name-with-extra-underscore ; M: gfortran-abi mangle-name lowercase-name-with-underscore ; M: intel-unix-abi mangle-name lowercase-name-with-underscore ; M: intel-windows-abi mangle-name >upper ; diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor old mode 100644 new mode 100755 index 3b9c56c8fb..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" } @@ -58,3 +58,10 @@ $nl "} cond >>" } "Note the parse time evaluation with " { $link POSTPONE: << } "." } ; + +ARTICLE: "loading-libs" "Loading native libraries" +"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:" +{ $subsection add-library } +"Once a library has been defined, you can try loading it to see if the path name is correct:" +{ $subsection load-library } +"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ; diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor index 3fcc15974c..6c18065ab6 100644 --- 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 ) [ native-string>alien ] 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/parser/parser.factor b/basis/alien/parser/parser.factor index 193893fabc..df1dd15bfb 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays assocs effects grouping kernel -parser sequences splitting words fry locals ; +parser sequences splitting words fry locals lexer namespaces ; IN: alien.parser : parse-arglist ( parameters return -- types effect ) @@ -12,8 +12,15 @@ IN: alien.parser : function-quot ( return library function types -- quot ) '[ _ _ _ _ alien-invoke ] ; -:: define-function ( return library function parameters -- ) +:: make-function ( return library function parameters -- word quot effect ) function create-in dup reset-generic return library function - parameters return parse-arglist [ function-quot ] dip - define-declared ; + parameters return parse-arglist [ function-quot ] dip ; + +: (FUNCTION:) ( -- word quot effect ) + scan "c-library" get scan ";" parse-tokens + [ "()" subseq? not ] filter + make-function ; + +: define-function ( return library function parameters -- ) + make-function define-declared ; 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/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 6a1bf7f635..0cc6d51446 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -16,9 +16,7 @@ SYNTAX: BAD-ALIEN parsed ; SYNTAX: LIBRARY: scan "c-library" set ; SYNTAX: FUNCTION: - scan "c-library" get scan ";" parse-tokens - [ "()" subseq? not ] filter - define-function ; + (FUNCTION:) define-declared ; SYNTAX: TYPEDEF: scan scan typedef ; diff --git a/extra/advice/tags.txt b/basis/alien/syntax/tags.txt similarity index 100% rename from extra/advice/tags.txt rename to basis/alien/syntax/tags.txt diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor index ddefff35bb..9094286575 100644 --- a/basis/base64/base64-tests.factor +++ b/basis/base64/base64-tests.factor @@ -23,5 +23,5 @@ IN: base64.tests ascii encode >base64-lines >string ] unit-test -\ >base64 must-infer -\ base64> must-infer +[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ] +[ malformed-base64? ] must-fail-with diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index c51d871bb5..47147fa306 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces sequences strings io.crlf ; IN: base64 +ERROR: malformed-base64 ; + ch swap 6 shift bitor ] reduce 3 >be ] [ [ CHAR: = = ] count ] bi head-slice* diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor index cf7915159a..20b33a0bcb 100644 --- a/basis/binary-search/binary-search-docs.factor +++ b/basis/binary-search/binary-search-docs.factor @@ -14,7 +14,7 @@ $nl HELP: sorted-index { $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } } -{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." } +{ $description "Outputs the index of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." } { $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ; { index index-from last-index last-index-from sorted-index } related-words diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor index 77b1c16505..63d2697418 100644 --- a/basis/binary-search/binary-search-tests.factor +++ b/basis/binary-search/binary-search-tests.factor @@ -1,8 +1,6 @@ IN: binary-search.tests USING: binary-search math.order vectors kernel tools.test ; -\ sorted-member? must-infer - [ f ] [ 3 { } [ <=> ] with search drop ] unit-test [ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test [ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 617073bbc4..7940703140 100644 --- 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 @@ -108,7 +111,7 @@ nl "." write flush -{ (compile) } compile-unoptimized +{ compile-word } compile-unoptimized "." write flush diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor index 36f6291bc6..ab08aa87a9 100644 --- a/basis/bootstrap/finish-bootstrap.factor +++ b/basis/bootstrap/finish-bootstrap.factor @@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ; (command-line) parse-command-line load-vocab-roots run-user-init - "e" get [ eval ] when* + "e" get [ eval( -- ) ] when* ignore-cli-args? not script get and [ run-script ] [ "run" get run ] if* output-stream get [ stream-flush ] when* diff --git a/basis/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor index c432a47ea4..e7070d3cf2 100644 --- a/basis/bootstrap/image/image-tests.factor +++ b/basis/bootstrap/image/image-tests.factor @@ -2,9 +2,6 @@ IN: bootstrap.image.tests USING: bootstrap.image bootstrap.image.private tools.test kernel math ; -\ ' must-infer -\ write-image must-infer - [ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test [ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 504afae018..cad40b6384 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 ; IN: bootstrap.image : arch ( os cpu -- arch ) @@ -94,13 +93,30 @@ CONSTANT: -1-offset 9 SYMBOL: sub-primitives -: make-jit ( quot rc rt offset -- quad ) - [ [ call( -- ) ] { } make ] 3dip 4array ; +SYMBOL: jit-define-rc +SYMBOL: jit-define-rt +SYMBOL: jit-define-offset -: jit-define ( quot rc rt offset name -- ) +: compute-offset ( -- offset ) + building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ; + +: jit-rel ( rc rt -- ) + jit-define-rt set + jit-define-rc set + compute-offset jit-define-offset set ; + +: make-jit ( quot -- quad ) + [ + call( -- ) + jit-define-rc get + jit-define-rt get + jit-define-offset get 3array + ] 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 @@ -119,7 +135,6 @@ SYMBOL: bootstrap-global SYMBOL: bootstrap-boot-quot ! JIT parameters -SYMBOL: jit-code-format SYMBOL: jit-prolog SYMBOL: jit-primitive-word SYMBOL: jit-primitive @@ -129,20 +144,36 @@ 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-execute-word +SYMBOL: jit-execute-jump +SYMBOL: jit-execute-call SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling -SYMBOL: jit-declare-word SYMBOL: jit-save-stack +! PIC stubs +SYMBOL: pic-load +SYMBOL: pic-tag +SYMBOL: pic-hi-tag +SYMBOL: pic-tuple +SYMBOL: pic-hi-tag-tuple +SYMBOL: pic-check-tag +SYMBOL: pic-check +SYMBOL: pic-hit +SYMBOL: pic-miss-word + +! Megamorphic dispatch +SYMBOL: mega-lookup +SYMBOL: mega-lookup-word +SYMBOL: mega-miss-word + ! Default definition for undefined words SYMBOL: undefined-quot @@ -150,7 +181,6 @@ SYMBOL: undefined-quot H{ { bootstrap-boot-quot 20 } { bootstrap-global 21 } - { jit-code-format 22 } { jit-prolog 23 } { jit-primitive-word 24 } { jit-primitive 25 } @@ -159,20 +189,32 @@ SYMBOL: undefined-quot { 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 } + { jit-save-stack 38 } + { jit-dip-word 39 } + { jit-dip 40 } + { jit-2dip-word 41 } + { jit-2dip 42 } + { jit-3dip-word 43 } + { jit-3dip 44 } + { jit-execute-word 45 } + { jit-execute-jump 46 } + { jit-execute-call 47 } + { pic-load 48 } + { pic-tag 49 } + { pic-hi-tag 50 } + { pic-tuple 51 } + { pic-hi-tag-tuple 52 } + { pic-check-tag 53 } + { pic-check 54 } + { pic-hit 55 } + { pic-miss-word 56 } + { mega-lookup 57 } + { mega-lookup-word 58 } + { mega-miss-word 59 } { undefined-quot 60 } } ; inline @@ -205,8 +247,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 +293,7 @@ GENERIC: ' ( obj -- ptr ) M: bignum ' [ - bignum tag-number dup [ emit-bignum ] emit-object + bignum [ emit-bignum ] emit-object ] cache-object ; ! Fixnums @@ -274,7 +316,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 +351,7 @@ M: f ' [ vocabulary>> , ] [ def>> , ] [ props>> , ] - [ drop f , ] + [ direct-entry-def>> , ] ! direct-entry-def [ drop 0 , ] ! count [ word-sub-primitive , ] [ drop 0 , ] ! xt @@ -318,8 +360,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 +381,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 +410,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 +427,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 +445,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 +460,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 +486,7 @@ M: tuple-layout-array ' M: quotation ' [ array>> ' - quotation type-number object tag-number [ + quotation [ emit ! array f ' emit ! compiled f ' emit ! cached-effect @@ -480,15 +518,16 @@ M: quotation ' : 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 + \ (execute) jit-execute-word set + \ inline-cache-miss \ pic-miss-word set + \ mega-cache-lookup \ mega-lookup-word set + \ mega-cache-miss \ mega-miss-word set [ undefined ] undefined-quot set { - jit-code-format jit-prolog jit-primitive-word jit-primitive @@ -498,19 +537,31 @@ M: quotation ' 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-execute-word + jit-execute-jump + jit-execute-call jit-epilog jit-return jit-profiling - jit-declare-word jit-save-stack + pic-load + pic-tag + pic-hi-tag + pic-tuple + pic-hi-tag-tuple + pic-check-tag + pic-check + pic-hit + pic-miss-word + mega-lookup + mega-lookup-word + mega-miss-word undefined-quot } [ emit-userenv ] each ; diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 6c824b6155..9d19e4a231 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -4,7 +4,7 @@ USING: accessors init namespaces words words.symbol io kernel.private math memory continuations kernel io.files io.pathnames io.backend system parser vocabs sequences vocabs.loader combinators splitting source-files strings -definitions assocs compiler.errors compiler.units math.parser +definitions assocs compiler.units math.parser generic sets command-line ; IN: bootstrap.stage2 @@ -16,13 +16,6 @@ SYMBOL: bootstrap-time vm file-name os windows? [ "." split1-last drop ] when ".image" append resource-path ; -: do-crossref ( -- ) - "Cross-referencing..." print flush - H{ } clone crossref set-global - xref-words - xref-generics - xref-sources ; - : load-components ( -- ) "include" "exclude" [ get-global " " split harvest ] bi@ @@ -42,14 +35,17 @@ 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 ; +: save/restore-error ( quot -- ) + error get-global + error-continuation get-global + [ call ] 2dip + error-continuation set-global + error set-global ; inline + [ ! We time bootstrap millis @@ -61,8 +57,6 @@ SYMBOL: bootstrap-time (command-line) parse-command-line - do-crossref - ! Set dll paths os wince? [ "windows.ce" require ] when os winnt? [ "windows.nt" require ] when @@ -70,18 +64,18 @@ SYMBOL: bootstrap-time "staging" get "deploy-vocab" get or [ "stage2: deployment mode" print ] [ + "debugger" require + "inspector" require + "tools.errors" require "listener" require "none" require ] if - [ - load-components + load-components - millis over - core-bootstrap-time set-global + millis over - core-bootstrap-time set-global - run-bootstrap-init - ] with-compiler-errors - :errors + run-bootstrap-init f error set-global f error-continuation set-global @@ -104,6 +98,7 @@ SYMBOL: bootstrap-time drop [ load-help? off - "vocab:bootstrap/bootstrap-error.factor" run-file + [ "vocab:bootstrap/bootstrap-error.factor" parse-file ] save/restore-error + call ] with-scope ] recover diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor index b0afe4a1d9..6017469925 100644 --- a/basis/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -6,6 +6,7 @@ IN: bootstrap.tools "bootstrap.image" "tools.annotations" "tools.crossref" + "tools.errors" "tools.deploy" "tools.disassembler" "tools.memory" @@ -13,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/calendar-tests.factor b/basis/calendar/calendar-tests.factor index b6d8e74072..8d1071122d 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -1,11 +1,7 @@ USING: arrays calendar kernel math sequences tools.test -continuations system math.order threads ; +continuations system math.order threads accessors ; IN: calendar.tests -\ time+ must-infer -\ time* must-infer -\ time- must-infer - [ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test [ f ] [ 2004 2 30 0 0 0 instant valid-timestamp? ] unit-test [ f ] [ 2003 2 29 0 0 0 instant valid-timestamp? ] unit-test @@ -167,3 +163,10 @@ IN: calendar.tests [ t ] [ now 50 milliseconds sleep now before? ] unit-test [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test + +[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test +[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test + +[ f ] [ now dup midnight eq? ] unit-test +[ f ] [ now dup easter eq? ] unit-test +[ f ] [ now dup beginning-of-year eq? ] unit-test diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 7a03fe4408..4b58b1b496 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.tuple combinators combinators.short-circuit - kernel locals math math.functions math.order namespaces sequences strings - summary system threads vocabs.loader ; +USING: accessors arrays classes.tuple combinators +combinators.short-circuit kernel locals math math.functions +math.order sequences summary system threads vocabs.loader ; IN: calendar HOOK: gmt-offset os ( -- hours minutes seconds ) @@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3 :: julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 - [let* | a [ 14 month - 12 /i ] - y [ year 4800 + a - ] - m [ month 12 a * + 3 - ] | - day 153 m * 2 + 5 /i + 365 y * + - y 4 /i + y 100 /i - y 400 /i + 32045 - - ] ; + 14 month - 12 /i :> a + year 4800 + a - :> y + month 12 a * + 3 - :> m + + day 153 m * 2 + 5 /i + 365 y * + + y 4 /i + y 100 /i - y 400 /i + 32045 - ; :: julian-day-number>date ( n -- year month day ) #! Inverse of julian-day-number - [let* | a [ n 32044 + ] - b [ 4 a * 3 + 146097 /i ] - c [ a 146097 b * 4 /i - ] - d [ 4 c * 3 + 1461 /i ] - e [ c 1461 d * 4 /i - ] - m [ 5 e * 2 + 153 /i ] | - 100 b * d + 4800 - - m 10 /i + m 3 + - 12 m 10 /i * - - e 153 m * 2 + 5 /i - 1+ - ] ; + n 32044 + :> a + 4 a * 3 + 146097 /i :> b + a 146097 b * 4 /i - :> c + 4 c * 3 + 1461 /i :> d + c 1461 d * 4 /i - :> e + 5 e * 2 + 153 /i :> m + + 100 b * d + 4800 - + m 10 /i + m 3 + + 12 m 10 /i * - + e 153 m * 2 + 5 /i - 1+ ; + +GENERIC: easter ( obj -- obj' ) + +:: easter-month-day ( year -- month day ) + year 19 mod :> a + year 100 /mod :> c :> b + b 4 /mod :> e :> d + b 8 + 25 /i :> f + b f - 1 + 3 /i :> g + 19 a * b + d - g - 15 + 30 mod :> h + c 4 /mod :> k :> i + 32 2 e * + 2 i * + h - k - 7 mod :> l + a 11 h * + 22 l * + 451 /i :> m + + h l + 7 m * - 114 + 31 /mod 1 + :> day :> month + month day ; + +M: integer easter ( year -- timestamp ) + dup easter-month-day ; + +M: timestamp easter ( timestamp -- timestamp ) + clone + dup year>> easter-month-day + swapd >>day swap >>month ; : >date< ( timestamp -- year month day ) [ year>> ] [ month>> ] [ day>> ] tri ; diff --git a/basis/calendar/format/macros/macros-tests.factor b/basis/calendar/format/macros/macros-tests.factor index 544332770f..4ba2872b43 100644 --- a/basis/calendar/format/macros/macros-tests.factor +++ b/basis/calendar/format/macros/macros-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test kernel ; +USING: tools.test kernel accessors ; IN: calendar.format.macros [ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test @@ -10,6 +10,6 @@ IN: calendar.format.macros : compiled-test-1 ( -- n ) { [ 1 throw ] [ 2 ] } attempt-all-quots ; -\ compiled-test-1 must-infer +\ compiled-test-1 def>> must-infer [ 2 ] [ compiled-test-1 ] unit-test 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/md5/md5.factor b/basis/checksums/md5/md5.factor index 04c6c2497e..29620b089d 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -14,7 +14,7 @@ IN: checksums.md5 SYMBOLS: a b c d old-a old-b old-c old-d ; : T ( N -- Y ) - sin abs 4294967296 * >integer ; foldable + sin abs 32 2^ * >integer ; foldable : initialize-md5 ( -- ) 0 bytes-read set diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 69d698f9b1..3e933e6643 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -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 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/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/colors/colors-docs.factor b/basis/colors/colors-docs.factor index 8881d89711..5e2b09380d 100644 --- a/basis/colors/colors-docs.factor +++ b/basis/colors/colors-docs.factor @@ -23,7 +23,7 @@ $nl ARTICLE: "colors" "Colors" "The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them." $nl -"RGBA colors:" +"RGBA colors with floating point components in the range " { $snippet "[0,1]" } ":" { $subsection rgba } { $subsection } "Converting a color to RGBA:" diff --git a/basis/combinators/short-circuit/smart/tags.txt b/basis/combinators/short-circuit/smart/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/combinators/short-circuit/smart/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/combinators/short-circuit/tags.txt b/basis/combinators/short-circuit/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/combinators/short-circuit/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 75f83c1a55..d8ee89ef2d 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations math sequences -multiline ; +multiline stack-checker ; IN: combinators.smart HELP: inputsequence } { $subsection output>array } -"Reducing the output of a quotation:" +"Reducing the set of output values:" { $subsection reduce-outputs } -"Summing the output of a quotation:" +"Summing output values:" { $subsection sum-outputs } -"Appending the results of a quotation:" +"Concatenating output values:" { $subsection append-outputs } -{ $subsection append-outputs-as } ; +{ $subsection append-outputs-as } +"New smart combinators can be created by defining " { $link "macros" } " which call " { $link infer } "." ; ABOUT: "combinators.smart" diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 1cca697dde..a18ef1f3b8 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test combinators.smart math kernel ; +USING: tools.test combinators.smart math kernel accessors ; IN: combinators.smart.tests : test-bi ( -- 9 11 ) @@ -42,7 +42,7 @@ IN: combinators.smart.tests : nested-smart-combo-test ( -- array ) [ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ; -\ nested-smart-combo-test must-infer +\ nested-smart-combo-test def>> must-infer [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test 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/combinators/smart/tags.txt b/basis/combinators/smart/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/combinators/smart/tags.txt @@ -0,0 +1 @@ +extensions 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 73a01aa352..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 @@ -60,7 +60,6 @@ SYMBOL: main-vocab-hook : default-cli-args ( -- ) global [ "quiet" off - "script" off "e" off "user-init" on embedded? "quiet" set diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 0b303a8a43..58eae8181b 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -5,8 +5,6 @@ math.private compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays kernel.private math ; -\ build-cfg must-infer - ! Just ensure that various CFGs build correctly. : unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 6d0a8f8c8e..6b0aba6813 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -16,7 +16,7 @@ M: callable test-cfg build-tree optimize-tree gensym build-cfg ; M: word test-cfg - [ build-tree-from-word optimize-tree ] keep build-cfg ; + [ build-tree optimize-tree ] keep build-cfg ; SYMBOL: allocate-registers? 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/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index 8d00a14ea2..908bf2475b 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -99,7 +99,7 @@ SYMBOL: spill-counts : interval-to-spill ( active-intervals current -- live-interval ) #! We spill the interval with the most distant use location. start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc - unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ; + [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ; : assign-spill ( before after -- before after ) #! If it has been spilled already, reuse spill location. diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor index 9efc23651b..13c1783711 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor @@ -1,4 +1,4 @@ USING: compiler.cfg.linear-scan.assignment tools.test ; IN: compiler.cfg.linear-scan.assignment.tests -\ assign-registers must-infer + diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor index 5e866d15db..fe8b4fd0c0 100644 --- a/basis/compiler/cfg/linearization/linearization-tests.factor +++ b/basis/compiler/cfg/linearization/linearization-tests.factor @@ -1,4 +1,4 @@ IN: compiler.cfg.linearization.tests USING: compiler.cfg.linearization tools.test ; -\ build-mr must-infer + 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 65e70bd042..826fa87b73 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -3,8 +3,9 @@ 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 compiler.alien compiler.cfg @@ -43,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 @@ -374,47 +375,21 @@ M: long-long-type flatten-value-type ( type -- types ) : box-return* ( node -- ) return>> [ ] [ box-return ] if-void ; -TUPLE: no-such-library name ; - -M: no-such-library summary - drop "Library not found" ; - -M: no-such-library compiler-error-type - drop +linkage+ ; - -: no-such-library ( name -- ) - \ no-such-library boa - compiling-word get compiler-error ; - -TUPLE: no-such-symbol name ; - -M: no-such-symbol summary - drop "Symbol not found" ; - -M: no-such-symbol compiler-error-type - drop +linkage+ ; - -: no-such-symbol ( name -- ) - \ no-such-symbol boa - compiling-word get compiler-error ; - : check-dlsym ( symbols dll -- ) dup dll-valid? [ dupd '[ _ dlsym ] any? - [ drop ] [ no-such-symbol ] if + [ drop ] [ compiling-word get no-such-symbol ] if ] [ - dll-path no-such-library drop + dll-path compiling-word get no-such-library drop ] if ; -: stdcall-mangle ( symbol node -- symbol ) - "@" - swap parameters>> parameter-sizes drop - number>string 3append ; +: stdcall-mangle ( symbol params -- symbol ) + parameters>> parameter-sizes drop number>string "@" glue ; : alien-invoke-dlsym ( params -- symbols dll ) - dup function>> dup pick stdcall-mangle 2array - swap library>> library dup [ dll>> ] when - 2dup check-dlsym ; + [ [ function>> dup ] keep stdcall-mangle 2array ] + [ library>> library dup [ dll>> ] when ] + bi 2dup check-dlsym ; M: ##alien-invoke generate-insn params>> diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 3a047a8d39..99f258d93c 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,9 @@ SYMBOL: literal-table : rel-word ( word class -- ) [ add-literal ] dip rt-xt rel-fixup ; +: rel-word-direct ( word class -- ) + [ add-literal ] dip rt-xt-direct rel-fixup ; + : rel-primitive ( word class -- ) [ def>> first add-literal ] dip rt-primitive rel-fixup ; @@ -88,4 +89,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 f19225a45c..306ab515a8 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -1,23 +1,43 @@ -USING: help.markup help.syntax words io parser -assocs words.private sequences compiler.units quotations ; +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 ; 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:" { $subsection compile-call } "Higher-level words can be found in " { $link "compilation-units" } "." ; +ARTICLE: "compiler-impl" "Compiler implementation" +"The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop." +$nl +"Words are added to the " { $link compile-queue } " variable as needed and compiled." +{ $subsection compile-queue } +"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "." +$nl +"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:" +{ $list + { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring certain compile errors generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." } + { "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." } + { "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." } + { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." } +} +"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler." +$nl +"Calling " { $link modify-code-heap } " is handled not by the " { $vocab-link "compiler" } " vocabulary, but rather " { $vocab-link "compiler.units" } ". The optimizing compiler merely provides an implementation of the " { $link recompile } " generic word." ; + ARTICLE: "compiler" "Optimizing compiler" "Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process." $nl @@ -26,12 +46,13 @@ $nl { "The " { $emphasis "non-optimizing quotation compiler" } " compiles quotations to naive machine code very quickly. The non-optimizing quotation compiler is part of the VM." } { "The " { $emphasis "optimizing word compiler" } " compiles whole words at a time while performing extensive data and control flow analysis. This provides greater performance for generated code, but incurs a much longer compile time. The optimizing compiler is written in Factor." } } -"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." -$nl "The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information." +$nl +"Most code you write will run with the optimizing compiler. Sometimes, the non-optimizing compiler is used, for example for listener interactions, or for running the quotation passed to " { $link POSTPONE: call( } "." { $subsection "compiler-errors" } { $subsection "hints" } -{ $subsection "compiler-usage" } ; +{ $subsection "compiler-usage" } +{ $subsection "compiler-impl" } ; ABOUT: "compiler" @@ -39,7 +60,7 @@ HELP: decompile { $values { "word" word } } { $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ; -HELP: (compile) +HELP: compile-word { $values { "word" word } } { $description "Compile a single word." } { $notes "This is an internal word, and user code should call " { $link compile } " instead." } ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 04c1a9c55f..e418f0ef60 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,8 +2,9 @@ ! 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 stack-checker -stack-checker.state stack-checker.inlining combinators.short-circuit +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 @@ -14,7 +15,8 @@ IN: compiler SYMBOL: compile-queue SYMBOL: compiled -: queue-compile? ( word -- ? ) +: compile? ( word -- ? ) + #! Don't attempt to compile certain words. { [ "forgotten" word-prop ] [ compiled get key? ] @@ -23,61 +25,123 @@ 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 ; -: maybe-compile ( word -- ) - dup optimized>> [ drop ] [ queue-compile ] if ; +: recompile-callers? ( word -- ? ) + changed-effects get key? ; -SYMBOLS: +optimized+ +unoptimized+ ; - -: ripple-up ( words -- ) - dup "compiled-status" word-prop +unoptimized+ eq? - [ usage [ word? ] filter ] [ compiled-usage keys ] if - [ queue-compile ] each ; - -: ripple-up? ( status word -- ? ) - [ - [ nip changed-effects get key? ] - [ "compiled-status" word-prop eq? not ] 2bi or - ] keep "compiled-status" word-prop and ; - -: save-compiled-status ( word status -- ) - [ over ripple-up? [ ripple-up ] [ drop ] if ] - [ "compiled-status" set-word-prop ] - 2bi ; +: recompile-callers ( words -- ) + #! If a word's stack effect changed, recompile all words that + #! have compiled calls to it. + dup recompile-callers? + [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ; : start ( word -- ) "trace-compilation" get [ dup name>> print flush ] when H{ } clone dependencies set H{ } clone generic-dependencies set - f swap compiler-error ; + 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 -- ? ) - [ [ inline? ] [ macro? ] bi or ] - [ compiler-error-type +warning+ eq? ] bi* and ; - -: fail ( word error -- * ) - [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ] + #! Ignore some errors on inline combinators, macros, and special + #! words such as 'call'. [ - drop - [ compiled-unxref ] - [ f swap compiled get set-at ] - [ +unoptimized+ save-compiled-status ] - tri - ] 2bi - return ; + { + [ macro? ] + [ inline? ] + [ no-compile? ] + [ "special" word-prop ] + } 1|| + ] [ + { + [ do-not-compile? ] + [ literal-expected? ] + } 1|| + ] bi* and ; + +: finish ( word -- ) + #! Recompile callers if the word's stack effect changed, then + #! save the word's dependencies so that if they change, the + #! word can get recompiled too. + [ recompile-callers ] + [ compiled-unxref ] + [ + dup crossref? [ + dependencies get + generic-dependencies get + compiled-xref + ] [ drop ] if + ] tri ; + +: deoptimize-with ( word def -- * ) + #! If the word failed to infer, compile it with the + #! non-optimizing compiler. + swap [ finish ] [ compiled get set-at ] bi return ; + +: 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. + { + { [ dup inference-error? not ] [ rethrow ] } + { [ 2dup ignore-error? ] [ ignore-error ] } + [ remember-error ] + } cond ; + +: optimize? ( word -- ? ) + { + [ predicate-engine-word? ] + [ contains-breakpoints? ] + [ single-generic? ] + } 1|| not ; : frontend ( word -- nodes ) - [ build-tree-from-word ] [ fail ] recover optimize-tree ; + #! If the word contains breakpoints, don't optimize it, since + #! the walker does not support this. + dup optimize? + [ [ build-tree ] [ deoptimize ] recover optimize-tree ] + [ 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 ; ! Only switch this off for debugging. SYMBOL: compile-dependencies? t compile-dependencies? set-global +: compile-dependencies ( asm -- ) + compile-dependencies? get + [ calls>> [ compile-dependency ] each ] [ drop ] if ; + : save-asm ( asm -- ) [ [ code>> ] [ label>> ] bi compiled get set-at ] - [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ] + [ compile-dependencies ] bi ; : backend ( nodes word -- ) @@ -91,19 +155,9 @@ t compile-dependencies? set-global save-asm ] each ; -: finish ( word -- ) - [ +optimized+ save-compiled-status ] - [ compiled-unxref ] - [ - dup crossref? - [ - dependencies get - generic-dependencies get - compiled-xref - ] [ drop ] if - ] tri ; - -: (compile) ( word -- ) +: compile-word ( word -- ) + #! We return early if the word has breakpoints or if it + #! failed to infer. '[ _ { [ start ] @@ -114,30 +168,38 @@ t compile-dependencies? set-global ] with-return ; : compile-loop ( deque -- ) - [ (compile) yield-hook get call( -- ) ] slurp-deque ; + [ compile-word yield-hook get call( -- ) ] slurp-deque ; : decompile ( word -- ) - f 2array 1array modify-code-heap ; + dup def>> 2array 1array modify-code-heap ; : compile-call ( quot -- ) [ dup infer define-temp ] with-compilation-unit execute ; +\ compile-call t "no-compile" set-word-prop + SINGLETON: optimizing-compiler 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 ( -- ) - forget-errors all-words compile ; + all-words compile ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index b3757bf008..2f0494b58a 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 ; IN: compiler.constants ! These constants must match vm/memory.h @@ -11,18 +12,17 @@ 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 ) 7 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 +: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline +: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline +: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline +: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline : compiled-header-size ( -- n ) 5 bootstrap-cells ; inline ! Relocation classes @@ -41,10 +41,12 @@ 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-xt-direct 4 +CONSTANT: rt-here 5 +CONSTANT: rt-this 6 +CONSTANT: rt-immediate 7 +CONSTANT: rt-stack-chain 8 +CONSTANT: rt-untagged 9 : rc-absolute? ( n -- ? ) [ rc-absolute-ppc-2/2 = ] diff --git a/basis/opengl/glu/authors.txt b/basis/compiler/errors/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from basis/opengl/glu/authors.txt rename to basis/compiler/errors/authors.txt diff --git a/basis/compiler/errors/errors-docs.factor b/basis/compiler/errors/errors-docs.factor new file mode 100644 index 0000000000..6dbe5193aa --- /dev/null +++ b/basis/compiler/errors/errors-docs.factor @@ -0,0 +1,5 @@ +IN: compiler.errors +USING: help.markup help.syntax vocabs.loader words io +quotations words.symbol ; + +ABOUT: "compiler-errors" diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor new file mode 100644 index 0000000000..3881439fc0 --- /dev/null +++ b/basis/compiler/errors/errors.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2007, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors source-files.errors kernel namespaces assocs fry +summary ; +IN: compiler.errors + +SYMBOL: +compiler-error+ +SYMBOL: compiler-errors + +compiler-errors [ H{ } clone ] initialize + +TUPLE: compiler-error < source-file-error ; + +M: compiler-error error-type drop +compiler-error+ ; + +SYMBOL: +linkage-error+ +SYMBOL: linkage-errors + +linkage-errors [ H{ } clone ] initialize + +TUPLE: linkage-error < source-file-error ; + +M: linkage-error error-type drop +linkage-error+ ; + +: clear-compiler-error ( word -- ) + compiler-errors linkage-errors + [ get-global delete-at ] bi-curry@ bi ; + +: compiler-error ( error -- ) + dup asset>> compiler-errors get-global set-at ; + +T{ error-type + { type +compiler-error+ } + { word ":errors" } + { plural "compiler errors" } + { icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" } + { quot [ compiler-errors get values ] } + { forget-quot [ compiler-errors get delete-at ] } +} define-error-type + +: ( error word -- compiler-error ) + \ compiler-error ; + +: ( error word -- linkage-error ) + \ linkage-error ; + +: linkage-error ( error word class -- ) + '[ _ boa ] dip dup asset>> linkage-errors get set-at ; inline + +T{ error-type + { type +linkage-error+ } + { word ":linkage" } + { plural "linkage errors" } + { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" } + { quot [ linkage-errors get values ] } + { forget-quot [ linkage-errors get delete-at ] } + { fatal? f } +} define-error-type + +TUPLE: no-such-library name ; + +M: no-such-library summary drop "Library not found" ; + +: no-such-library ( name word -- ) \ no-such-library linkage-error ; + +TUPLE: no-such-symbol name ; + +M: no-such-symbol summary drop "Symbol not found" ; + +: no-such-symbol ( name word -- ) \ no-such-symbol linkage-error ; + +ERROR: not-compiled word error ; \ No newline at end of file diff --git a/core/compiler/errors/summary.txt b/basis/compiler/errors/summary.txt similarity index 100% rename from core/compiler/errors/summary.txt rename to basis/compiler/errors/summary.txt diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 4d7882ad08..42ed90d64a 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string memory system threads tools.test math accessors combinators specialized-arrays.float alien.libraries io.pathnames io.backend ; -IN: compiler.tests +IN: compiler.tests.alien << : libfactor-ffi-tests-path ( -- string ) 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 2e02e5476c..8fbe13ce51 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping make ; -IN: compiler.tests +IN: compiler.tests.codegen ! Originally, this file did black box testing of templating ! optimization. We now have a different codegen, but the tests @@ -26,7 +26,7 @@ IN: compiler.tests [ 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 @@ -281,4 +281,4 @@ TUPLE: cucumber ; M: cucumber equal? "The cucumber has no equal" throw ; -[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test \ No newline at end of file +[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index 2d1f15b9a8..32611ba87a 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -1,6 +1,6 @@ USING: tools.test quotations math kernel sequences assocs namespaces make compiler.units compiler ; -IN: compiler.tests +IN: compiler.tests.curry [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index b439b5f6a4..7074b73845 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.float USING: compiler.units compiler kernel kernel.private memory math math.private tools.test math.floats.private ; @@ -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/folding.factor b/basis/compiler/tests/folding.factor index d6868fd034..5050ce1950 100644 --- a/basis/compiler/tests/folding.factor +++ b/basis/compiler/tests/folding.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel classes.mixin arrays ; -IN: compiler.tests +IN: compiler.tests.folding ! Calls to generic words were not folded away. @@ -12,7 +12,7 @@ IN: compiler.tests IN: compiler.tests.folding GENERIC: foldable-generic ( a -- b ) foldable M: integer foldable-generic f ; - "> eval + "> eval( -- ) ] unit-test [ ] [ @@ -20,7 +20,7 @@ IN: compiler.tests USING: math arrays ; IN: compiler.tests.folding : fold-test ( -- x ) 10 foldable-generic ; - "> eval + "> eval( -- ) ] unit-test [ t ] [ 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/insane.factor b/basis/compiler/tests/insane.factor deleted file mode 100644 index aa79067252..0000000000 --- a/basis/compiler/tests/insane.factor +++ /dev/null @@ -1,5 +0,0 @@ -IN: compiler.tests -USING: words kernel stack-checker alien.strings tools.test -compiler.units ; - -[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 93860db924..5ca0f3f109 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings namespaces libc sequences.private io.encodings.ascii classes compiler ; -IN: compiler.tests +IN: compiler.tests.intrinsics ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test @@ -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 3aed47ae7e..f19a950711 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 ; -IN: optimizer.tests +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 @@ -261,7 +261,7 @@ USE: binary-search.private : lift-loop-tail-test-2 ( -- a b c ) 10 [ ] lift-loop-tail-test-1 1 2 3 ; -\ lift-loop-tail-test-2 must-infer +\ lift-loop-tail-test-2 def>> must-infer [ 1 2 3 ] [ lift-loop-tail-test-2 ] 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 @@ -302,8 +302,8 @@ HINTS: recursive-inline-hang-3 array ; : member-test ( obj -- ? ) { + - * / /i } member? ; -\ member-test must-infer -[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test +\ member-test def>> must-infer +[ ] [ \ member-test build-tree optimize-tree drop ] unit-test [ t ] [ \ + member-test ] unit-test [ f ] [ \ append member-test ] unit-test @@ -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 ; -\ interval-inference-bug must-infer +[ 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,9 @@ 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 \ No newline at end of file diff --git a/basis/compiler/tests/peg-regression-2.factor b/basis/compiler/tests/peg-regression-2.factor index 1efadba3aa..7929d9e6f6 100644 --- a/basis/compiler/tests/peg-regression-2.factor +++ b/basis/compiler/tests/peg-regression-2.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.peg-regression-2 USING: peg.ebnf strings tools.test ; GENERIC: ( times -- term' ) @@ -12,4 +12,4 @@ Regexp = Times:t => [[ t ]] ;EBNF -[ "foo" ] [ "a" parse-regexp ] unit-test \ No newline at end of file +[ "foo" ] [ "a" parse-regexp ] unit-test diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor index 56a4021eed..95d454fed1 100644 --- a/basis/compiler/tests/peg-regression.factor +++ b/basis/compiler/tests/peg-regression.factor @@ -4,8 +4,8 @@ ! optimization, which would batch generic word updates at the ! end of a compilation unit. -USING: kernel accessors peg.ebnf ; -IN: compiler.tests +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/redefine0.factor b/basis/compiler/tests/redefine0.factor new file mode 100644 index 0000000000..3d7a05a74b --- /dev/null +++ b/basis/compiler/tests/redefine0.factor @@ -0,0 +1,107 @@ +IN: compiler.tests.redefine0 +USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math +namespaces macros assocs ; + +! Test ripple-up behavior +: test-1 ( -- a ) 3 ; +: test-2 ( -- ) test-1 ; + +[ test-2 ] [ not-compiled? ] must-fail-with + +[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test + +{ 0 0 } [ test-1 ] must-infer-as + +[ ] [ test-2 ] unit-test + +[ ] [ + [ + \ test-1 forget + \ test-2 forget + ] with-compilation-unit +] unit-test + +: test-3 ( a -- ) drop ; +: test-4 ( -- ) [ 1 2 3 ] test-3 ; + +[ ] [ test-4 ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test + +[ test-4 ] [ not-compiled? ] must-fail-with + +[ ] [ + [ + \ test-3 forget + \ test-4 forget + ] with-compilation-unit +] unit-test + +: test-5 ( a -- quot ) ; +: test-6 ( a -- b ) test-5 ; + +[ 31337 ] [ 31337 test-6 ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test + +[ 31337 test-6 ] [ not-compiled? ] must-fail-with + +[ ] [ + [ + \ test-5 forget + \ test-6 forget + ] with-compilation-unit +] unit-test + +GENERIC: test-7 ( a -- b ) + +M: integer test-7 + ; + +: test-8 ( a -- b ) 255 bitand test-7 ; + +[ 1 test-7 ] [ not-compiled? ] must-fail-with +[ 1 test-8 ] [ not-compiled? ] must-fail-with + +[ ] [ "IN: compiler.tests.redefine0 USING: macros math kernel ; GENERIC: test-7 ( x y -- z ) : test-8 ( a b -- c ) 255 bitand test-7 ;" eval( -- ) ] unit-test + +[ 4 ] [ 1 3 test-7 ] unit-test +[ 4 ] [ 1 259 test-8 ] unit-test + +[ ] [ + [ + \ test-7 forget + \ test-8 forget + ] with-compilation-unit +] unit-test + +! Indirect dependency on an unoptimized word +: test-9 ( -- ) ; +<< SYMBOL: quot +[ test-9 ] quot set-global >> +MACRO: test-10 ( -- quot ) quot get ; +: test-11 ( -- ) test-10 ; + +[ ] [ test-11 ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) 1 ;" eval( -- ) ] unit-test + +! test-11 should get recompiled now + +[ test-11 ] [ not-compiled? ] must-fail-with + +[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- a ) 1 ;" eval( -- ) ] unit-test + +[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) ;" eval( -- ) ] unit-test + +[ ] [ test-11 ] unit-test + +quot global delete-at + +[ ] [ + [ + \ test-9 forget + \ test-10 forget + \ test-11 forget + \ quot forget + ] with-compilation-unit +] unit-test diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index 0875967bd2..6bb623cac4 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -1,7 +1,7 @@ USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval strings ; -IN: compiler.tests +IN: compiler.tests.redefine1 GENERIC: method-redefine-generic-1 ( a -- b ) @@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ; [ 6 ] [ method-redefine-test-1 ] unit-test -[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test +[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test @@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ; [ 6 ] [ method-redefine-test-2 ] unit-test -[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test +[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test @@ -36,41 +36,3 @@ M: integer method-redefine-generic-2 3 + ; fixnum string [ \ method-redefine-generic-2 method forget ] bi@ ] with-compilation-unit ] unit-test - -! Test ripple-up behavior -: hey ( -- ) ; -: there ( -- ) hey ; - -[ t ] [ \ hey optimized>> ] unit-test -[ t ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test -[ f ] [ \ hey optimized>> ] unit-test -[ f ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test -[ t ] [ \ there optimized>> ] unit-test - -: good ( -- ) ; -: bad ( -- ) good ; -: ugly ( -- ) bad ; - -[ t ] [ \ good optimized>> ] unit-test -[ t ] [ \ bad optimized>> ] unit-test -[ t ] [ \ ugly optimized>> ] unit-test - -[ f ] [ \ good compiled-usage assoc-empty? ] unit-test - -[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test - -[ f ] [ \ good optimized>> ] unit-test -[ f ] [ \ bad optimized>> ] unit-test -[ f ] [ \ ugly optimized>> ] unit-test - -[ t ] [ \ good compiled-usage assoc-empty? ] unit-test - -[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test - -[ t ] [ \ good optimized>> ] unit-test -[ t ] [ \ bad optimized>> ] unit-test -[ t ] [ \ ugly optimized>> ] unit-test - -[ f ] [ \ good compiled-usage assoc-empty? ] unit-test diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index 8a6fb8a313..66edd75097 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine10 ! Mixin redefinition did not recompile all necessary words. @@ -13,7 +13,7 @@ IN: compiler.tests MIXIN: my-mixin INSTANCE: fixnum my-mixin : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; - "> eval + "> eval( -- ) ] unit-test [ ] [ @@ -21,7 +21,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine10 INSTANCE: float my-mixin - "> eval + "> eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor index 18b1a3a430..dbec57e3d5 100644 --- a/basis/compiler/tests/redefine11.factor +++ b/basis/compiler/tests/redefine11.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel classes.mixin arrays ; -IN: compiler.tests +IN: compiler.tests.redefine11 ! Mixin redefinition did not recompile all necessary words. @@ -17,7 +17,7 @@ IN: compiler.tests M: my-mixin my-generic drop 0 ; M: object my-generic drop 1 ; : my-inline ( -- b ) { } my-generic ; - "> eval + "> eval( -- ) ] unit-test [ ] [ diff --git a/basis/compiler/tests/redefine12.factor b/basis/compiler/tests/redefine12.factor index 87dc4596e9..ccf6c88e70 100644 --- a/basis/compiler/tests/redefine12.factor +++ b/basis/compiler/tests/redefine12.factor @@ -15,6 +15,6 @@ M: object g drop t ; TUPLE: jeah ; -[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test +[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test [ f ] [ T{ jeah } h ] unit-test 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/redefine15.factor b/basis/compiler/tests/redefine15.factor index 797460a411..33aa080bac 100644 --- a/basis/compiler/tests/redefine15.factor +++ b/basis/compiler/tests/redefine15.factor @@ -17,4 +17,4 @@ DEFER: word-1 [ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit -[ 2 3 ] [ 0 word-4 ] unit-test \ No newline at end of file +[ 2 3 ] [ 0 word-4 ] unit-test diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor new file mode 100644 index 0000000000..3bef30f9f1 --- /dev/null +++ b/basis/compiler/tests/redefine16.factor @@ -0,0 +1,11 @@ +IN: compiler.tests.redefine16 +USING: eval tools.test definitions words compiler.units +quotations stack-checker ; + +[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test + +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test + +[ ] [ [ "blah" "compiler.tests.redefine16" lookup 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/redefine2.factor b/basis/compiler/tests/redefine2.factor index 5a28b28261..9112a1e1af 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -1,11 +1,11 @@ -IN: compiler.tests +IN: compiler.tests.redefine2 USING: compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval words.symbol ; DEFER: redefine2-test -[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test +[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index b25b5a1a5e..0a5eb84579 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.redefine3 USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval ; @@ -14,11 +14,11 @@ 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 -[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test +[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test [ "wake up" ] [ sheeple-test ] unit-test [ f ] [ object \ 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/redefine4.factor b/basis/compiler/tests/redefine4.factor index 2f21777801..2320f64af6 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.redefine4 USING: io.streams.string kernel tools.test eval ; : declaration-test-1 ( -- a ) 3 ; flushable @@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ; [ "" ] [ [ declaration-test ] with-string-writer ] unit-test -[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test +[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor index ac1619b857..7613987852 100644 --- a/basis/compiler/tests/redefine5.factor +++ b/basis/compiler/tests/redefine5.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine5 ! Regression: if dispatch was eliminated but method was not inlined, ! compiled usage information was not recorded. @@ -14,7 +14,7 @@ IN: compiler.tests GENERIC: my-generic ( a -- b ) M: object my-generic [ <=> ] sort ; : my-inline ( a -- b ) my-generic ; - "> eval + "> eval( -- ) ] unit-test [ ] [ @@ -23,7 +23,7 @@ IN: compiler.tests IN: compiler.tests.redefine5 TUPLE: my-tuple ; M: my-tuple my-generic drop 0 ; - "> eval + "> eval( -- ) ] unit-test [ 0 ] [ diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor index 73225c55b8..fdf3e7edbb 100644 --- a/basis/compiler/tests/redefine6.factor +++ b/basis/compiler/tests/redefine6.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine6 ! Mixin redefinition did not recompile all necessary words. @@ -14,7 +14,7 @@ IN: compiler.tests MIXIN: my-mixin M: my-mixin my-generic drop 0 ; : my-inline ( a -- b ) { my-mixin } declare my-generic ; - "> eval + "> eval( -- ) ] unit-test [ ] [ @@ -24,7 +24,7 @@ IN: compiler.tests TUPLE: my-tuple ; M: my-tuple my-generic drop 1 ; INSTANCE: my-tuple my-mixin - "> eval + "> eval( -- ) ] unit-test [ 1 ] [ diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor index 164a2e3831..cfe29603f9 100644 --- a/basis/compiler/tests/redefine7.factor +++ b/basis/compiler/tests/redefine7.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine7 ! Mixin redefinition did not recompile all necessary words. @@ -13,7 +13,7 @@ IN: compiler.tests MIXIN: my-mixin INSTANCE: fixnum my-mixin : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; - "> eval + "> eval( -- ) ] unit-test [ ] [ @@ -21,7 +21,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine7 INSTANCE: float my-mixin - "> eval + "> eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor index c8b3377632..a79bfb5af5 100644 --- a/basis/compiler/tests/redefine8.factor +++ b/basis/compiler/tests/redefine8.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine8 ! Mixin redefinition did not recompile all necessary words. @@ -16,7 +16,7 @@ IN: compiler.tests ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> eval + "> eval( -- ) ] unit-test [ ] [ @@ -24,7 +24,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine8 INSTANCE: float my-mixin - "> eval + "> eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor index 7b0f8a2e9c..2598246472 100644 --- a/basis/compiler/tests/redefine9.factor +++ b/basis/compiler/tests/redefine9.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel generic.math ; -IN: compiler.tests +IN: compiler.tests.redefine9 ! Mixin redefinition did not recompile all necessary words. @@ -16,7 +16,7 @@ IN: compiler.tests ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> eval + "> eval( -- ) ] unit-test [ ] [ @@ -25,7 +25,7 @@ IN: compiler.tests IN: compiler.tests.redefine9 TUPLE: my-tuple ; INSTANCE: my-tuple my-mixin - "> eval + "> eval( -- ) ] unit-test [ diff --git a/basis/compiler/tests/reload.factor b/basis/compiler/tests/reload.factor index b2b65b5868..62c7c31bc2 100644 --- a/basis/compiler/tests/reload.factor +++ b/basis/compiler/tests/reload.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.reload USE: vocabs.loader ! "parser" reload diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index d53b864b06..da021412fe 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -1,9 +1,7 @@ USING: compiler compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory vocabs parser eval ; -IN: compiler.tests - -\ (compile) must-infer +IN: compiler.tests.simple ! Test empty word [ ] [ [ ] compile-call ] unit-test @@ -62,8 +60,8 @@ IN: compiler.tests ! 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 @@ -237,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 + "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 4092352fd5..e518ff8df2 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -1,6 +1,6 @@ USING: math.private kernel combinators accessors arrays -generalizations tools.test ; -IN: compiler.tests +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 [ 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 [ 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 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/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index b317ed3eb5..1cb11571ef 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.stack-trace USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private words splitting grouping sorting accessors ; diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index caa214b70c..fc249d99db 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.tuples USING: kernel tools.test compiler.units compiler ; TUPLE: color red green blue ; diff --git a/basis/compiler/tree/builder/builder-docs.factor b/basis/compiler/tree/builder/builder-docs.factor index 8cf3796f0a..b7ee51834b 100644 --- a/basis/compiler/tree/builder/builder-docs.factor +++ b/basis/compiler/tree/builder/builder-docs.factor @@ -3,12 +3,11 @@ compiler.tree stack-checker.errors ; IN: compiler.tree.builder HELP: build-tree -{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } } +{ $values { "word/quot" { $or word quotation } } { "nodes" "a sequence of nodes" } } { $description "Attempts to construct tree SSA IR from a quotation." } { $notes "This is the first stage of the compiler." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; -HELP: build-tree-with -{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } } -{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." } -{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; +HELP: build-sub-tree +{ $values { "#call" #call } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } } +{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ; diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor index 4982a3986c..f3a2b99db6 100755 --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -1,11 +1,27 @@ IN: compiler.tree.builder.tests USING: compiler.tree.builder tools.test sequences kernel -compiler.tree ; - -\ build-tree must-infer -\ build-tree-with must-infer -\ build-tree-from-word must-infer +compiler.tree stack-checker stack-checker.errors ; : inline-recursive ( -- ) inline-recursive ; inline recursive -[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test +[ t ] [ \ inline-recursive build-tree [ #recursive? ] any? ] unit-test + +: bad-recursion-1 ( a -- b ) + dup [ drop bad-recursion-1 5 ] [ ] if ; + +[ \ bad-recursion-1 build-tree ] [ inference-error? ] must-fail-with + +FORGET: bad-recursion-1 + +: bad-recursion-2 ( obj -- obj ) + dup [ dup first swap second bad-recursion-2 ] [ ] if ; + +[ \ bad-recursion-2 build-tree ] [ inference-error? ] must-fail-with + +FORGET: bad-recursion-2 + +: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; + +[ \ bad-bin build-tree ] [ inference-error? ] must-fail-with + +FORGET: bad-bin diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 4cb7650b1d..37cc1f05da 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.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: fry accessors quotations kernel sequences namespaces -assocs words arrays vectors hints combinators compiler.tree +USING: fry locals accessors quotations kernel sequences namespaces +assocs words arrays vectors hints combinators continuations +effects compiler.tree stack-checker stack-checker.state stack-checker.errors @@ -10,49 +11,59 @@ stack-checker.backend stack-checker.recursive-state ; IN: compiler.tree.builder -: with-tree-builder ( quot -- nodes ) - '[ V{ } clone stack-visitor set @ ] - with-infer nip ; inline +vector \ meta-d set ] - [ f initial-recursive-state infer-quot ] bi* - ] with-tree-builder - unclip-last in-d>> ; - -: build-sub-tree ( #call quot -- nodes ) - [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with - over ends-with-terminate? - [ drop swap [ f swap #push ] map append ] - [ rot #copy suffix ] - if ; - -: (build-tree-from-word) ( word -- ) - dup initial-recursive-state recursive-state set - dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and - [ 1quotation ] [ specialized-def ] if - infer-quot-here ; - -: check-cannot-infer ( word -- ) - dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ; +M: callable (build-tree) infer-quot-here ; : check-no-compile ( word -- ) - dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ; + dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ; -: build-tree-from-word ( word -- nodes ) +: check-effect ( word effect -- ) + swap required-stack-effect 2dup effect<= + [ 2drop ] [ effect-error ] if ; + +: inline-recursive? ( word -- ? ) + [ "inline" word-prop ] [ "recursive" word-prop ] bi and ; + +: word-body ( word -- quot ) + dup inline-recursive? [ 1quotation ] [ specialized-def ] if ; + +M: word (build-tree) + [ check-no-compile ] + [ word-body infer-quot-here ] + [ current-effect check-effect ] tri ; + +: build-tree-with ( in-stack word/quot -- nodes ) [ + recursive-state set + V{ } clone stack-visitor set + [ [ >vector \ meta-d set ] [ length d-in set ] bi ] + [ (build-tree) ] + bi* + ] with-infer nip ; + +PRIVATE> + +: build-tree ( word/quot -- nodes ) + [ f ] dip build-tree-with ; + +:: build-sub-tree ( #call word/quot -- nodes/f ) + #! We don't want methods on mixins to have a declaration for that mixin. + #! 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. + f specialize-method? [ [ + #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d { - [ check-cannot-infer ] - [ check-no-compile ] - [ (build-tree-from-word) ] - [ finish-word ] - } cleave - ] maybe-cannot-infer - ] with-tree-builder ; + { [ 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/checker/checker-tests.factor b/basis/compiler/tree/checker/checker-tests.factor index 5a8706b900..d9591e7be2 100644 --- a/basis/compiler/tree/checker/checker-tests.factor +++ b/basis/compiler/tree/checker/checker-tests.factor @@ -1,4 +1,4 @@ IN: compiler.tree.checker.tests USING: compiler.tree.checker tools.test ; -\ check-nodes must-infer + diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 7de092d84a..c596be263a 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ; [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) ] if ; inline recursive -: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline +: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline [ f ] [ [ { bignum } declare annotate-entry-test-2 ] @@ -302,7 +302,7 @@ cell-bits 32 = [ ] unit-test [ t ] [ - [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? + [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined? ] unit-test : rec ( a -- b ) @@ -519,4 +519,4 @@ cell-bits 32 = [ [ t ] [ [ { integer integer } declare + drop ] { + +-integer-integer } inlined? -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 7c28866e94..ed4df91eec 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -9,8 +9,6 @@ accessors combinators io prettyprint words sequences.deep sequences.private arrays classes kernel.private ; IN: compiler.tree.dead-code.tests -\ remove-dead-code must-infer - : count-live-values ( quot -- n ) build-tree analyze-recursive diff --git a/basis/compiler/tree/debugger/debugger-tests.factor b/basis/compiler/tree/debugger/debugger-tests.factor index 9b4a6da12a..9bacd51be1 100644 --- a/basis/compiler/tree/debugger/debugger-tests.factor +++ b/basis/compiler/tree/debugger/debugger-tests.factor @@ -1,8 +1,5 @@ IN: compiler.tree.debugger.tests USING: compiler.tree.debugger tools.test sorting sequences io math.order ; -\ optimized. must-infer -\ optimizer-report. must-infer - [ [ <=> ] sort ] optimized. [ [ print ] each ] optimizer-report. \ No newline at end of file diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 430424291e..60cab92843 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -130,8 +130,6 @@ M: node node>quot drop ; GENERIC: optimized. ( quot/word -- ) -M: method-spec optimized. first2 method optimized. ; - M: word optimized. specialized-def optimized. ; M: callable optimized. build-tree optimize-tree nodes>quot . ; @@ -144,8 +142,7 @@ SYMBOL: node-count : make-report ( word/quot -- assoc ) [ - dup word? [ build-tree-from-word ] [ build-tree ] if - optimize-tree + build-tree optimize-tree H{ } clone words-called set H{ } clone generics-called set @@ -156,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/def-use/def-use-tests.factor b/basis/compiler/tree/def-use/def-use-tests.factor index d970e04afd..227a1f1dd7 100644 --- a/basis/compiler/tree/def-use/def-use-tests.factor +++ b/basis/compiler/tree/def-use/def-use-tests.factor @@ -7,8 +7,6 @@ compiler.tree.def-use arrays kernel.private sorting math.order binary-search compiler.tree.checker ; IN: compiler.tree.def-use.tests -\ compute-def-use must-infer - [ t ] [ [ 1 2 3 ] build-tree compute-def-use drop def-use get { 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 9a226b954f..5f89372ebe 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -11,15 +11,13 @@ compiler.tree.propagation.info stack-checker.errors compiler.tree.checker kernel.private ; -\ escape-analysis must-infer - GENERIC: count-unboxed-allocations* ( m node -- n ) : (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* @@ -293,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 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/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 5ac3c57abe..3b4574effe 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -6,9 +6,6 @@ compiler.tree.normalization.renaming compiler.tree compiler.tree.checker sequences accessors tools.test kernel math ; -\ count-introductions must-infer -\ normalize must-infer - [ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test [ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test @@ -17,13 +14,13 @@ sequences accessors tools.test kernel math ; [ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test -: foo ( -- ) swap ; inline recursive +: foo ( quot: ( -- ) -- ) call ; inline recursive : recursive-inputs ( nodes -- n ) [ #recursive? ] find nip child>> first in-d>> length ; -[ 0 2 ] [ - [ foo ] build-tree +[ 1 3 ] [ + [ [ swap ] foo ] build-tree [ recursive-inputs ] [ analyze-recursive normalize recursive-inputs ] bi ] unit-test @@ -34,18 +31,18 @@ sequences accessors tools.test kernel math ; [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test DEFER: bbb -: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive -: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive +: aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive +: bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive [ ] [ [ bbb ] test-normalization ] unit-test -: ccc ( -- ) ccc drop 1 ; inline recursive +: ccc ( obj -- 1 ) ccc drop 1 ; inline recursive [ ] [ [ ccc ] test-normalization ] unit-test DEFER: eee -: ddd ( -- ) eee ; inline recursive -: eee ( -- ) swap ddd ; inline recursive +: ddd ( a b -- a b ) eee ; inline recursive +: eee ( a b -- a b ) swap ddd ; inline recursive [ ] [ [ eee ] test-normalization ] unit-test diff --git a/basis/compiler/tree/optimizer/optimizer-tests.factor b/basis/compiler/tree/optimizer/optimizer-tests.factor index 1075e441e7..5d05947b8a 100644 --- a/basis/compiler/tree/optimizer/optimizer-tests.factor +++ b/basis/compiler/tree/optimizer/optimizer-tests.factor @@ -1,4 +1,4 @@ USING: compiler.tree.optimizer tools.test ; IN: compiler.tree.optimizer.tests -\ optimize-tree must-infer + diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index 54c6c2c117..fe3c7acb92 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -18,6 +18,12 @@ IN: compiler.tree.optimizer SYMBOL: check-optimizer? +: ?check ( nodes -- nodes' ) + check-optimizer? get [ + compute-def-use + dup check-nodes + ] when ; + : optimize-tree ( nodes -- nodes' ) analyze-recursive normalize @@ -30,10 +36,7 @@ SYMBOL: check-optimizer? apply-identities compute-def-use remove-dead-code - check-optimizer? get [ - compute-def-use - dup check-nodes - ] when + ?check compute-def-use optimize-modular-arithmetic finalize ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index c56db570b2..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 ) @@ -238,7 +227,7 @@ DEFER: (value-info-union) : value-infos-union ( infos -- info ) [ null-info ] - [ unclip-slice [ value-info-union ] reduce ] if-empty ; + [ [ ] [ value-info-union ] map-reduce ] if-empty ; : literals<= ( info1 info2 -- ? ) { diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index f18cfcd3a3..2a7d431314 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,9 +1,10 @@ ! 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 +words namespaces continuations classes fry combinators.smart hints +locals compiler.tree compiler.tree.builder compiler.tree.recursive @@ -27,24 +28,34 @@ SYMBOL: node-count SYMBOL: inlining-count ! Splicing nodes -GENERIC: splicing-nodes ( #call word/quot/f -- nodes ) - -M: word splicing-nodes +: splicing-call ( #call word -- nodes ) [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; -M: callable splicing-nodes - build-sub-tree analyze-recursive normalize ; +: splicing-body ( #call quot/word -- nodes/f ) + build-sub-tree dup [ analyze-recursive normalize ] when ; ! Dispatch elimination +: undo-inlining ( #call -- ? ) + f >>method f >>body f >>class drop f ; + +: propagate-body ( #call -- ? ) + body>> (propagate) t ; + +GENERIC: splicing-nodes ( #call word/quot -- nodes/f ) + +M: word splicing-nodes splicing-call ; + +M: callable splicing-nodes splicing-body ; + : eliminate-dispatch ( #call class/f word/quot/f -- ? ) dup [ [ >>class ] dip - over method>> over = [ drop ] [ - 2dup splicing-nodes - [ >>method ] [ >>body ] bi* + over method>> over = [ drop propagate-body ] [ + 2dup splicing-nodes dup [ + [ >>method ] [ >>body ] bi* propagate-body + ] [ 2drop undo-inlining ] if ] if - body>> (propagate) t - ] [ 2drop f >>method f >>body f >>class drop f ] if ; + ] [ 2drop undo-inlining ] if ; : inlining-standard-method ( #call word -- class/f method/f ) dup "methods" word-prop assoc-empty? [ 2drop f f ] [ @@ -136,19 +147,21 @@ DEFER: (flat-length) [ [ classes-known? 2 0 ? ] [ - { - [ body-length-bias ] - [ "default" word-prop -4 0 ? ] - [ "specializer" word-prop 1 0 ? ] - [ method-body? 1 0 ? ] - } cleave + [ body-length-bias ] + [ "specializer" word-prop 1 0 ? ] + [ method-body? 1 0 ? ] + tri node-count-bias loop-nesting get 0 or 2 * ] bi* ] sum-outputs ; : should-inline? ( #call word -- ? ) - dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ; + { + { [ dup contains-breakpoints? ] [ 2drop f ] } + { [ dup "inline" word-prop ] [ 2drop t ] } + [ inlining-rank 5 >= ] + } cond ; SYMBOL: history @@ -157,19 +170,17 @@ SYMBOL: history [ history [ swap suffix ] change ] bi ; -: inline-word-def ( #call word quot -- ? ) - over history get memq? [ 3drop f ] [ - [ - [ remember-inlining ] dip - [ drop ] [ splicing-nodes ] 2bi - [ >>body drop ] [ count-nodes ] [ (propagate) ] tri - ] with-scope node-count +@ - t +:: inline-word ( #call word -- ? ) + word history get memq? [ f ] [ + #call word splicing-body [ + [ + word remember-inlining + [ ] [ count-nodes ] [ (propagate) ] tri + ] with-scope + [ #call (>>body) ] [ node-count +@ ] bi* t + ] [ f ] if* ] if ; -: inline-word ( #call word -- ? ) - dup def>> inline-word-def ; - : inline-method-body ( #call word -- ? ) 2dup should-inline? [ inline-word ] [ 2drop f ] if ; @@ -177,7 +188,7 @@ SYMBOL: history { curry compose } memq? ; : never-inline-word? ( word -- ? ) - [ deferred? ] [ { call execute } memq? ] bi or ; + [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ; : custom-inlining? ( word -- ? ) "custom-inlining" word-prop ; @@ -187,10 +198,6 @@ SYMBOL: history call( #call -- word/quot/f ) object swap eliminate-dispatch ; -: inline-instance-check ( #call word -- ? ) - over in-d>> second value-info literal>> dup class? - [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ; - : (do-inlining) ( #call word -- ? ) #! If the generic was defined in an outer compilation unit, #! then it doesn't have a definition yet; the definition @@ -202,7 +209,6 @@ SYMBOL: history #! discouraged, but it should still work.) { { [ dup never-inline-word? ] [ 2drop f ] } - { [ dup \ instance? eq? ] [ inline-instance-check ] } { [ dup always-inline-word? ] [ inline-word ] } { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 1b5d383353..b91a1157f7 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -341,6 +341,11 @@ generic-comparison-ops [ ] [ 2drop object-info ] if ] "outputs" set-word-prop +\ instance? [ + in-d>> second value-info literal>> dup class? + [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if +] "custom-inlining" set-word-prop + \ equal? [ ! If first input has a known type and second input is an ! object, we convert this to [ swap equal? ]. diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 5dd647ae89..eba41dbfdf 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,11 +9,9 @@ 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 -\ propagate must-infer - [ V{ } ] [ [ ] final-classes ] unit-test [ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test @@ -359,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 } ] [ @@ -377,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 @@ -592,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 @@ -680,11 +678,16 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; : (littledan-3-test) ( x -- ) length 1+ f (littledan-3-test) ; inline recursive -: littledan-3-test ( x -- ) +: littledan-3-test ( -- ) 0 f (littledan-3-test) ; inline [ ] [ [ littledan-3-test ] final-classes drop ] unit-test [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test -[ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test \ No newline at end of file +[ 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 \ No newline at end of file diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 1bcd36f6b0..b8d1760a0b 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -28,8 +28,8 @@ IN: compiler.tree.propagation.recursive { { [ 2dup interval-subset? ] [ empty-interval ] } { [ over empty-interval eq? ] [ empty-interval ] } - { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] } - { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] } + { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] } + { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] } [ [-inf,inf] ] } cond interval-union nip ; 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/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index d548d58bc6..80edae076f 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -10,8 +10,6 @@ compiler.tree.combinators ; [ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test [ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test -\ analyze-recursive must-infer - : label-is-loop? ( nodes word -- ? ) [ { @@ -21,8 +19,6 @@ compiler.tree.combinators ; } 2&& ] curry contains-node? ; -\ label-is-loop? must-infer - : label-is-not-loop? ( nodes word -- ? ) [ { @@ -32,8 +28,6 @@ compiler.tree.combinators ; } 2&& ] curry contains-node? ; -\ label-is-not-loop? must-infer - : loop-test-1 ( a -- ) dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive @@ -57,7 +51,7 @@ compiler.tree.combinators ; \ (each-integer) label-is-loop? ] unit-test -: loop-test-2 ( a -- ) +: loop-test-2 ( a b -- a' ) dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive [ t ] [ diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 81ba01f1e2..70670648b1 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -8,8 +8,6 @@ compiler.tree.def-use kernel accessors sequences math math.private sorting math.order binary-search sequences.private slots.private ; -\ unbox-tuples must-infer - : test-unboxing ( quot -- ) build-tree analyze-recursive @@ -34,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 ] 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/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 11e624110c..ad00bbdfa9 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -20,10 +20,12 @@ IN: concurrency.conditions ] ] dip later ; +ERROR: wait-timeout ; + : wait ( queue timeout status -- ) over [ [ queue-timeout [ drop ] ] dip suspend - [ "Timeout" throw ] [ cancel-alarm ] if + [ wait-timeout ] [ cancel-alarm ] if ] [ [ drop '[ _ push-front ] ] dip suspend drop ] if ; diff --git a/basis/concurrency/exchangers/exchangers-tests.factor b/basis/concurrency/exchangers/exchangers-tests.factor index 569b1a72c2..3b5b014fe3 100644 --- a/basis/concurrency/exchangers/exchangers-tests.factor +++ b/basis/concurrency/exchangers/exchangers-tests.factor @@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; -:: exchanger-test ( -- ) +:: exchanger-test ( -- string ) [let | ex [ ] c [ 2 ] diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor index a666293316..05ff74b03f 100644 --- a/basis/concurrency/flags/flags-tests.factor +++ b/basis/concurrency/flags/flags-tests.factor @@ -11,7 +11,7 @@ kernel threads locals accessors calendar ; [ f ] [ flag-test-1 ] unit-test -:: flag-test-2 ( -- ) +:: flag-test-2 ( -- ? ) [let | f [ ] | [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop f lower-flag diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor index 64971eeb77..81e54f1807 100644 --- a/basis/concurrency/mailboxes/mailboxes-tests.factor +++ b/basis/concurrency/mailboxes/mailboxes-tests.factor @@ -1,6 +1,6 @@ IN: concurrency.mailboxes.tests -USING: concurrency.mailboxes concurrency.count-downs vectors -sequences threads tools.test math kernel strings namespaces +USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions +vectors sequences threads tools.test math kernel strings namespaces continuations calendar destructors ; { 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as @@ -75,3 +75,15 @@ continuations calendar destructors ; [ ] [ "d" get 5 seconds await-timeout ] unit-test [ ] [ "m" get dispose ] unit-test + +[ { "foo" "bar" } ] [ + + "foo" over mailbox-put + "bar" over mailbox-put + mailbox-get-all +] unit-test + +[ + 1 seconds mailbox-get-timeout +] [ wait-timeout? ] must-fail-with + \ No newline at end of file diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index f6aec94b41..200adb14ae 100755 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -49,7 +49,7 @@ M: mailbox dispose* threads>> notify-all ; : mailbox-get-all-timeout ( mailbox timeout -- array ) block-if-empty - [ dup mailbox-empty? ] + [ dup mailbox-empty? not ] [ dup data>> pop-back ] produce nip ; diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor index 8e160842a9..69f12d8739 100644 --- a/basis/concurrency/promises/promises-docs.factor +++ b/basis/concurrency/promises/promises-docs.factor @@ -7,6 +7,10 @@ IN: concurrency.promises HELP: promise { $class-description "The class of write-once promises." } ; +HELP: +{ $values { "promise" promise } } +{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ; + HELP: promise-fulfilled? { $values { "promise" promise } { "?" "a boolean" } } { $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ; 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/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index f35a5cfca8..09db4cb050 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -114,5 +114,3 @@ make vocabs sequences ; { HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler { HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler { HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler - -"cpu.ppc.assembler" words [ must-infer ] each diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index ec7bf8f341..7278fd2092 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -2,15 +2,13 @@ ! 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 @@ -23,7 +21,7 @@ CONSTANT: rs-reg 30 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ; [ - 0 6 LOAD32 + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel 11 6 profile-count-offset LWZ 11 11 1 tag-fixnum ADDI 11 6 profile-count-offset STW @@ -31,65 +29,50 @@ CONSTANT: rs-reg 30 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 6 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 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 + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel 6 ds-reg 4 STWU -] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define +] jit-push-immediate jit-define [ - 0 6 LOAD32 + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel 7 6 0 LWZ 1 7 0 STW -] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define +] jit-save-stack jit-define [ - 0 6 LOAD32 + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel 6 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-direct jit-rel ] jit-word-call jit-define -[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define +[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump 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 jit-rel +] 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 +] jit-if-2 jit-define : jit->r ( -- ) 4 ds-reg 0 LWZ @@ -139,29 +122,29 @@ 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 [ 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 @@ -169,8 +152,10 @@ CONSTANT: rs-reg 30 [ 3 ds-reg 0 LWZ ds-reg dup 4 SUBI - jit-jump-quot -] f f f \ (call) define-sub-primitive + 4 3 quot-xt-offset LWZ + 4 MTCTR + BCTR +] \ (call) define-sub-primitive [ 3 ds-reg 0 LWZ @@ -178,7 +163,7 @@ CONSTANT: rs-reg 30 4 3 word-xt-offset LWZ 4 MTCTR BCTR -] f f f \ (execute) define-sub-primitive +] \ (execute) define-sub-primitive ! Objects [ @@ -186,7 +171,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 +180,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 +206,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 +216,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 +253,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 +276,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,23 +285,22 @@ 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 - 2 swap execute ! magic number + 2 swap execute( offset -- ) ! magic number \ f tag-number 3 LI 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,17 +320,17 @@ 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 4 ds-reg -4 LWZU - [ 5 3 4 ] dip execute + [ 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 +338,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 +366,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 +376,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 +385,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 +396,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/x86/32/32.factor b/basis/cpu/x86/32/32.factor index b280afc01e..10cd9c8657 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -309,7 +309,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..be21344815 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -22,13 +22,15 @@ 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 + ! load stack_chain + temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel + ! save stack pointer + temp0 [] stack-reg MOV +] jit-save-stack jit-define [ - (JMP) drop -] rc-relative rt-primitive 1 jit-primitive jit-define + (JMP) drop 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/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index ddf5791009..8d1ed086e7 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -20,15 +20,19 @@ 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 + ! save stack pointer + temp0 [] stack-reg MOV +] 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 + ! 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..5560d17a1e 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -316,15 +316,16 @@ 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: callable CALL (CALL) rel-word-direct ; M: label CALL (CALL) label-fixup ; 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 ; +: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ; +M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ; +M: integer JUMPcc (JUMPcc) drop ; +M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ; +M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ; : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; @@ -382,6 +383,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 f5829d76ea..4fe5e5cd33 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,35 @@ 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 + f JMP rc-relative rt-xt jit-rel +] jit-word-jump jit-define [ - f CALL -] rc-relative rt-xt 1 jit-word-call jit-define + f CALL rc-relative rt-xt-direct jit-rel +] jit-word-call jit-define [ ! load boolean @@ -59,31 +57,13 @@ 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 + f JNE rc-relative rt-xt jit-rel +] jit-if-1 jit-define [ ! 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 + f JMP rc-relative rt-xt jit-rel +] jit-if-2 jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD @@ -135,30 +115,133 @@ big-endian off [ jit->r - f CALL + f 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 + f 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 + f 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 + +! temp0 contains the object being dispatched on +! temp1 contains its class + +! 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 8 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 + +[ f 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 + ! ... goto get(cache + bootstrap-cell) + [ + temp0 temp0 bootstrap-cell [+] MOV + temp0 word-xt-offset [+] JMP + ] [ ] make + [ length JNE ] [ % ] bi + ! fall-through on miss +] mega-lookup jit-define + +! ! ! Sub-primitives ! Quotations and words [ @@ -168,16 +251,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 +263,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 +281,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 +308,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 +318,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 +350,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 +359,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 +382,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 +391,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 @@ -334,13 +408,12 @@ big-endian off ! compare with second value ds-reg [] temp0 CMP ! move t if true - [ temp1 temp3 ] dip execute + [ temp1 temp3 ] dip execute( dst src -- ) ! store 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 @@ -355,11 +428,11 @@ big-endian off ! pop stack ds-reg bootstrap-cell SUB ! compute result - [ ds-reg [] temp0 ] dip execute ; + [ 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 +447,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 +484,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 +504,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 +514,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 +523,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 +534,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 +545,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 +556,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/db/errors/sqlite/sqlite.factor b/basis/db/errors/sqlite/sqlite.factor index c247a36257..c73409b850 100644 --- a/basis/db/errors/sqlite/sqlite.factor +++ b/basis/db/errors/sqlite/sqlite.factor @@ -4,7 +4,8 @@ USING: accessors combinators db kernel sequences peg.ebnf strings db.errors ; IN: db.errors.sqlite -ERROR: unparsed-sqlite-error error ; +TUPLE: unparsed-sqlite-error error ; +C: unparsed-sqlite-error SINGLETONS: table-exists table-missing ; @@ -22,4 +23,6 @@ SqliteError = => [[ table >string message sqlite-table-error ]] | "no such table: " .+:table => [[ table >string ]] + | .*:error + => [[ error >string ]] ;EBNF diff --git a/basis/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor index 7ff2a33d92..334ff9e11a 100644 --- a/basis/db/pools/pools-tests.factor +++ b/basis/db/pools/pools-tests.factor @@ -2,8 +2,6 @@ IN: db.pools.tests USING: db.pools tools.test continuations io.files io.files.temp io.directories namespaces accessors kernel math destructors ; -\ must-infer - { 1 0 } [ [ ] with-db-pool ] must-infer-as { 1 0 } [ [ ] with-pooled-db ] must-infer-as diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 2730340bfc..c4aa47d383 100755 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -4,7 +4,7 @@ USING: accessors kernel math namespaces make sequences random strings math.parser math.intervals combinators math.bitwise nmake db db.tuples db.types classes words shuffle arrays destructors continuations db.tuples.private prettyprint -db.private ; +db.private byte-arrays ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -115,6 +115,9 @@ M: sequence where ( spec obj -- ) [ " or " 0% ] [ dupd where ] interleave drop ] in-parens ; +M: byte-array where ( spec obj -- ) + over column-name>> 0% " = " 0% bind# ; + M: NULL where ( spec obj -- ) drop column-name>> 0% " is NULL" 0% ; diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index fcc5abf1cf..56bac7efcd 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -3,7 +3,7 @@ USING: concurrency.combinators db.pools db.sqlite db.tuples db.types kernel math random threads tools.test db sequences io prettyprint db.postgresql db.sqlite accessors io.files.temp -namespaces fry system ; +namespaces fry system math.parser ; IN: db.tester : postgresql-test-db ( -- postgresql-db ) @@ -56,6 +56,10 @@ test-2 "TEST2" { { "z" "Z" { VARCHAR 256 } +not-null+ } } define-persistent +: test-1-tuple ( -- tuple ) + f 100 random 100 random 100 random [ number>string ] tri@ + test-1 boa ; + : db-tester ( test-db -- ) [ [ @@ -67,8 +71,7 @@ test-2 "TEST2" { drop 10 [ dup [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield + test-1-tuple insert-tuple yield ] with-db ] times ] with parallel-each @@ -84,8 +87,7 @@ test-2 "TEST2" { [ 10 [ 10 [ - f 100 random 100 random 100 random test-1 boa - insert-tuple yield + test-1-tuple insert-tuple yield ] times ] parallel-each ] with-pooled-db diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 50d7f044d1..afdee3e89f 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -411,7 +411,7 @@ TUPLE: exam id name score ; T{ exam f 4 "Cartman" 41 } } ] [ - T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples + T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples ] unit-test [ @@ -419,7 +419,7 @@ TUPLE: exam id name score ; T{ exam f 1 "Kyle" 100 } } ] [ - T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples + T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples ] unit-test [ @@ -430,7 +430,7 @@ TUPLE: exam id name score ; T{ exam f 4 "Cartman" 41 } } ] [ - T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples + T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples ] unit-test [ @@ -592,17 +592,6 @@ string-encoding-test "STRING_ENCODING_TEST" { [ test-string-encoding ] test-sqlite [ test-string-encoding ] test-postgresql -! Don't comment these out. These words must infer -\ bind-tuple must-infer -\ insert-tuple must-infer -\ update-tuple must-infer -\ delete-tuples must-infer -\ select-tuple must-infer -\ define-persistent must-infer -\ ensure-table must-infer -\ create-table must-infer -\ drop-table must-infer - : test-queries ( -- ) [ ] [ exam ensure-table ] unit-test [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test @@ -634,3 +623,22 @@ compound-foo "COMPOUND_FOO" [ test-compound-primary-key ] test-sqlite [ test-compound-primary-key ] test-postgresql + + +TUPLE: example id data ; + +example "EXAMPLE" +{ + { "id" "ID" +db-assigned-id+ } + { "data" "DATA" BLOB } +} define-persistent + +: test-blob-select ( -- ) + example ensure-table + [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test + [ + T{ example { id 1 } { data B{ 1 2 3 4 5 } } } + ] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ; + +[ test-blob-select ] test-sqlite +[ test-blob-select ] test-postgresql 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-tests.factor b/basis/debugger/debugger-tests.factor index afa4aa1c28..08f84d9335 100644 --- a/basis/debugger/debugger-tests.factor +++ b/basis/debugger/debugger-tests.factor @@ -2,3 +2,6 @@ IN: debugger.tests USING: debugger kernel continuations tools.test ; [ ] [ [ drop ] [ error. ] recover ] unit-test + +[ f ] [ { } vm-error? ] unit-test +[ f ] [ { "A" "B" } vm-error? ] unit-test \ No newline at end of file diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index efd35ab280..bb0268f048 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -1,21 +1,22 @@ ! 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 compiler.errors -generic.parser strings.parser vocabs.loader vocabs.parser ; +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 GENERIC: error. ( error -- ) GENERIC: error-help ( error -- topic ) M: object error. . ; + M: object error-help drop f ; M: tuple error-help class ; @@ -76,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 @@ -87,8 +88,7 @@ M: string error. print ; : divide-by-zero-error. ( obj -- ) "Division by zero" print drop ; -: signal-error. ( obj -- ) - "Operating system signal " write third . ; +HOOK: signal-error. os ( obj -- ) : array-size-error. ( obj -- ) "Invalid array size: " write dup third . @@ -98,9 +98,7 @@ M: string error. print ; "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 ; @@ -126,14 +124,14 @@ M: string error. print ; : primitive-error. ( error -- ) "Unimplemented primitive" print drop ; -PREDICATE: kernel-error < array +PREDICATE: vm-error < array { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } [ second 0 15 between? ] } cond ; -: kernel-errors ( error -- n errors ) +: vm-errors ( error -- n errors ) second { { 0 [ expired-error. ] } { 1 [ io-error. ] } @@ -153,9 +151,11 @@ PREDICATE: kernel-error < array { 15 [ memory-error. ] } } ; inline -M: kernel-error error. dup kernel-errors case ; +M: vm-error summary drop "VM error" ; -M: kernel-error error-help kernel-errors at first ; +M: vm-error error. dup vm-errors case ; + +M: vm-error error-help vm-errors at first ; M: no-method summary drop "No suitable method" ; @@ -213,14 +213,13 @@ M: condition error-help error>> error-help ; M: assert summary drop "Assertion failed" ; -M: assert error. - "Assertion failed" print +M: assert-sequence summary drop "Assertion failed" ; + +M: assert-sequence error. standard-table-style [ - 15 length-limit set - 5 line-limit set - [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ] - [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi - ] tabular-output nl ; + [ "=== Expected:" print expected>> stack. ] + [ "=== Got:" print got>> stack. ] bi + ] tabular-output ; M: immutable summary drop "Sequence is immutable" ; @@ -268,20 +267,6 @@ M: duplicate-slot-names summary M: invalid-slot-name summary drop "Invalid slot name" ; -: file. ( file -- ) path>> . ; - -M: source-file-error error. - [ file>> file. ] [ error>> error. ] bi ; - -M: source-file-error summary - error>> summary ; - -M: source-file-error compute-restarts - error>> compute-restarts ; - -M: source-file-error error-help - error>> error-help ; - M: not-in-a-method-error summary drop "call-next-method can only be called in a method definition" ; @@ -309,12 +294,6 @@ M: lexer-error compute-restarts M: lexer-error error-help error>> error-help ; -M: object compiler-error. ( error word -- ) - nl - "While compiling " write pprint ": " print - nl - print-error ; - M: bad-effect summary drop "Bad stack effect declaration" ; @@ -326,4 +305,9 @@ M: check-mixin-class summary drop "Not a mixin class" ; M: not-found-in-roots summary drop "Cannot resolve vocab: path" ; -M: wrong-values summary drop "Quotation called with wrong stack effect" ; \ No newline at end of file +M: wrong-values summary drop "Quotation called with wrong stack effect" ; + +{ + { [ os windows? ] [ "debugger.windows" require ] } + { [ os unix? ] [ "debugger.unix" require ] } +} cond \ No newline at end of file diff --git a/basis/debugger/unix/authors.txt b/basis/debugger/unix/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/debugger/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/debugger/unix/unix.factor b/basis/debugger/unix/unix.factor new file mode 100644 index 0000000000..212908b2fd --- /dev/null +++ b/basis/debugger/unix/unix.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger io kernel math prettyprint sequences system ; +IN: debugger.unix + +CONSTANT: signal-names +{ + "SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT" + "SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS" + "SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP" + "SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU" + "SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO" + "SIGUSR1" "SIGUSR2" +} + +: signal-name ( n -- str/f ) 1- signal-names ?nth ; + +: signal-name. ( n -- ) + signal-name [ " (" ")" surround write ] when* ; + +M: unix signal-error. ( obj -- ) + "Unix signal #" write + third [ pprint ] [ signal-name. ] bi nl ; diff --git a/basis/debugger/windows/authors.txt b/basis/debugger/windows/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/debugger/windows/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/debugger/windows/windows.factor b/basis/debugger/windows/windows.factor new file mode 100644 index 0000000000..1f4b8fb0ac --- /dev/null +++ b/basis/debugger/windows/windows.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger io prettyprint sequences system ; +IN: debugger.windows + +M: windows signal-error. "Windows exception #" write third .h ; \ No newline at end of file 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 cf822b40a3..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 @@ -35,7 +35,7 @@ M: hello bing hello-test ; [ 3 ] [ 1 0 2 whoa ] unit-test [ 3 ] [ 1 0 f 2 whoa ] unit-test -[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test +[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test [ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test @@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ; [ 0 ] [ 1 three ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test -[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test +[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test [ f ] [ hey \ two method ] unit-test [ f ] [ hey \ four method ] unit-test -[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test +[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test [ 2 ] [ 1 one ] unit-test [ 0 ] [ 1 two ] unit-test [ 0 ] [ 1 three ] unit-test [ 0 ] [ 1 four ] unit-test -[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test +[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test [ 2 ] [ 1 one ] unit-test [ -1 ] [ 1 two ] unit-test [ -1 ] [ 1 three ] unit-test [ -1 ] [ 1 four ] unit-test -[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test +[ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test [ f ] [ hey \ one method ] unit-test TUPLE: slot-protocol-test-1 a b ; @@ -196,4 +196,4 @@ DEFER: seq-delegate seq-delegate sequence-protocol \ protocol-consult word-prop key? -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/delegate/protocols/protocols.factor b/basis/delegate/protocols/protocols.factor index f568a3e388..40054bc4b0 100644 --- a/basis/delegate/protocols/protocols.factor +++ b/basis/delegate/protocols/protocols.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: delegate sequences.private sequences assocs -io definitions kernel continuations ; +USING: delegate sequences.private sequences assocs io ; IN: delegate.protocols PROTOCOL: sequence-protocol @@ -19,7 +18,3 @@ stream-read-until ; PROTOCOL: output-stream-protocol stream-flush stream-write1 stream-write stream-nl ; - -PROTOCOL: definition-protocol -where set-where forget uses -synopsis* definer definition ; 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-docs.factor b/basis/editors/editors-docs.factor index 0f50e40eb4..30611ca699 100644 --- a/basis/editors/editors-docs.factor +++ b/basis/editors/editors-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax parser source-files vocabs.loader ; +USING: help.markup help.syntax parser source-files +source-files.errors vocabs.loader ; IN: editors ARTICLE: "editor" "Editor integration" @@ -13,6 +14,9 @@ ARTICLE: "editor" "Editor integration" ABOUT: "editor" +HELP: edit-hook +{ $var-description "A quotation with stack effect " { $snippet "( file line -- )" } ". If not set, the " { $link edit } " word throws a condition with restarts for loading one of the sub-vocabularies of the " { $vocab-link "editors" } " vocabulary." } ; + HELP: edit { $values { "defspec" "a definition specifier" } } { $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." } @@ -22,7 +26,7 @@ HELP: edit "A word's documentation:" { $code "\\ foo >link edit" } "A method definition:" - { $code "{ editor draw-gadget* } edit" } + { $code "M\\ fixnum + edit" } "A help article:" { $code "\"handbook\" >link edit" } } ; diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 0003b508fb..d5b4b909e3 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -2,9 +2,9 @@ ! 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 assocs -vocabs vocabs.loader splitting accessors debugger prettyprint -help.topics ; +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 ; @@ -57,7 +57,7 @@ M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ; M: source-file-error error-file - [ error>> error-file ] [ file>> path>> ] bi or ; + [ error>> error-file ] [ file>> ] bi or ; M: source-file-error error-line error>> error-line ; @@ -81,6 +81,9 @@ M: object error-line : :edit ( -- ) error get (:edit) ; +: edit-error ( error -- ) + [ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ; + : edit-each ( seq -- ) [ [ "Editing " write . ] diff --git a/basis/editors/emacs/authors.txt b/basis/editors/emacs/authors.txt index 6cfd5da273..07c1c4a765 100644 --- a/basis/editors/emacs/authors.txt +++ b/basis/editors/emacs/authors.txt @@ -1 +1,2 @@ Eduardo Cavazos +Doug Coleman diff --git a/basis/editors/emacs/emacs-docs.factor b/basis/editors/emacs/emacs-docs.factor index f55068e143..adf6d8a7b7 100644 --- a/basis/editors/emacs/emacs-docs.factor +++ b/basis/editors/emacs/emacs-docs.factor @@ -2,10 +2,23 @@ USING: help help.syntax help.markup ; IN: editors.emacs ARTICLE: "editors.emacs" "Integration with Emacs" -"Put this in your " { $snippet ".emacs" } " file:" +"Full Emacs integration with Factor requires the use of two executable files -- " { $snippet "emacs" } " and " { $snippet "emacsclient" } ", which act as a client/server pair. To start the server, run the " { $snippet "emacs" } " binary and run " { $snippet "M-x server-start" } " or start " { $snippet "emacs" } " with the following line in your " { $snippet ".emacs" } " file:" { $code "(server-start)" } +"On Windows, if you install Emacs to " { $snippet "Program Files" } " or " { $snippet "Program Files(x86)" } ", Factor will automatically detect the path to " { $snippet "emacsclient.exe" } ". On Unix systems, make sure that " { $snippet "emacsclient" } " is in your path. To set the path manually, use the following snippet:" +{ $code "USE: edtiors.emacs" + "\"/my/crazy/bin/emacsclient\" emacsclient-path set-global" +} + "If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:" { $code "(setq server-window 'switch-to-buffer-other-frame)" } -{ $see-also "editor" } ; -ABOUT: "editors.emacs" \ No newline at end of file +"To quickly scaffold a " { $snippet ".emacs" } " file, run the following code:" +{ $code "USE: tools.scaffold" + "scaffold-emacs" +} + +{ $see-also "editor" } + +; + +ABOUT: "editors.emacs" diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index 366bc53104..31fcaf114e 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -11,7 +11,10 @@ M: object default-emacsclient ( -- path ) "emacsclient" ; : emacsclient ( file line -- ) [ - { [ emacsclient-path get ] [ default-emacsclient ] } 0|| , + { + [ emacsclient-path get-global ] + [ default-emacsclient dup emacsclient-path set-global ] + } 0|| , "--no-wait" , number>string "+" prepend , , diff --git a/basis/editors/emacs/windows/authors.txt b/basis/editors/emacs/windows/authors.txt index 7c1b2f2279..1901f27a24 100755 --- a/basis/editors/emacs/windows/authors.txt +++ b/basis/editors/emacs/windows/authors.txt @@ -1 +1 @@ -Doug Coleman +Slava Pestov diff --git a/basis/alien/strings/windows/tags.txt b/basis/editors/emacs/windows/tags.txt similarity index 100% rename from basis/alien/strings/windows/tags.txt rename to basis/editors/emacs/windows/tags.txt diff --git a/basis/images/normalization/authors.txt b/basis/editors/gedit/authors.txt similarity index 100% rename from basis/images/normalization/authors.txt rename to basis/editors/gedit/authors.txt diff --git a/basis/editors/gedit/gedit.factor b/basis/editors/gedit/gedit.factor new file mode 100644 index 0000000000..97ea0e1cb3 --- /dev/null +++ b/basis/editors/gedit/gedit.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: editors io.launcher kernel make math.parser namespaces +sequences ; +IN: editors.gedit + +: gedit-path ( -- path ) + \ gedit-path get-global [ + "gedit" + ] unless* ; + +: gedit ( file line -- ) + [ + gedit-path , number>string "+" prepend , , + ] { } make run-detached drop ; + +[ gedit ] edit-hook set-global diff --git a/basis/editors/gedit/summary.txt b/basis/editors/gedit/summary.txt new file mode 100644 index 0000000000..ebb7189c9f --- /dev/null +++ b/basis/editors/gedit/summary.txt @@ -0,0 +1 @@ +gedit integration diff --git a/unmaintained/openal/macosx/tags.txt b/basis/editors/gedit/tags.txt similarity index 100% rename from unmaintained/openal/macosx/tags.txt rename to basis/editors/gedit/tags.txt diff --git a/basis/eval/eval-docs.factor b/basis/eval/eval-docs.factor index b53c3bae6b..b30c6d9cb9 100644 --- a/basis/eval/eval-docs.factor +++ b/basis/eval/eval-docs.factor @@ -1,18 +1,23 @@ IN: eval -USING: help.markup help.syntax strings io ; +USING: help.markup help.syntax strings io effects ; HELP: eval -{ $values { "str" string } } -{ $description "Parses Factor source code from a string, and calls the resulting quotation." } +{ $values { "str" string } { "effect" effect } } +{ $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." } +{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ; + +HELP: eval( +{ $syntax "eval( inputs -- outputs )" } +{ $description "Parses Factor source code from the string at the top of the stack, and calls the resulting quotation, which must have the given stack effect." } { $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ; HELP: eval>string { $values { "str" string } { "output" string } } -{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ; +{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } ; ARTICLE: "eval" "Evaluating strings at runtime" "The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime." -{ $subsection eval } +{ $subsection POSTPONE: eval( } { $subsection eval>string } ; ABOUT: "eval" diff --git a/basis/eval/eval-tests.factor b/basis/eval/eval-tests.factor index 675921944a..d27e661193 100644 --- a/basis/eval/eval-tests.factor +++ b/basis/eval/eval-tests.factor @@ -1,4 +1,6 @@ IN: eval.tests USING: eval tools.test ; +[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test +[ "USE: math 2 2 +" eval( -- ) ] must-fail [ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test diff --git a/basis/eval/eval.factor b/basis/eval/eval.factor index 3672337a58..4c5b9e8cf9 100644 --- a/basis/eval/eval.factor +++ b/basis/eval/eval.factor @@ -1,23 +1,25 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: splitting parser compiler.units kernel namespaces -debugger io.streams.string fry ; +debugger io.streams.string fry combinators effects.parser ; IN: eval : parse-string ( str -- quot ) [ string-lines parse-lines ] with-compilation-unit ; -: (eval) ( str -- ) - parse-string call ; +: (eval) ( str effect -- ) + [ parse-string ] dip call-effect ; inline -: eval ( str -- ) - [ (eval) ] with-file-vocabs ; +: eval ( str effect -- ) + [ (eval) ] with-file-vocabs ; inline + +SYNTAX: eval( \ eval parse-call( ; : (eval>string) ( str -- output ) [ "quiet" on parser-notes off - '[ _ (eval) ] try + '[ _ (( -- )) (eval) ] try ] with-string-writer ; : eval>string ( str -- output ) 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-tests.factor b/basis/fry/fry-tests.factor index d240e6f233..88ecae66ad 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -56,7 +56,7 @@ sequences eval accessors ; 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call ] unit-test -[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ] +[ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ] [ error>> >r/r>-in-fry-error? ] must-fail-with [ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [ 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 b4417532b4..03bd21e58c 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -43,8 +43,6 @@ WHERE >> -\ sqsq must-infer - [ 16 ] [ 2 sqsq ] unit-test << @@ -65,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? [ [ ] ] [ @@ -73,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 @@ -91,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 @@ -107,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/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index a582755dc4..c7893117d1 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -9,6 +9,7 @@ http.server.responses furnace.utilities furnace.redirection furnace.conversations +furnace.chloe-tags html.forms html.components html.components diff --git a/basis/furnace/auth/auth-tests.factor b/basis/furnace/auth/auth-tests.factor index 220a8cd04c..54c32e7b4a 100644 --- a/basis/furnace/auth/auth-tests.factor +++ b/basis/furnace/auth/auth-tests.factor @@ -1,6 +1,3 @@ USING: furnace.auth tools.test ; IN: furnace.auth.tests -\ logged-in-username must-infer -\ must-infer -\ new-realm must-infer diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor index d0fdf22c27..996047e83d 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.edit-profile.tests USING: tools.test furnace.auth.features.edit-profile ; -\ allow-edit-profile must-infer + diff --git a/basis/furnace/auth/features/recover-password/recover-password-tests.factor b/basis/furnace/auth/features/recover-password/recover-password-tests.factor index b589c52624..313b8ef397 100644 --- a/basis/furnace/auth/features/recover-password/recover-password-tests.factor +++ b/basis/furnace/auth/features/recover-password/recover-password-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.recover-password USING: tools.test furnace.auth.features.recover-password ; -\ allow-password-recovery must-infer + diff --git a/basis/furnace/auth/features/registration/registration-tests.factor b/basis/furnace/auth/features/registration/registration-tests.factor index e770f35586..42acda416c 100644 --- a/basis/furnace/auth/features/registration/registration-tests.factor +++ b/basis/furnace/auth/features/registration/registration-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.features.registration.tests USING: tools.test furnace.auth.features.registration ; -\ allow-registration must-infer + diff --git a/basis/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor index 64f7bd3b96..aabd0c5c30 100644 --- a/basis/furnace/auth/login/login-tests.factor +++ b/basis/furnace/auth/login/login-tests.factor @@ -1,4 +1,4 @@ IN: furnace.auth.login.tests USING: tools.test furnace.auth.login ; -\ must-infer + diff --git a/basis/furnace/cache/cache.factor b/basis/furnace/cache/cache.factor index a5308c171e..fe2840c9eb 100644 --- a/basis/furnace/cache/cache.factor +++ b/basis/furnace/cache/cache.factor @@ -22,7 +22,7 @@ server-state f : expire-state ( class -- ) new - -1.0/0.0 millis [a,b] >>expires + -1/0. millis [a,b] >>expires delete-tuples ; TUPLE: server-state-manager < filter-responder timeout ; diff --git a/basis/furnace/db/db-tests.factor b/basis/furnace/db/db-tests.factor index 34357ae701..15698d8e9b 100644 --- a/basis/furnace/db/db-tests.factor +++ b/basis/furnace/db/db-tests.factor @@ -1,4 +1,4 @@ IN: furnace.db.tests USING: tools.test furnace.db ; -\ must-infer + diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor index adafb21524..37b2f40e82 100644 --- a/basis/furnace/furnace.factor +++ b/basis/furnace/furnace.factor @@ -17,7 +17,6 @@ USE: vocabs.loader "furnace.auth.providers.db" require "furnace.auth.providers.null" require "furnace.boilerplate" require -"furnace.chloe-tags" require "furnace.conversations" require "furnace.db" require "furnace.json" require diff --git a/basis/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor index 01297288dc..ff81d73f7f 100644 --- a/basis/furnace/redirection/redirection.factor +++ b/basis/furnace/redirection/redirection.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors combinators namespaces fry urls http -http.server http.server.redirection http.server.responses +USING: kernel accessors combinators namespaces fry urls urls.secure +http http.server http.server.redirection http.server.responses http.server.remapping http.server.filters furnace.utilities ; IN: furnace.redirection diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index b325c778cf..99855c76fa 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -22,7 +22,7 @@ M: foo call-responder* "x" [ 1+ ] schange "x" sget number>string "text/html" ; -: url-responder-mock-test ( -- ) +: url-responder-mock-test ( -- string ) [ "GET" >>method @@ -34,7 +34,7 @@ M: foo call-responder* [ write-response-body drop ] with-string-writer ] with-destructors ; -: sessions-mock-test ( -- ) +: sessions-mock-test ( -- string ) [ "GET" >>method diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 2088e468c6..3671511194 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -272,8 +272,8 @@ HELP: nweave HELP: n*quot { $values - { "n" integer } { "seq" sequence } - { "seq'" sequence } + { "n" integer } { "quot" quotation } + { "quot'" quotation } } { $examples { $example "USING: generalizations prettyprint math ;" diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 0aa042d4f2..139b7a528a 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -7,7 +7,7 @@ IN: generalizations << -: n*quot ( n seq -- seq' ) concat >quotation ; +: n*quot ( n quot -- quot' ) concat >quotation ; : repeat ( n obj quot -- ) swapd times ; inline @@ -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 -- ) @@ -94,4 +97,4 @@ MACRO: nweave ( n -- ) : nappend-as ( n exemplar -- seq ) [ narray concat ] dip like ; inline -: nappend ( n -- seq ) narray concat ; inline \ No newline at end of file +: nappend ( n -- seq ) narray concat ; inline diff --git a/basis/hash2/hash2-tests.factor b/basis/hash2/hash2-tests.factor index 6f97c7c3d5..682680bc50 100644 --- a/basis/hash2/hash2-tests.factor +++ b/basis/hash2/hash2-tests.factor @@ -4,11 +4,11 @@ IN: hash2.tests [ t ] [ 1 2 { 1 2 } 2= ] unit-test [ f ] [ 1 3 { 1 2 } 2= ] unit-test -: sample-hash ( -- ) +: sample-hash ( -- hash ) 5 - dup 2 3 "foo" roll set-hash2 - dup 4 2 "bar" roll set-hash2 - dup 4 7 "other" roll set-hash2 ; + [ [ 2 3 "foo" ] dip set-hash2 ] keep + [ [ 4 2 "bar" ] dip set-hash2 ] keep + [ [ 4 7 "other" ] dip set-hash2 ] keep ; [ "foo" ] [ 2 3 sample-hash hash2 ] unit-test [ "bar" ] [ 4 2 sample-hash hash2 ] unit-test diff --git a/basis/hash2/hash2.factor b/basis/hash2/hash2.factor index ffe6926130..aadc0d45a2 100644 --- a/basis/hash2/hash2.factor +++ b/basis/hash2/hash2.factor @@ -1,4 +1,6 @@ -USING: kernel sequences arrays math vectors ; +! Copyright (C) 2007 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences arrays math vectors locals ; IN: hash2 ! Little ad-hoc datastructure used to map two numbers @@ -22,8 +24,8 @@ IN: hash2 : assoc2 ( a b alist -- value ) (assoc2) dup [ third ] when ; inline -: set-assoc2 ( value a b alist -- alist ) - [ rot 3array ] dip ?push ; inline +:: set-assoc2 ( value a b alist -- alist ) + { a b value } alist ?push ; inline : hash2@ ( a b hash2 -- a b bucket hash2 ) [ 2dup hashcode2 ] dip [ length mod ] keep ; inline @@ -31,8 +33,8 @@ IN: hash2 : hash2 ( a b hash2 -- value/f ) hash2@ nth dup [ assoc2 ] [ 3drop f ] if ; -: set-hash2 ( a b value hash2 -- ) - [ -rot ] dip hash2@ [ set-assoc2 ] change-nth ; +:: set-hash2 ( a b value hash2 -- ) + value a b hash2 hash2@ [ set-assoc2 ] change-nth ; : alist>hash2 ( alist size -- hash2 ) [ over [ first3 ] dip set-hash2 ] reduce ; inline diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor index 7e780cbe5e..b476107562 100644 --- a/basis/heaps/heaps-tests.factor +++ b/basis/heaps/heaps-tests.factor @@ -54,7 +54,7 @@ IN: heaps.tests : sort-entries ( entries -- entries' ) [ [ key>> ] compare ] sort ; -: delete-test ( n -- ? ) +: delete-test ( n -- obj1 obj2 ) [ random-alist [ heap-push-all ] keep 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/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 2cc19f87dd..59486a9c35 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -12,7 +12,7 @@ $nl $nl "Factor evaluates code left to right, and stores intermediate values on a " { $emphasis "stack" } ". If you think of the stack as a pile of papers, then " { $emphasis "pushing" } " a value on the stack corresponds to placing a piece of paper at the top of the pile, while " { $emphasis "popping" } " a value corresponds to removing the topmost piece." $nl -"All words except those which only push literals on the stack must have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effect-declaration" } "." +"All words have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effects" } "." $nl "Coming back to the example in the beginning of this article, the following series of steps occurs as the code is evaluated:" { $table @@ -56,25 +56,16 @@ $nl "5 0 - ! Computes 5-0" "5 0 swap - ! Computes 0-5" } -"Also, in the above example a stack effect declaration is written between " { $snippet "(" } " and " { $snippet ")" } " with a mnemonic description of what the word does to the stack. See " { $link "effect-declaration" } " for details." +"Also, in the above example a stack effect declaration is written between " { $snippet "(" } " and " { $snippet ")" } " with a mnemonic description of what the word does to the stack. See " { $link "effects" } " for details." { $curious - "This syntax will be familiar to anybody who has used Forth before. However the behavior is slightly different. In most Forth systems, the below code prints 2, because the definition of " { $snippet "b" } " still refers to the previous definition of " { $snippet "a" } ":" - { $code - ": a 1 ;" - ": b ( -- x ) a 1 + ;" - ": a 2 ;" - "b ." - } - "In Factor, this example will print 3 since word redefinition is explicitly supported." - $nl - "Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "." + "This syntax will be familiar to anybody who has used Forth before. However, unlike Forth, some additional static checks are performed. See " { $link "definition-checking" } " and " { $link "inference" } "." } { $references { "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." } "shuffle-words" "words" "generic" - "tools" + "handbook-tools-reference" } ; ARTICLE: "cookbook-combinators" "Control flow cookbook" @@ -117,7 +108,7 @@ $nl } { $references { "Since quotations are objects, they can be constructed and taken apart at will. You can write code that writes code. Arrays are just one of the various types of sequences, and the sequence operations such as " { $link each } " and " { $link map } " operate on all types of sequences. There are many more sequence iteration operations than the ones above, too." } - "dataflow" + "combinators" "sequences" } ; @@ -175,53 +166,11 @@ $nl "parser" } ; -ARTICLE: "cookbook-io" "Input and output cookbook" -"Ask the user for their age, and print it back:" -{ $code - "USING: io math.parser ;" - ": ask-age ( -- ) \"How old are you?\" print ;" - ": read-age ( -- n ) readln string>number ;" - ": print-age ( n -- )" - " \"You are \" write" - " number>string write" - " \" years old.\" print ;" - ": example ( -- ) ask-age read-age print-age ;" - "example" -} -"Print the lines of a file in sorted order:" -{ $code - "USING: io io.encodings.utf8 io.files sequences sorting ;" - "\"lines.txt\" utf8 file-lines natural-sort [ print ] each" -} -"Read 1024 bytes from a file:" -{ $code - "USING: io io.encodings.binary io.files ;" - "\"data.bin\" binary [ 1024 read ] with-file-reader" -} -"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" -{ $code - "USING: accessors grouping io.files io.mmap.char kernel sequences ;" - "\"mydata.dat\" [" - " 4 [ reverse-here ] change-each" - "] with-mapped-char-file" -} -"Send some bytes to a remote host:" -{ $code - "USING: io io.encodings.ascii io.sockets strings ;" - "\"myhost\" 1033 ascii" - "[ B{ 12 17 102 } write ] with-client" -} -{ $references - { } - "number-strings" - "io" -} ; - ARTICLE: "cookbook-application" "Application cookbook" "Vocabularies can define a main entry point:" { $code "IN: game-of-life" "..." -": play-life ... ;" +": play-life ( -- ) ... ;" "" "MAIN: play-life" } @@ -318,7 +267,6 @@ $nl { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." } { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." } "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition." - { "Learn to use the " { $link "inference" } " tool." } { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." } "Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution." { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." } @@ -332,6 +280,7 @@ $nl "Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code." $nl "Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ; + ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" "Factor is a very clean and consistent language. However, it has some limitations and leaky abstractions you should keep in mind, as well as behaviors which differ from other languages you may be used to." { $list @@ -341,13 +290,6 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" { "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." } { "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." } { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." } - { "Performance-sensitive code should have a static stack effect so that it can be compiled by the optimizing word compiler, which generates more efficient code than the non-optimizing quotation compiler. See " { $link "inference" } " and " { $link "compiler" } "." - $nl - "This means that methods defined on performance sensitive, frequently-called core generic words such as " { $link nth } " should have static stack effects which are consistent with each other, since a generic word will only have a static stack effect if all methods do." - $nl - "Unit tests for the " { $vocab-link "stack-checker" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:" - { $code "\"stack-checker\" test" } - "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." } { "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." } { "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." } } ; @@ -372,7 +314,6 @@ ARTICLE: "cookbook" "Factor cookbook" { $subsection "cookbook-combinators" } { $subsection "cookbook-variables" } { $subsection "cookbook-vocabs" } -{ $subsection "cookbook-io" } { $subsection "cookbook-application" } { $subsection "cookbook-scripts" } { $subsection "cookbook-philosophy" } diff --git a/basis/help/crossref/crossref-docs.factor b/basis/help/crossref/crossref-docs.factor index ae227fde89..7f243ec764 100644 --- a/basis/help/crossref/crossref-docs.factor +++ b/basis/help/crossref/crossref-docs.factor @@ -17,8 +17,3 @@ HELP: xref-article { $values { "topic" "an article name or a word" } } { $description "Sets the " { $link article-parent } " of each child of this article." } $low-level-note ; - -HELP: unxref-article -{ $values { "topic" "an article name or a word" } } -{ $description "Clears the " { $link article-parent } " of each child of this article." } -$low-level-note ; diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 2e01330d73..95d4612cbe 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays io.streams.string continuations debugger compiler.units eval ; [ ] [ - "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- ) ] unit-test [ $subsection ] [ @@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ; ] unit-test [ ] [ - "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- ) ] unit-test [ ] [ diff --git a/basis/help/crossref/crossref.factor b/basis/help/crossref/crossref.factor index b791a4b124..46f9561605 100644 --- a/basis/help/crossref/crossref.factor +++ b/basis/help/crossref/crossref.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs math fry io kernel namespaces prettyprint prettyprint.sections @@ -12,9 +12,6 @@ IN: help.crossref : article-children ( topic -- seq ) { $subsection } article-links ; -M: link uses - { $subsection $link $see-also } article-links ; - : help-path ( topic -- seq ) [ article-parent ] follow rest ; @@ -22,10 +19,7 @@ M: link uses article-children [ set-article-parent ] with each ; : xref-article ( topic -- ) - dup >link xref dup set-article-parents ; - -: unxref-article ( topic -- ) - >link unxref ; + dup set-article-parents ; : prev/next ( obj seq n -- obj' ) [ [ index dup ] keep ] dip swap diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor index 7bb66eca02..c3365fe53f 100644 --- a/basis/help/definitions/definitions-tests.factor +++ b/basis/help/definitions/definitions-tests.factor @@ -32,7 +32,7 @@ IN: help.definitions.tests "hello" "help.definitions.tests" lookup "help" word-prop ] unit-test - [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test + [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval( -- ) ] unit-test [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index ed2a14a2f2..b83fb22ccf 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -5,7 +5,7 @@ math system strings sbufs vectors byte-arrays quotations io.streams.byte-array classes.builtin parser lexer classes.predicate classes.union classes.intersection classes.singleton classes.tuple help.vocabs math.parser -accessors ; +accessors definitions sets ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -13,13 +13,13 @@ ARTICLE: "conventions" "Conventions" { $heading "Documentation conventions" } "Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article." $nl -"Every article has links to parent articles at the top. These can be persued if the article is too specific." +"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific." $nl "Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are." { $heading "Vocabulary naming conventions" } "A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")." $nl -"You should should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason." +"You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason." { $heading "Word naming conventions" } "These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:" { $table @@ -39,7 +39,7 @@ $nl { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } } { $heading "Stack effect conventions" } -"Stack effect conventions are documented in " { $link "effect-declaration" } "." +"Stack effect conventions are documented in " { $link "effects" } "." { $heading "Glossary of terms" } "Common terminology and abbreviations used throughout Factor and its documentation:" { $table @@ -49,13 +49,15 @@ $nl { "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } } { "boolean" { { $link t } " or " { $link f } } } { "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } } - { "definition specifier" { "a " { $link word } ", " { $link method-spec } ", " { $link link } ", vocabulary specifier, or any other object whose class implements the " { $link "definition-protocol" } } } + { "combinator" { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } } + { "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } } { "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } } { "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } } { "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } } { "object" { "any datum which can be identified" } } { "ordering specifier" { "see " { $link "order-specifiers" } } } { "pathname string" { "an OS-specific pathname which identifies a file" } } + { "quotation" { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } } { "sequence" { "a sequence; see " { $link "sequence-protocol" } } } { "slot" { "a component of an object which can store a value" } } { "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } } @@ -70,7 +72,7 @@ ARTICLE: "tail-call-opt" "Tail-call optimization" $nl "Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ; -ARTICLE: "evaluator" "Evaluation semantics" +ARTICLE: "evaluator" "Stack machine model" { $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:" { $list { "a " { $link word } " - the word's definition quotation is called. See " { $link "words" } } @@ -84,12 +86,13 @@ ARTICLE: "objects" "Objects" "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed." { $subsection "equality" } { $subsection "math.order" } -{ $subsection "destructors" } { $subsection "classes" } { $subsection "tuples" } { $subsection "generic" } -{ $subsection "slots" } -{ $subsection "mirrors" } ; +"Advanced features:" +{ $subsection "delegate" } +{ $subsection "mirrors" } +{ $subsection "slots" } ; ARTICLE: "numbers" "Numbers" { $subsection "arithmetic" } @@ -118,9 +121,9 @@ ARTICLE: "collections" "Collections" "Fixed-length sequences:" { $subsection "arrays" } { $subsection "quotations" } -"Fixed-length specialized sequences:" { $subsection "strings" } { $subsection "byte-arrays" } +{ $subsection "specialized-arrays" } "Resizable sequences:" { $subsection "vectors" } { $subsection "byte-vectors" } @@ -128,7 +131,8 @@ ARTICLE: "collections" "Collections" { $subsection "growable" } { $heading "Associative mappings" } { $subsection "assocs" } -{ $subsection "namespaces" } +{ $subsection "linked-assocs" } +{ $subsection "biassocs" } { $subsection "refs" } "Implementations:" { $subsection "hashtables" } @@ -140,26 +144,29 @@ ARTICLE: "collections" "Collections" { $subsection "dlists" } { $subsection "search-deques" } { $heading "Other collections" } -{ $subsection "boxes" } +{ $subsection "lists" } +{ $subsection "disjoint-sets" } +{ $subsection "interval-maps" } { $subsection "heaps" } +{ $subsection "boxes" } { $subsection "graphs" } { $subsection "buffers" } "There are also many other vocabularies tagged " { $link T{ vocab-tag { name "collections" } } } " in the library." ; -USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ; +USING: io.encodings.utf8 io.encodings.binary io.files ; ARTICLE: "encodings-introduction" "An introduction to encodings" "In order to express text in terms of binary, some sort of encoding has to be used. In a modern context, this is understood as a two-way mapping between Unicode code points (characters) and some amount of binary. Since English isn't the only language in the world, ASCII is not sufficient as a mapping from binary to Unicode; it can't even express em-dashes or curly quotes. Unicode was designed as a universal character set that could potentially represent everything." $nl "Not all encodings can represent all Unicode code points, but Unicode can represent basically everything that exists in modern encodings. Some encodings are language-specific, and some can represent everything in Unicode. Though the world is moving toward Unicode and UTF-8, the reality today is that there are several encodings which must be taken into account." $nl -"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } ", " { $link ascii } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl +"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl "Constructors for streams which deal with bytes usually take an encoding as an explicit parameter. For example, to open a text file for reading whose contents are in UTF-8, use the following" { $code "\"file.txt\" utf8 " } "If there is an error in the encoded stream, a replacement character (0xFFFD) will be inserted. To throw an exception upon error, use a strict encoding as follows" { $code "\"file.txt\" utf8 strict " } "In a similar way, encodings can be specified when opening a file for writing." -{ $code "\"file.txt\" ascii " } +{ $code "USE: io.encodings.ascii" "\"file.txt\" ascii " } "An encoding is also needed for some words that don't return streams, such as " { $link file-contents } ", for example" -{ $code "\"file.txt\" utf16 file-contents" } +{ $code "USE: io.encodings.utf16" "\"file.txt\" utf16 file-contents" } "Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text." $nl "When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ; @@ -190,29 +197,6 @@ ARTICLE: "io" "Input and output" { $subsection "io.ports" } { $see-also "destructors" } ; -ARTICLE: "tools" "Developer tools" -{ $subsection "tools.vocabs" } -"Exploratory tools:" -{ $subsection "see" } -{ $subsection "editor" } -{ $subsection "listener" } -{ $subsection "tools.crossref" } -{ $subsection "inspector" } -{ $subsection "tools.completion" } -{ $subsection "summary" } -"Debugging tools:" -{ $subsection "tools.annotations" } -{ $subsection "tools.test" } -{ $subsection "tools.threads" } -"Performance tools:" -{ $subsection "tools.memory" } -{ $subsection "profiling" } -{ $subsection "timing" } -{ $subsection "tools.disassembler" } -"Deployment tools:" -{ $subsection "tools.deploy" } -{ $see-also "ui-tools" } ; - ARTICLE: "article-index" "Article index" { $index [ articles get keys ] } ; @@ -239,52 +223,101 @@ ARTICLE: "class-index" "Class index" { $heading "Predicate classes" } { $index [ classes [ predicate-class? ] filter ] } ; -ARTICLE: "program-org" "Program organization" -{ $subsection "definitions" } -{ $subsection "vocabularies" } -{ $subsection "parser" } -{ $subsection "vocabs.loader" } -{ $subsection "source-files" } ; - USING: help.cookbook help.tutorial ; -ARTICLE: "handbook-language-reference" "Language reference" +ARTICLE: "handbook-language-reference" "The language" +{ $heading "Fundamentals" } { $subsection "conventions" } { $subsection "syntax" } -{ $subsection "dataflow" } -{ $subsection "objects" } -{ $subsection "program-org" } +{ $heading "The stack" } +{ $subsection "evaluator" } +{ $subsection "effects" } +{ $subsection "inference" } +{ $heading "Basic data types" } +{ $subsection "booleans" } { $subsection "numbers" } { $subsection "collections" } -{ $subsection "io" } +{ $heading "Evaluation" } +{ $subsection "words" } +{ $subsection "shuffle-words" } +{ $subsection "combinators" } +{ $subsection "threads" } +{ $heading "Named values" } +{ $subsection "locals" } +{ $subsection "namespaces" } +{ $subsection "namespaces-global" } +{ $subsection "values" } +{ $heading "Abstractions" } +{ $subsection "errors" } +{ $subsection "objects" } +{ $subsection "destructors" } +{ $subsection "continuations" } +{ $subsection "memoize" } +{ $subsection "parsing-words" } +{ $subsection "macros" } +{ $subsection "fry" } +{ $heading "Program organization" } +{ $subsection "vocabs.loader" } "Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ; -ARTICLE: "handbook-environment-reference" "Environment reference" -{ $subsection "prettyprint" } -{ $subsection "tools" } +ARTICLE: "handbook-system-reference" "The implementation" +{ $heading "Parse time and compile time" } +{ $subsection "parser" } +{ $subsection "definitions" } +{ $subsection "vocabularies" } +{ $subsection "source-files" } +{ $subsection "compiler" } +{ $subsection "tools.errors" } +{ $heading "Virtual machine" } +{ $subsection "images" } { $subsection "cli" } { $subsection "rc-files" } -{ $subsection "help" } -{ $subsection "inference" } -{ $subsection "compiler" } -{ $subsection "system" } -{ $subsection "images" } -{ $subsection "alien" } { $subsection "init" } -{ $subsection "layouts" } -{ $see-also "program-org" } ; +{ $subsection "system" } +{ $subsection "layouts" } ; -ARTICLE: "handbook-library-reference" "Library reference" -"This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "." -{ $index [ "handbook" orphan-articles remove ] } ; +ARTICLE: "handbook-tools-reference" "Developer tools" +"The below tools are text-based. " { $link "ui-tools" } " are documented separately." +{ $heading "Workflow" } +{ $subsection "listener" } +{ $subsection "editor" } +{ $subsection "vocabs.refresh" } +{ $subsection "tools.test" } +{ $subsection "help" } +{ $heading "Debugging" } +{ $subsection "prettyprint" } +{ $subsection "inspector" } +{ $subsection "tools.annotations" } +{ $subsection "tools.inference" } +{ $heading "Browsing" } +{ $subsection "see" } +{ $subsection "tools.crossref" } +{ $subsection "vocabs.hierarchy" } +{ $heading "Performance" } +{ $subsection "timing" } +{ $subsection "profiling" } +{ $subsection "tools.memory" } +{ $subsection "tools.threads" } +{ $subsection "tools.disassembler" } +{ $heading "Deployment" } +{ $subsection "tools.deploy" } ; + +ARTICLE: "handbook-library-reference" "Libraries" +"This index lists articles from loaded vocabularies which are not subsections of any other article. To explore more vocabularies, see " { $link "vocab-index" } "." +{ $index [ orphan-articles { "help.home" "handbook" } diff ] } ; ARTICLE: "handbook" "Factor handbook" "Learn the language:" { $subsection "cookbook" } { $subsection "first-program" } +"Reference material:" { $subsection "handbook-language-reference" } -{ $subsection "handbook-environment-reference" } +{ $subsection "io" } { $subsection "ui" } +{ $subsection "handbook-system-reference" } +{ $subsection "handbook-tools-reference" } +{ $subsection "ui-tools" } +{ $subsection "alien" } { $subsection "handbook-library-reference" } "Explore loaded libraries:" { $subsection "article-index" } diff --git a/basis/help/help.factor b/basis/help/help.factor index d20e06b6c6..6e09e298f4 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -54,7 +54,7 @@ M: word article-title dup [ parsing-word? ] [ symbol? ] bi or [ name>> ] [ - [ name>> ] + [ unparse ] [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi append ] if ; @@ -156,10 +156,7 @@ help-hook [ [ print-topic ] ] initialize error get (:help) ; : remove-article ( name -- ) - dup articles get key? [ - dup unxref-article - dup articles get delete-at - ] when drop ; + articles get delete-at ; : add-article ( article name -- ) [ remove-article ] keep @@ -167,7 +164,6 @@ help-hook [ [ print-topic ] ] initialize xref-article ; : remove-word-help ( word -- ) - dup word-help [ dup unxref-article ] when f "help" set-word-prop ; : set-word-help ( content word -- ) diff --git a/basis/help/home/home-docs.factor b/basis/help/home/home-docs.factor index 6608a6e9c0..b40d162670 100644 --- a/basis/help/home/home-docs.factor +++ b/basis/help/home/home-docs.factor @@ -8,7 +8,7 @@ ARTICLE: "help.home" "Factor documentation" { $link "handbook" } { $link "vocab-index" } { $link "ui-tools" } - { $link "handbook-library-reference" } + { $link "ui-listener" } } { $heading "Recently visited" } { $table diff --git a/basis/help/home/home.factor b/basis/help/home/home.factor index f32c0db30d..9cb3c6f1bb 100644 --- a/basis/help/home/home.factor +++ b/basis/help/home/home.factor @@ -21,7 +21,7 @@ M: apropos add-recent-where recent-searches ; M: object add-recent-where f ; : $recent ( element -- ) - first get [ nl ] [ 1array $pretty-link ] interleave ; + first get reverse [ nl ] [ 1array $pretty-link ] interleave ; : $recent-searches ( element -- ) drop recent-searches get [ <$link> ] map $list ; diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index d880af5b55..348fcbbbfb 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -3,25 +3,27 @@ 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.loader serialize fry memoize unicode.case math.order -sorting debugger html xml.syntax xml.writer ; +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 : escape-char ( ch -- ) - dup H{ - { CHAR: " "__quo__" } - { CHAR: * "__star__" } - { CHAR: : "__colon__" } - { CHAR: < "__lt__" } - { CHAR: > "__gt__" } - { CHAR: ? "__que__" } - { CHAR: \\ "__back__" } - { CHAR: | "__pipe__" } - { CHAR: / "__slash__" } - { CHAR: , "__comma__" } - { CHAR: @ "__at__" } - } at [ % ] [ , ] ?if ; + dup ascii? [ + dup H{ + { CHAR: " "__quo__" } + { CHAR: * "__star__" } + { CHAR: : "__colon__" } + { CHAR: < "__lt__" } + { CHAR: > "__gt__" } + { CHAR: ? "__que__" } + { CHAR: \\ "__back__" } + { CHAR: | "__pipe__" } + { CHAR: / "__slash__" } + { CHAR: , "__comma__" } + { CHAR: @ "__at__" } + } at [ % ] [ , ] ?if + ] [ number>string "__" "__" surround % ] if ; : escape-filename ( string -- filename ) [ [ escape-char ] each ] "" make ; diff --git a/basis/help/lint/checks/authors.txt b/basis/help/lint/checks/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/help/lint/checks/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor new file mode 100644 index 0000000000..4a15f864a6 --- /dev/null +++ b/basis/help/lint/checks/checks.factor @@ -0,0 +1,176 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes combinators +combinators.short-circuit definitions effects eval fry grouping +help help.markup help.topics io.streams.string kernel macros +namespaces sequences sequences.deep sets sorting splitting +strings unicode.categories values vocabs vocabs.loader words +words.symbol summary debugger io ; +IN: help.lint.checks + +ERROR: simple-lint-error message ; + +M: simple-lint-error summary message>> ; + +M: simple-lint-error error. summary print ; + +SYMBOL: vocabs-quot +SYMBOL: all-vocabs +SYMBOL: vocab-articles + +: check-example ( element -- ) + '[ + _ rest [ + but-last "\n" join + [ (eval>string) ] call( code -- output ) + "\n" ?tail drop + ] keep + peek assert= + ] vocabs-quot get call( quot -- ) ; + +: check-examples ( element -- ) + \ $example swap elements [ check-example ] each ; + +: extract-values ( element -- seq ) + \ $values swap elements dup empty? [ + first rest [ first ] map prune natural-sort + ] unless ; + +: effect-values ( word -- seq ) + stack-effect + [ in>> ] [ out>> ] bi append + [ dup pair? [ first ] when effect>string ] map + prune natural-sort ; + +: contains-funky-elements? ( element -- ? ) + { + $shuffle + $values-x/y + $predicate + $class-description + $error-description + } swap '[ _ elements empty? not ] any? ; + +: don't-check-word? ( word -- ? ) + { + [ macro? ] + [ symbol? ] + [ value-word? ] + [ parsing-word? ] + [ "declared-effect" word-prop not ] + } 1|| ; + +: check-values ( word element -- ) + { + [ + [ don't-check-word? ] + [ contains-funky-elements? ] + bi* or + ] [ + [ effect-values ] + [ extract-values ] + bi* sequence= + ] + } 2|| [ "$values don't match stack effect" simple-lint-error ] unless ; + +: check-nulls ( element -- ) + \ $values swap elements + null swap deep-member? + [ "$values should not contain null" simple-lint-error ] when ; + +: check-see-also ( element -- ) + \ $see-also swap elements [ + rest dup prune [ length ] bi@ assert= + ] each ; + +: vocab-exists? ( name -- ? ) + [ vocab ] [ all-vocabs get member? ] bi or ; + +: check-modules ( element -- ) + \ $vocab-link swap elements [ + second + vocab-exists? [ + "$vocab-link to non-existent vocabulary" + simple-lint-error + ] unless + ] each ; + +: check-rendering ( element -- ) + [ print-content ] with-string-writer drop ; + +: check-strings ( str -- ) + [ + "\n\t" intersects? [ + "Paragraph text should not contain \\n or \\t" + simple-lint-error + ] when + ] [ + " " swap subseq? [ + "Paragraph text should not contain double spaces" + simple-lint-error + ] when + ] bi ; + +: check-whitespace ( str1 str2 -- ) + [ " " tail? ] [ " " head? ] bi* or + [ "Missing whitespace between strings" simple-lint-error ] unless ; + +: check-bogus-nl ( element -- ) + { { $nl } { { $nl } } } [ head? ] with any? [ + "Simple element should not begin with a paragraph break" + simple-lint-error + ] when ; + +: check-class-description ( word element -- ) + [ class? not ] + [ { $class-description } swap elements empty? not ] bi* and + [ "A word that is not a class has a $class-description" simple-lint-error ] when ; + +: check-article-title ( article -- ) + article-title first LETTER? + [ "Article title must begin with a capital letter" simple-lint-error ] unless ; + +: check-elements ( element -- ) + { + [ check-bogus-nl ] + [ [ string? ] filter [ check-strings ] each ] + [ [ simple-element? ] filter [ check-elements ] each ] + [ 2 [ [ string? ] all? ] filter [ first2 check-whitespace ] each ] + } cleave ; + +: check-descriptions ( element -- ) + { $description $class-description $var-description } + swap '[ + _ elements [ + rest { { } { "" } } member? + [ "Empty description" throw ] when + ] each + ] each ; + +: check-markup ( element -- ) + { + [ check-elements ] + [ check-rendering ] + [ check-examples ] + [ check-modules ] + [ check-descriptions ] + } cleave ; + +: files>vocabs ( -- assoc ) + vocabs + [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ] + [ [ [ vocab-source-path ] keep ] H{ } map>assoc ] + bi assoc-union ; + +: group-articles ( -- assoc ) + articles get keys + files>vocabs + H{ } clone [ + '[ + dup >link where dup + [ first _ at _ push-at ] [ 2drop ] if + ] each + ] keep ; + +: all-word-help ( words -- seq ) + [ word-help ] filter ; diff --git a/basis/help/lint/lint-docs.factor b/basis/help/lint/lint-docs.factor index 0c0fcf92d2..ed74748356 100644 --- a/basis/help/lint/lint-docs.factor +++ b/basis/help/lint/lint-docs.factor @@ -14,6 +14,10 @@ $nl "To run help lint, use one of the following two words:" { $subsection help-lint } { $subsection help-lint-all } +"Once a help lint run completes, failures can be listed:" +{ $subsection :lint-failures } +"Help lint failures are also shown in the " { $link "ui.tools.error-list" } "." +$nl "Help lint performs the following checks:" { $list "ensures examples run and produce stated output" diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 7ec8c59ba6..7a5b482270 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -1,161 +1,53 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors sequences parser kernel help help.markup -help.topics words strings classes tools.vocabs namespaces make -io io.streams.string prettyprint definitions arrays vectors -combinators combinators.short-circuit splitting debugger -hashtables sorting effects vocabs vocabs.loader assocs editors -continuations classes.predicate macros math sets eval -vocabs.parser words.symbol values grouping unicode.categories -sequences.deep ; +USING: assocs continuations fry help help.lint.checks +help.topics io kernel namespaces parser sequences +source-files.errors vocabs.hierarchy vocabs words classes +locals tools.errors ; +FROM: help.lint.checks => all-vocabs ; IN: help.lint -SYMBOL: vocabs-quot +SYMBOL: lint-failures -: check-example ( element -- ) - '[ - _ rest [ - but-last "\n" join - [ (eval>string) ] call( code -- output ) - "\n" ?tail drop - ] keep - peek assert= - ] vocabs-quot get call( quot -- ) ; +lint-failures [ H{ } clone ] initialize -: check-examples ( element -- ) - \ $example swap elements [ check-example ] each ; +TUPLE: help-lint-error < source-file-error ; -: extract-values ( element -- seq ) - \ $values swap elements dup empty? [ - first rest [ first ] map prune natural-sort - ] unless ; +SYMBOL: +help-lint-failure+ -: effect-values ( word -- seq ) - stack-effect - [ in>> ] [ out>> ] bi append - [ dup pair? [ first ] when effect>string ] map - prune natural-sort ; +T{ error-type + { type +help-lint-failure+ } + { word ":lint-failures" } + { plural "help lint failures" } + { icon "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } + { quot [ lint-failures get values ] } + { forget-quot [ lint-failures get delete-at ] } +} define-error-type -: contains-funky-elements? ( element -- ? ) - { - $shuffle - $values-x/y - $predicate - $class-description - $error-description - } swap '[ _ elements empty? not ] any? ; +M: help-lint-error error-type drop +help-lint-failure+ ; -: don't-check-word? ( word -- ? ) - { - [ macro? ] - [ symbol? ] - [ value-word? ] - [ parsing-word? ] - [ "declared-effect" word-prop not ] - } 1|| ; + ( error topic -- help-lint-error ) + \ help-lint-error ; -: check-nulls ( element -- ) - \ $values swap elements - null swap deep-member? - [ "$values should not contain null" throw ] when ; +PRIVATE> -: check-see-also ( element -- ) - \ $see-also swap elements [ - rest dup prune [ length ] bi@ assert= - ] each ; +: help-lint-error ( error topic -- ) + lint-failures get pick + [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if + notify-error-observers ; -: vocab-exists? ( name -- ? ) - [ vocab ] [ "all-vocabs" get member? ] bi or ; + [ [ string? ] all? ] filter [ first2 check-whitespace ] each ] - } cleave ; - -: check-descriptions ( element -- ) - { $description $class-description $var-description } - swap '[ - _ elements [ - rest { { } { "" } } member? - [ "Empty description" throw ] when - ] each - ] each ; - -: check-markup ( element -- ) - { - [ check-elements ] - [ check-rendering ] - [ check-examples ] - [ check-modules ] - [ check-descriptions ] - } cleave ; - -: check-class-description ( word element -- ) - [ class? not ] - [ { $class-description } swap elements empty? not ] bi* and - [ "A word that is not a class has a $class-description" throw ] when ; - -: all-word-help ( words -- seq ) - [ word-help ] filter ; - -TUPLE: help-error error topic ; - -C: help-error - -M: help-error error. - [ "In " write topic>> pprint nl ] - [ error>> error. ] - bi ; - -: check-something ( obj quot -- ) - flush '[ _ call( -- ) ] swap '[ _ , ] recover ; inline +:: check-something ( topic quot -- ) + [ quot call( -- ) f ] [ ] recover + topic help-lint-error ; inline : check-word ( word -- ) [ with-file-vocabs ] vocabs-quot set dup word-help [ - dup '[ + [ >link ] keep '[ _ dup word-help [ check-values ] [ check-class-description ] @@ -165,69 +57,38 @@ M: help-error error. : check-words ( words -- ) [ check-word ] each ; -: check-article-title ( article -- ) - article-title first LETTER? - [ "Article title must begin with a capital letter" throw ] unless ; - : check-article ( article -- ) [ with-interactive-vocabs ] vocabs-quot set - dup '[ + >link dup '[ _ [ check-article-title ] [ article-content check-markup ] bi ] check-something ; -: files>vocabs ( -- assoc ) - vocabs - [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ] - [ [ [ vocab-source-path ] keep ] H{ } map>assoc ] - bi assoc-union ; - -: group-articles ( -- assoc ) - articles get keys - files>vocabs - H{ } clone [ - '[ - dup >link where dup - [ first _ at _ push-at ] [ 2drop ] if - ] each - ] keep ; - : check-about ( vocab -- ) dup '[ _ vocab-help [ article drop ] when* ] check-something ; -: check-vocab ( vocab -- seq ) +: check-vocab ( vocab -- ) "Checking " write dup write "..." print - [ - [ check-about ] - [ words [ check-word ] each ] - [ "vocab-articles" get at [ check-article ] each ] - tri - ] { } make ; + [ vocab check-about ] + [ words [ check-word ] each ] + [ vocab-articles get at [ check-article ] each ] + tri ; -: run-help-lint ( prefix -- alist ) +PRIVATE> + +: help-lint ( prefix -- ) [ - all-vocabs-seq [ vocab-name ] map "all-vocabs" set - group-articles "vocab-articles" set + all-vocabs-seq [ vocab-name ] map all-vocabs set + group-articles vocab-articles set child-vocabs - [ dup check-vocab ] { } map>assoc - [ nip empty? not ] assoc-filter + [ check-vocab ] each ] with-scope ; -: typos. ( assoc -- ) - [ - "==== ALL CHECKS PASSED" print - ] [ - [ - swap vocab-heading. - [ print-error nl ] each - ] assoc-each - ] if-empty ; - -: help-lint ( prefix -- ) run-help-lint typos. ; - : help-lint-all ( -- ) "" help-lint ; +: :lint-failures ( -- ) lint-failures get values errors. ; + : unlinked-words ( words -- seq ) all-word-help [ article-parent not ] filter ; @@ -235,6 +96,6 @@ M: help-error error. all-words [ word-help not ] filter [ article-parent ] filter - [ "predicating" word-prop not ] filter ; + [ predicate? not ] filter ; MAIN: help-lint diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index 9b928f3691..93bed37a55 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -5,7 +5,7 @@ IN: help.markup.tests TUPLE: blahblah quux ; -[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test +[ "int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test [ ] [ \ quux>> print-topic ] unit-test [ ] [ \ >>quux print-topic ] unit-test @@ -26,5 +26,3 @@ TUPLE: blahblah quux ; [ "a string, a fixnum, or an integer" ] [ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test -\ print-element must-infer -\ print-topic must-infer \ No newline at end of file diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 8b5edf38c1..04b6d90883 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -138,7 +138,7 @@ ALIAS: $slot $snippet ! Images : $image ( element -- ) - [ [ "" ] dip first image associate format ] ($span) ; + [ first write-image ] ($span) ; : <$image> ( path -- element ) 1array \ $image prefix ; @@ -251,7 +251,7 @@ M: word ($instance) dup name>> a/an write bl ($link) ; M: string ($instance) - dup a/an write bl $snippet ; + write ; M: f ($instance) drop { f } $link ; diff --git a/basis/help/syntax/syntax-tests.factor b/basis/help/syntax/syntax-tests.factor index e7438edd4d..7618e9cdeb 100644 --- a/basis/help/syntax/syntax-tests.factor +++ b/basis/help/syntax/syntax-tests.factor @@ -4,12 +4,12 @@ IN: help.syntax.tests [ [ "foobar" ] [ - "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval + "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval( -- ) "help.syntax.tests" vocab vocab-help ] unit-test [ { "foobar" } ] [ - "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval + "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval( -- ) "help.syntax.tests" vocab vocab-help ] unit-test diff --git a/basis/help/syntax/tags.txt b/basis/help/syntax/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/help/syntax/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index f53bdee9c7..cafeb009a4 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -3,11 +3,6 @@ help.markup help.syntax kernel sequences tools.test words parser namespaces assocs source-files eval ; IN: help.topics.tests -\ article-name must-infer -\ article-title must-infer -\ article-content must-infer -\ article-parent must-infer - ! Test help cross-referencing [ ] [ "Test B" { "Hello world." }
{ "test" "b" } add-article ] unit-test @@ -29,7 +24,7 @@ SYMBOL: foo } "\n" join [ "testfile" source-file file set - eval + eval( -- ) ] with-scope ] unit-test diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index 26812947c0..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 @@ -76,9 +76,11 @@ $nl { $code "." } "What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "." $nl -"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool." +"Create a test harness file using the scaffold tool:" +{ $code "\"palindrome\" scaffold-tests" } +"Now, open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool." $nl -"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values." +"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link POSTPONE: unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values." $nl "Add the following three lines to " { $snippet "palindrome-tests.factor" } ":" { $code 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 804ef035f4..db04033275 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,10 +1,10 @@ -! 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 generic generic.standard generic.standard.engines classes -hashtables ; +byte-arrays byte-vectors io.binary io.streams.string splitting math +math.parser generic generic.single generic.standard classes +hashtables namespaces ; IN: hints GENERIC: specializer-predicate ( spec -- quot ) @@ -25,7 +25,7 @@ M: object specializer-declaration class ; [ drop object eq? not ] assoc-filter [ [ t ] ] [ [ swap specializer-predicate append ] { } assoc>map - unclip [ swap [ f ] \ if 3array append [ ] like ] reduce + [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce ] if-empty ; : specializer-cases ( quot word -- default alist ) @@ -37,13 +37,18 @@ M: object specializer-declaration class ; : specialize-quot ( quot specializer -- quot' ) specializer-cases alist>quot ; +! compiler.tree.propagation.inlining sets this to f +SYMBOL: specialize-method? + +t specialize-method? set-global + : method-declaration ( method -- quot ) [ "method-generic" word-prop dispatch# object ] [ "method-class" word-prop ] - bi prefix ; + bi prefix [ declare ] curry [ ] like ; : specialize-method ( quot method -- quot' ) - [ method-declaration '[ _ declare ] prepend ] + [ specialize-method? get [ method-declaration prepend ] [ drop ] if ] [ "method-generic" word-prop "specializer" word-prop ] bi [ specialize-quot ] when* ; @@ -65,9 +70,8 @@ M: object specializer-declaration class ; SYNTAX: HINTS: scan-object - dup method-spec? [ first2 method ] when - [ redefined ] - [ parse-definition "specializer" set-word-prop ] bi ; + [ changed-definition ] + [ parse-definition { } like "specializer" set-word-prop ] bi ; ! Default specializers { first first2 first3 first4 } @@ -119,6 +123,8 @@ SYNTAX: HINTS: \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop -\ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop +\ base> { string fixnum } "specializer" set-word-prop -\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop +M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop + +M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index 72ceea20a0..da2e5b5991 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -4,8 +4,6 @@ io.streams.null accessors inspector html.streams html.components html.forms namespaces xml.writer ; -\ render must-infer - [ ] [ begin-form ] unit-test [ ] [ 3 "hi" set-value ] unit-test 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/client-tests.factor b/basis/http/client/client-tests.factor index 4dcc6b8813..4f786cb22c 100644 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -1,8 +1,6 @@ USING: http.client http.client.private http tools.test namespaces urls ; -\ download must-infer - [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 4099e3d84c..d1997c73f9 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -6,7 +6,7 @@ math.order hashtables byte-arrays destructors io io.sockets io.streams.string io.files io.timeouts io.pathnames io.encodings io.encodings.string io.encodings.ascii io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf -io.streams.duplex fry ascii urls urls.encoding present +io.streams.duplex fry ascii urls urls.encoding present locals http http.parsers http.client.post-data ; IN: http.client @@ -77,12 +77,13 @@ SYMBOL: redirects : redirect? ( response -- ? ) code>> 300 399 between? ; -: do-redirect ( quot: ( chunk -- ) response -- response ) +:: do-redirect ( quot: ( chunk -- ) response -- response ) redirects inc redirects get max-redirects < [ request get clone - swap "location" header redirect-url - "GET" >>method swap (with-http-request) + response "location" header redirect-url + response code>> 307 = [ "GET" >>method ] unless + quot (with-http-request) ] [ too-many-redirects ] if ; inline recursive : read-chunk-size ( -- n ) @@ -164,7 +165,7 @@ ERROR: download-failed response ; present file-name "?" split1 drop "/" ?tail drop ; : download-to ( url file -- ) - binary [ [ write ] with-http-get drop ] with-file-writer ; + binary [ [ write ] with-http-get check-response drop ] with-file-writer ; : download ( url -- ) dup download-name download-to ; @@ -183,6 +184,12 @@ ERROR: download-failed response ; : http-put ( post-data url -- response data ) http-request ; +: ( url -- request ) + "DELETE" ; + +: http-delete ( url -- response data ) + http-request ; + USING: vocabs vocabs.loader ; "debugger" vocab [ "http.client.debugger" require ] when 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/http-tests.factor b/basis/http/http-tests.factor index bc906fad44..5c73377cbe 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -1,8 +1,8 @@ -USING: http http.server http.client http.client.private tools.test multiline -io.streams.string io.encodings.utf8 io.encodings.8-bit -io.encodings.binary io.encodings.string kernel arrays splitting -sequences assocs io.sockets db db.sqlite continuations urls -hashtables accessors namespaces xml.data ; +USING: http http.server http.client http.client.private tools.test +multiline io.streams.string io.encodings.utf8 io.encodings.8-bit +io.encodings.binary io.encodings.string io.encodings.ascii kernel +arrays splitting sequences assocs io.sockets db db.sqlite +continuations urls hashtables accessors namespaces xml.data ; IN: http.tests [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test @@ -359,4 +359,44 @@ SYMBOL: a ! Test basic auth [ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test +! Test a corner case with static responder +[ ] [ + + add-quit-action + "vocab:http/test/foo.html" >>default + test-httpd +] unit-test +[ t ] [ + "http://localhost/" add-port http-get nip + "vocab:http/test/foo.html" ascii file-contents = +] unit-test + +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test + +! Check behavior of 307 redirect (reported by Chris Double) +[ ] [ + + add-quit-action + + [ "b" ] >>submit + "a" add-responder + + [ + request get post-data>> data>> "data" = + [ "OK" "text/plain" ] [ "OOPS" throw ] if + ] >>submit + "b" add-responder + test-httpd +] unit-test + +[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test + +! Check that download throws errors (reported by Chris Double) +[ + "resource:temp" [ + "http://localhost/tweet_my_twat" add-port download + ] with-directory +] must-fail + +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test diff --git a/basis/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor index 2c8db27259..08974aca3b 100644 --- a/basis/http/server/dispatchers/dispatchers-tests.factor +++ b/basis/http/server/dispatchers/dispatchers-tests.factor @@ -3,8 +3,6 @@ tools.test kernel namespaces accessors io http math sequences assocs arrays classes words urls ; IN: http.server.dispatchers.tests -\ find-responder must-infer - TUPLE: mock-responder path ; C: mock-responder diff --git a/basis/http/server/redirection/redirection-tests.factor b/basis/http/server/redirection/redirection-tests.factor index 14855ca875..72ff111db9 100644 --- a/basis/http/server/redirection/redirection-tests.factor +++ b/basis/http/server/redirection/redirection-tests.factor @@ -2,8 +2,6 @@ IN: http.server.redirection.tests USING: http http.server.redirection urls accessors namespaces tools.test present kernel ; -\ relative-to-request must-infer - [ 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-tests.factor b/basis/http/server/server-tests.factor index 171973fcd8..3dc97098a4 100644 --- a/basis/http/server/server-tests.factor +++ b/basis/http/server/server-tests.factor @@ -4,8 +4,6 @@ IN: http.server.tests [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test -\ make-http-error must-infer - [ "text/plain; charset=UTF-8" ] [ "text/plain" >>content-type 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/http/server/static/static.factor b/basis/http/server/static/static.factor index bbca70d845..f80a3cc7cd 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -47,8 +47,8 @@ TUPLE: file-responder root hook special allow-listings ; if ; : serving-path ( filename -- filename ) - [ file-responder get root>> trim-tail-separators "/" ] dip - "" or trim-head-separators 3append ; + [ file-responder get root>> trim-tail-separators ] dip + [ "/" swap trim-head-separators 3append ] unless-empty ; : serve-file ( filename -- response ) dup mime-type diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index e154df26a1..29ba3b9b80 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -1,6 +1,7 @@ USING: images.bitmap images.viewer io.encodings.binary io.files io.files.unique kernel tools.test images.loader -literals sequences ; +literals sequences checksums.md5 checksums +images.normalization ; IN: images.bitmap.tests CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp" @@ -11,17 +12,33 @@ CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp" CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp" -[ t ] -[ - test-bitmap24 - [ binary file-contents ] [ load-image ] bi - - "test-bitmap24" unique-file - [ save-bitmap ] [ binary file-contents ] bi = -] unit-test +CONSTANT: test-40 "vocab:images/test-images/40red24bit.bmp" +CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp" +CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp" +CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp" { $ test-bitmap8 $ test-bitmap24 "vocab:ui/render/test/reference.bmp" -} [ [ ] swap [ load-image drop ] curry unit-test ] each \ No newline at end of file +} [ [ ] swap [ load-image drop ] curry unit-test ] each + + +: test-bitmap-save ( path -- ? ) + [ md5 checksum-file ] + [ load-image normalize-image ] bi + "bitmap-save-test" unique-file + [ save-bitmap ] + [ md5 checksum-file ] bi = ; + +[ + t +] [ + { + $ test-40 + $ test-41 + $ test-42 + $ test-43 + $ test-bitmap24 + } [ test-bitmap-save ] all? +] unit-test diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 8209159a8e..48095bb26b 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -37,14 +37,14 @@ M: bitmap-magic summary ERROR: bmp-not-supported n ; : reverse-lines ( byte-array width -- byte-array ) - 3 * concat ; inline + concat ; inline : raw-bitmap>seq ( loading-bitmap -- array ) dup bit-count>> { { 32 [ color-index>> ] } - { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] } - { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] } + { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] } + { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] } [ bmp-not-supported ] } case >byte-array ; @@ -81,30 +81,31 @@ ERROR: bmp-not-supported n ; : image-size ( loading-bitmap -- n ) [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ; +: bitmap-padding ( width -- n ) + 3 * 4 mod 4 swap - 4 mod ; inline + :: fixup-color-index ( loading-bitmap -- loading-bitmap ) loading-bitmap width>> :> width width 3 * :> width*3 - loading-bitmap height>> abs :> height - loading-bitmap color-index>> length :> color-index-length - color-index-length height /i :> stride - color-index-length width*3 height * - height /i :> padding + loading-bitmap width>> bitmap-padding :> padding + loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride + loading-bitmap padding 0 > [ - loading-bitmap [ + [ stride [ width*3 head-slice ] map concat ] change-color-index - ] [ - loading-bitmap - ] if ; + ] when ; : parse-bitmap ( loading-bitmap -- loading-bitmap ) dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index fixup-color-index ; -: load-bitmap-data ( path loading-bitmap -- loading-bitmap ) - [ binary ] dip '[ - _ parse-file-header parse-bitmap-header parse-bitmap +: load-bitmap-data ( path -- loading-bitmap ) + binary [ + loading-bitmap new + parse-file-header parse-bitmap-header parse-bitmap ] with-file-reader ; ERROR: unknown-component-order bitmap ; @@ -117,8 +118,7 @@ ERROR: unknown-component-order bitmap ; [ unknown-component-order ] } case ; -: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image ) - [ bitmap-image new ] dip +: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image ) { [ raw-bitmap>seq >>bitmap ] [ [ width>> ] [ height>> abs ] bi 2array >>dim ] @@ -127,20 +127,30 @@ ERROR: unknown-component-order bitmap ; } cleave ; M: bitmap-image load-image* ( path loading-bitmap -- bitmap ) - drop loading-bitmap new - load-bitmap-data - loading-bitmap>bitmap-image ; + swap load-bitmap-data loading-bitmap>bitmap-image ; PRIVATE> -: bitmap>color-index ( bitmap-array -- byte-array ) - 4 [ 3 head-slice ] map B{ } join ; inline +: bitmap>color-index ( bitmap -- byte-array ) + [ + bitmap>> + 4 + [ 3 head-slice ] map + B{ } join + ] [ + dim>> first dup bitmap-padding dup 0 > [ + [ 3 * group ] dip '[ _ append ] map + B{ } join + ] [ + 2drop + ] if + ] bi ; : save-bitmap ( image path -- ) binary [ B{ CHAR: B CHAR: M } write [ - bitmap>> bitmap>color-index length 14 + 40 + write4 + bitmap>color-index length 14 + 40 + write4 0 write4 54 write4 40 write4 @@ -159,7 +169,7 @@ PRIVATE> [ drop 0 write4 ] ! size-image - [ bitmap>> bitmap>color-index length write4 ] + [ bitmap>color-index length write4 ] ! x-pels [ drop 0 write4 ] @@ -175,7 +185,9 @@ PRIVATE> ! rgb-quads [ - [ bitmap>> bitmap>color-index ] [ dim>> first ] bi + [ bitmap>color-index ] + [ dim>> first 3 * ] + [ dim>> first bitmap-padding + ] tri reverse-lines write ] } cleave diff --git a/basis/images/images.factor b/basis/images/images.factor index b32953f67c..178b91ab52 100755 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -3,7 +3,7 @@ USING: combinators kernel accessors ; IN: images -SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR +SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ; @@ -11,6 +11,7 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ; : bytes-per-pixel ( component-order -- n ) { { L [ 1 ] } + { LA [ 2 ] } { BGR [ 3 ] } { RGB [ 3 ] } { BGRA [ 4 ] } @@ -33,4 +34,4 @@ TUPLE: image dim component-order upside-down? bitmap ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ; -GENERIC: load-image* ( path tuple -- image ) \ No newline at end of file +GENERIC: load-image* ( path tuple -- image ) diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index b8bafc021f..fe33cc8f00 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images images.normalization -io.pathnames ; +accessors images.bitmap images.tiff images io.pathnames ; IN: images.loader ERROR: unknown-image-extension extension ; @@ -16,4 +15,4 @@ ERROR: unknown-image-extension extension ; } case ; : load-image ( path -- image ) - dup image-class new load-image* normalize-image ; + dup image-class new load-image* ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 80eaff8140..6bf1ea2ff1 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -463,6 +463,7 @@ ERROR: unknown-component-order ifd ; { { 16 16 16 } [ 2 seq>native-endianness ] } { { 8 8 8 8 } [ ] } { { 8 8 8 } [ ] } + { 8 [ ] } [ unknown-component-order ] } case >>bitmap ; @@ -474,11 +475,11 @@ ERROR: unknown-component-order ifd ; { { 16 16 16 } [ R16G16B16 ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } + { 8 [ LA ] } [ unknown-component-order ] } case ; : normalize-alpha-data ( seq -- byte-array ) - ! [ normalize-alpha-data ] change-bitmap B{ } like dup byte-array>float-array 4 diff --git a/basis/interpolate/tags.txt b/basis/interpolate/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/basis/interpolate/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/basis/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor index 9d81992eae..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 @@ -83,3 +85,12 @@ C: nil [ [ sqrt ] ] [ [ sq ] [undo] ] unit-test [ [ not ] ] [ [ not ] [undo] ] unit-test [ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test + +TUPLE: funny-tuple ; +: ( -- funny-tuple ) \ funny-tuple boa ; +: funny-tuple ( -- ) "OOPS" throw ; + +[ ] [ [ ] [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 ; M: fail summary drop "Matching failed" ; -: assure ( ? -- ) [ fail ] unless ; +: assure ( ? -- ) [ fail ] unless ; inline -: =/fail ( obj1 obj2 -- ) = assure ; +: =/fail ( obj1 obj2 -- ) = assure ; inline ! Inverse of a quotation @@ -74,7 +74,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; : fold-word ( stack word -- stack ) 2dup enough? - [ 1quotation with-datastack ] [ [ % ] [ , ] bi* { } ] if ; + [ 1quotation with-datastack ] + [ [ [ literalize , ] each ] [ , ] bi* { } ] + if ; : fold ( quot -- folded-quot ) [ { } [ fold-word ] reduce % ] [ ] make ; @@ -141,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 @@ -171,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? } @@ -192,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 @@ -212,14 +225,18 @@ 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 ; : slot-readers ( class -- quot ) - all-slots - [ name>> reader-word 1quotation [ keep ] curry ] map concat - [ ] like [ drop ] compose ; + all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ; : ?wrapped ( object -- wrapped ) dup wrapper? [ wrapped>> ] when ; @@ -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/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/buffers/buffers.factor b/basis/io/buffers/buffers.factor index 4df081b17d..49b5357d98 100644 --- a/basis/io/buffers/buffers.factor +++ b/basis/io/buffers/buffers.factor @@ -22,7 +22,7 @@ M: buffer dispose* ptr>> free ; swap >>fill 0 >>pos drop ; : buffer-capacity ( buffer -- n ) - [ size>> ] [ fill>> ] bi - ; inline + [ size>> ] [ fill>> ] bi - >fixnum ; inline : buffer-empty? ( buffer -- ? ) fill>> zero? ; inline diff --git a/basis/io/crlf/crlf-tests.factor b/basis/io/crlf/crlf-tests.factor new file mode 100644 index 0000000000..2412945ab3 --- /dev/null +++ b/basis/io/crlf/crlf-tests.factor @@ -0,0 +1,8 @@ +IN: io.crlf.tests +USING: io.crlf tools.test io.streams.string io ; + +[ "Hello, world." ] [ "Hello, world." [ read-crlf ] with-string-reader ] unit-test +[ "Hello, world." ] [ "Hello, world.\r\n" [ read-crlf ] with-string-reader ] unit-test +[ "Hello, world.\r" [ read-crlf ] with-string-reader ] must-fail +[ f ] [ "" [ read-crlf ] with-string-reader ] unit-test +[ "" ] [ "\r\n" [ read-crlf ] with-string-reader ] unit-test diff --git a/basis/io/crlf/crlf.factor b/basis/io/crlf/crlf.factor index 53dddce199..29f10300de 100644 --- a/basis/io/crlf/crlf.factor +++ b/basis/io/crlf/crlf.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel ; +USING: io kernel sequences ; IN: io.crlf : crlf ( -- ) @@ -8,4 +8,4 @@ IN: io.crlf : read-crlf ( -- seq ) "\r" read-until - [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; + [ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ; diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index 818899606d..a6c82a1bff 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -15,13 +15,20 @@ HELP: each-file } } ; -HELP: recursive-directory +HELP: recursive-directory-files { $values { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "paths" "a sequence of pathname strings" } } { $description "Traverses a directory path recursively and returns a sequence of files in a breadth-first or depth-first manner." } ; +HELP: recursive-directory-entries +{ $values + { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } + { "directory-entries" "a sequence of directory-entries" } +} +{ $description "Traverses a directory path recursively and returns a sequence of directory-entries in a breadth-first or depth-first manner." } ; + HELP: find-file { $values { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation } @@ -41,11 +48,11 @@ HELP: find-all-files { "path" "a pathname string" } { "quot" quotation } { "paths/f" "a sequence of pathname strings or f" } } -{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ; +{ $description "Recursively finds all files in the input directory matching the predicate quotation." } ; HELP: find-all-in-directories { $values - { "directories" "a sequence of directory paths" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation } + { "directories" "a sequence of directory paths" } { "quot" quotation } { "paths/f" "a sequence of pathname strings or f" } } { $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ; @@ -55,7 +62,8 @@ HELP: find-all-in-directories ARTICLE: "io.directories.search" "Searching directories" "The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl "Traversing directories:" -{ $subsection recursive-directory } +{ $subsection recursive-directory-files } +{ $subsection recursive-directory-entries } { $subsection each-file } "Finding files:" { $subsection find-file } diff --git a/basis/io/directories/search/search-tests.factor b/basis/io/directories/search/search-tests.factor index 5281ca9c2b..db4b58c4fd 100644 --- a/basis/io/directories/search/search-tests.factor +++ b/basis/io/directories/search/search-tests.factor @@ -1,12 +1,14 @@ -USING: io.directories.search io.files io.files.unique -io.pathnames kernel namespaces sequences sorting tools.test ; +USING: combinators.smart io.directories +io.directories.hierarchy io.directories.search io.files +io.files.unique io.pathnames kernel namespaces sequences +sorting strings tools.test ; IN: io.directories.search.tests [ t ] [ [ 10 [ "io.paths.test" "gogogo" make-unique-file ] replicate current-temporary-directory get [ ] find-all-files - ] with-unique-directory drop [ natural-sort ] bi@ = + ] cleanup-unique-directory [ natural-sort ] bi@ = ] unit-test [ f ] [ @@ -18,3 +20,18 @@ IN: io.directories.search.tests [ f ] [ { } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories ] unit-test + +[ t ] [ + [ + current-temporary-directory get + "the-head" unique-file drop t + [ file-name "the-head" head? ] find-file string? + ] cleanup-unique-directory +] unit-test + +[ t ] [ + [ unique-directory unique-directory ] output>array + [ [ "abcd" append-path touch-file ] each ] + [ [ file-name "abcd" = ] find-all-in-directories length 2 = ] + [ [ delete-tree ] each ] tri +] unit-test diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 6db83ebca6..f7d18306f8 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -2,72 +2,108 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays continuations deques dlists fry io.directories io.files io.files.info io.pathnames kernel -sequences system vocabs.loader ; +sequences system vocabs.loader locals math namespaces +sorting assocs calendar threads io math.parser ; IN: io.directories.search +: qualified-directory-entries ( path -- seq ) + dup directory-entries + [ [ append-path ] change-name ] with map ; + +: qualified-directory-files ( path -- seq ) + dup directory-files [ append-path ] with map ; + +: with-qualified-directory-files ( path quot -- ) + '[ "" qualified-directory-files @ ] with-directory ; inline + +: with-qualified-directory-entries ( path quot -- ) + '[ "" qualified-directory-entries @ ] with-directory ; inline + > ] [ bfs>> ] bi +: push-directory-entries ( path iter -- ) + [ [ qualified-directory-entries ] [ 2drop f ] recover ] dip '[ + _ [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if - ] curry each ; + ] each ; : ( path bfs? -- iterator ) directory-iterator boa - dup path>> over push-directory ; + dup path>> over push-directory-entries ; -: next-file ( iter -- file/f ) +: next-directory-entry ( iter -- directory-entry/f ) dup queue>> deque-empty? [ drop f ] [ - dup queue>> pop-back dup link-info directory? - [ over push-directory next-file ] [ nip ] if + dup queue>> pop-back + dup directory? + [ name>> over push-directory-entries next-directory-entry ] + [ nip ] if ] if ; -: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) - over next-file [ - over call - [ 2nip ] [ iterate-directory ] if* +:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f ) + iter next-directory-entry [ + quot call + [ iter quot iterate-directory-entries ] unless* ] [ - 2drop f + f ] if* ; inline recursive +: iterate-directory ( iter quot -- path/f ) + [ name>> ] prepose iterate-directory-entries ; inline + +: setup-traversal ( path bfs quot -- iterator quot' ) + [ ] dip [ f ] compose ; inline + PRIVATE> -: each-file ( path bfs? quot: ( obj -- ) -- ) +: each-file ( path bfs? quot -- ) + setup-traversal iterate-directory drop ; inline + +: each-directory-entry ( path bfs? quot -- ) + setup-traversal iterate-directory-entries drop ; inline + +: recursive-directory-files ( path bfs? -- paths ) + [ ] accumulator [ each-file ] dip ; inline + +: recursive-directory-entries ( path bfs? -- directory-entries ) + [ ] accumulator [ each-directory-entry ] dip ; inline + +: find-file ( path bfs? quot -- path/f ) [ ] dip - [ f ] compose iterate-directory drop ; inline + [ keep and ] curry iterate-directory ; inline -: recursive-directory ( path bfs? -- paths ) - [ ] accumulator [ each-file ] dip ; +: find-all-files ( path quot -- paths/f ) + [ f ] dip pusher + [ [ f ] compose iterate-directory drop ] dip ; inline -: find-file ( path bfs? quot: ( obj -- ? ) -- path/f ) - '[ - _ _ _ [ ] dip - [ keep and ] curry iterate-directory - ] [ drop f ] recover ; inline +ERROR: file-not-found path bfs? quot ; -: find-all-files ( path quot: ( obj -- ? ) -- paths/f ) - f swap - '[ - _ _ _ [ ] dip - pusher [ [ f ] compose iterate-directory drop ] dip - ] [ drop f ] recover ; inline +: find-file-throws ( path bfs? quot -- path ) + 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline -ERROR: file-not-found ; +: find-in-directories ( directories bfs? quot -- path'/f ) + '[ _ [ _ _ find-file-throws ] attempt-all ] + [ drop f ] recover ; inline -: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f ) - '[ - _ [ _ _ find-file [ file-not-found ] unless* ] attempt-all - ] [ - drop f - ] recover ; inline +: find-all-in-directories ( directories quot -- paths/f ) + '[ _ find-all-files ] map concat ; inline -: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f ) - '[ _ _ find-all-files ] map concat ; inline +: link-size/0 ( path -- n ) + [ link-info size-on-disk>> ] [ 2drop 0 ] recover ; + +: directory-size ( path -- n ) + 0 swap t [ link-size/0 + ] each-file ; + +: path>usage ( directory-entry -- name size ) + [ name>> dup ] [ directory? ] bi + [ directory-size ] [ link-size/0 ] if ; + +: directory-usage ( path -- assoc ) + [ + [ + [ path>usage ] [ drop name>> 0 ] recover + ] { } map>assoc + ] with-qualified-directory-entries sort-values ; os windows? [ "io.directories.search.windows" require ] when diff --git a/basis/io/encodings/8-bit/8-bit-tests.factor b/basis/io/encodings/8-bit/8-bit-tests.factor index 8b18e2a9af..55b9c44934 100644 --- a/basis/io/encodings/8-bit/8-bit-tests.factor +++ b/basis/io/encodings/8-bit/8-bit-tests.factor @@ -4,11 +4,11 @@ IN: io.encodings.8-bit.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test [ { 256 } >string latin1 encode ] must-fail -[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test +[ B{ 255 } ] [ { 255 } >string latin1 encode ] unit-test [ "bar" ] [ "bar" latin1 decode ] unit-test -[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test -[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test +[ { CHAR: b 233 CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test +[ { HEX: fffd HEX: 20AC } ] [ B{ HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test [ t ] [ \ latin1 8-bit-encoding? ] unit-test [ "bar" ] [ "bar" \ latin1 decode ] unit-test diff --git a/basis/io/encodings/ascii/ascii-tests.factor b/basis/io/encodings/ascii/ascii-tests.factor index 4f6d28835a..fcd549d31f 100644 --- a/basis/io/encodings/ascii/ascii-tests.factor +++ b/basis/io/encodings/ascii/ascii-tests.factor @@ -3,7 +3,7 @@ IN: io.encodings.ascii.tests [ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test [ { 128 } >string ascii encode ] must-fail -[ B{ 127 } ] [ { 127 } ascii encode ] unit-test +[ B{ 127 } ] [ { 127 } >string ascii encode ] unit-test [ "bar" ] [ "bar" ascii decode ] unit-test -[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test +[ { CHAR: b HEX: fffd CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } ascii decode >array ] unit-test diff --git a/basis/io/encodings/gb18030/gb18030-tests.factor b/basis/io/encodings/gb18030/gb18030-tests.factor index 20ea522a4d..da44d1cf9a 100644 --- a/basis/io/encodings/gb18030/gb18030-tests.factor +++ b/basis/io/encodings/gb18030/gb18030-tests.factor @@ -6,7 +6,7 @@ IN: io.encodings.gb18030.tests [ "hello" ] [ "hello" gb18030 encode >string ] unit-test [ "hello" ] [ "hello" gb18030 decode ] unit-test [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } ] -[ B{ HEX: B7 HEX: B8 } gb18030 encode ] unit-test +[ B{ HEX: B7 HEX: B8 } >string gb18030 encode ] unit-test [ { HEX: B7 HEX: B8 } ] [ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } gb18030 decode >array ] unit-test [ { HEX: B7 CHAR: replacement-character } ] @@ -18,9 +18,9 @@ IN: io.encodings.gb18030.tests [ { HEX: B7 } ] [ B{ HEX: A1 HEX: A4 } gb18030 decode >array ] unit-test [ { CHAR: replacement-character } ] -[ B{ HEX: A1 } gb18030 decode >array ] unit-test +[ B{ HEX: A1 } >string gb18030 decode >array ] unit-test [ { HEX: 44D7 HEX: 464B } ] [ B{ HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } gb18030 decode >array ] unit-test [ { HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } ] -[ { HEX: 44D7 HEX: 464B } gb18030 encode >array ] unit-test +[ { HEX: 44D7 HEX: 464B } >string gb18030 encode >array ] unit-test 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/encodings/utf16/utf16-tests.factor b/basis/io/encodings/utf16/utf16-tests.factor deleted file mode 100644 index 230612cc77..0000000000 --- a/basis/io/encodings/utf16/utf16-tests.factor +++ /dev/null @@ -1,25 +0,0 @@ -! Copyright (C) 2008 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test io.encodings.utf16 arrays sbufs -io.streams.byte-array sequences io.encodings io -io.encodings.string alien.c-types alien.strings accessors classes ; -IN: io.encodings.utf16.tests - -[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test -[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test - -[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test - -[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test - -[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test - -[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test -[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test - -[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test diff --git a/basis/io/encodings/utf32/utf32-tests.factor b/basis/io/encodings/utf32/utf32-tests.factor index be1111e242..2a80e47c7b 100644 --- a/basis/io/encodings/utf32/utf32-tests.factor +++ b/basis/io/encodings/utf32/utf32-tests.factor @@ -1,30 +1,30 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel tools.test io.encodings.utf32 arrays sbufs -io.streams.byte-array sequences io.encodings io +io.streams.byte-array sequences io.encodings io strings io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf32.tests -[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test -[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 0 0 CHAR: x } utf32be decode >array ] unit-test +[ { HEX: 1D11E } ] [ B{ 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 1 HEX: D1 } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 1 } utf32be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ 0 } utf32be decode >array ] unit-test [ { } ] [ { } utf32be decode >array ] unit-test -[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test +[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } >string utf32be encode >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test -[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test -[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test +[ { CHAR: x } ] [ B{ CHAR: x 0 0 0 } utf32le decode >array ] unit-test +[ { HEX: 1d11e } ] [ B{ HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 } utf32le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ HEX: 1e } utf32le decode >array ] unit-test [ { } ] [ { } utf32le decode >array ] unit-test -[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test +[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32le encode >array ] unit-test -[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test -[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test +[ { CHAR: x } ] [ B{ 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test -[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test +[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32 encode >array ] unit-test diff --git a/basis/io/files/info/info-tests.factor b/basis/io/files/info/info-tests.factor index b94bc0635c..7b19f56b10 100644 --- a/basis/io/files/info/info-tests.factor +++ b/basis/io/files/info/info-tests.factor @@ -3,9 +3,6 @@ io.directories kernel io.pathnames accessors tools.test sequences io.files.temp ; IN: io.files.info.tests -\ file-info must-infer -\ link-info must-infer - [ t ] [ temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory temp-directory "test41" append-path utf8 file-contents "hi41" = diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index fd21850612..5c5d2c93d2 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -5,7 +5,7 @@ vocabs.loader io.files.types ; IN: io.files.info ! File info -TUPLE: file-info type size permissions created modified +TUPLE: file-info type size size-on-disk permissions created modified accessed ; HOOK: file-info os ( path -- info ) @@ -25,4 +25,4 @@ HOOK: file-system-info os ( path -- file-system-info ) { { [ os unix? ] [ "io.files.info.unix." os name>> append ] } { [ os windows? ] [ "io.files.info.windows" ] } -} cond require \ No newline at end of file +} cond require diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 616f70cccc..80f4b74ac8 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -63,6 +63,8 @@ M: unix link-info ( path -- info ) M: unix new-file-info ( -- class ) unix-file-info new ; +CONSTANT: standard-unix-block-size 512 + M: unix stat>file-info ( stat -- file-info ) [ new-file-info ] dip { @@ -80,6 +82,7 @@ M: unix stat>file-info ( stat -- file-info ) [ stat-st_rdev >>rdev ] [ stat-st_blocks >>blocks ] [ stat-st_blksize >>blocksize ] + [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ] } cleave ; : n>file-type ( n -- type ) diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index fdff368491..81e43f8dd9 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -5,11 +5,33 @@ io.files.windows io.files.windows.nt kernel windows.kernel32 windows.time windows accessors alien.c-types combinators generalizations system alien.strings io.encodings.utf16n sequences splitting windows.errors fry continuations destructors -calendar ascii combinators.short-circuit ; +calendar ascii combinators.short-circuit locals ; IN: io.files.info.windows +:: round-up-to ( n multiple -- n' ) + n multiple rem dup 0 = [ + drop n + ] [ + multiple swap - n + + ] if ; + TUPLE: windows-file-info < file-info attributes ; +: get-compressed-file-size ( path -- n ) + "DWORD" [ GetCompressedFileSize ] keep + over INVALID_FILE_SIZE = [ + win32-error-string throw + ] [ + *uint >64bit + ] if ; + +: set-windows-size-on-disk ( file-info path -- file-info ) + over attributes>> +compressed+ swap member? [ + get-compressed-file-size + ] [ + drop dup size>> 4096 round-up-to + ] if >>size-on-disk ; + : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) [ \ windows-file-info new ] dip { @@ -79,7 +101,9 @@ TUPLE: windows-file-info < file-info attributes ; ] if ; M: windows file-info ( path -- info ) - normalize-path get-file-information-stat ; + normalize-path + [ get-file-information-stat ] + [ set-windows-size-on-disk ] bi ; M: windows link-info ( path -- info ) file-info ; 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-docs.factor b/basis/io/files/unique/unique-docs.factor index 74fc045032..6a7be47813 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -62,8 +62,8 @@ HELP: current-temporary-directory HELP: unique-file { $values + { "prefix" string } { "path" "a pathname string" } - { "path'" "a pathname string" } } { $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ; diff --git a/basis/io/files/unique/unique-tests.factor b/basis/io/files/unique/unique-tests.factor index fd8cf2c69f..53a77907cf 100644 --- a/basis/io/files/unique/unique-tests.factor +++ b/basis/io/files/unique/unique-tests.factor @@ -5,7 +5,7 @@ IN: io.files.unique.tests [ 123 ] [ "core" ".test" [ - [ [ 123 CHAR: a ] dip ascii set-file-contents ] + [ [ 123 CHAR: a ] dip ascii set-file-contents ] [ file-info size>> ] bi ] cleanup-unique-file ] unit-test diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 7bd96aa63b..0e4338e3e0 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -64,7 +64,7 @@ PRIVATE> [ unique-directory ] dip '[ _ with-temporary-directory ] [ delete-tree ] bi ; inline -: unique-file ( path -- path' ) +: unique-file ( prefix -- path ) "" make-unique-file ; { diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index 9e449982fb..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 ; +namespaces make accessors tr windows.time windows.shell32 +windows.errors ; IN: io.files.windows.nt M: winnt cwd @@ -58,4 +59,9 @@ M: winnt open-append [ dup windows-file-size ] [ drop 0 ] recover [ (open-append) ] dip >>ptr ; -M: winnt home "USERPROFILE" os-env ; +M: winnt home + { + [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ] + [ "USERPROFILE" os-env ] + [ my-documents ] + } 0|| ; diff --git a/basis/io/launcher/launcher-docs.factor b/basis/io/launcher/launcher-docs.factor index 3585214735..f20e65dc27 100644 --- a/basis/io/launcher/launcher-docs.factor +++ b/basis/io/launcher/launcher-docs.factor @@ -140,7 +140,46 @@ HELP: { "desc" "a launch descriptor" } { "encoding" "an encoding descriptor" } { "stream" "a bidirectional stream" } } -{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ; +{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream with the given encoding." } ; + +HELP: +{ $values + { "desc" "a launch descriptor" } + { "encoding" "an encoding descriptor" } + { "stream" "an input stream" } } +{ $description "Launches a process and redirects its output via a pipe which may be read as a stream with the given encoding." } ; + +HELP: +{ $values + { "desc" "a launch descriptor" } + { "encoding" "an encoding descriptor" } + { "stream" "an output stream" } +} +{ $description "Launches a process and redirects its input via a pipe which may be written to as a stream with the given encoding." } ; + +HELP: with-process-stream +{ $values + { "desc" "a launch descriptor" } + { "encoding" "an encoding descriptor" } + { "quot" quotation } +} +{ $description "Launches a process and redirects its input and output via a pair of pipes. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to these pipes." } ; + +HELP: with-process-reader +{ $values + { "desc" "a launch descriptor" } + { "encoding" "an encoding descriptor" } + { "quot" quotation } +} +{ $description "Launches a process and redirects its output via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ; + +HELP: with-process-writer +{ $values + { "desc" "a launch descriptor" } + { "encoding" "an encoding descriptor" } + { "quot" quotation } +} +{ $description "Launches a process and redirects its input via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ; HELP: wait-for-process { $values { "process" process } { "status" object } } @@ -175,7 +214,11 @@ ARTICLE: "io.launcher.launch" "Launching processes" "Redirecting standard input and output to a pipe:" { $subsection } { $subsection } -{ $subsection } ; +{ $subsection } +"Combinators built on top of the above:" +{ $subsection with-process-reader } +{ $subsection with-process-writer } +{ $subsection with-process-stream } ; ARTICLE: "io.launcher.examples" "Launcher examples" "Starting a command and waiting for it to finish:" diff --git a/basis/io/launcher/launcher-tests.factor b/basis/io/launcher/launcher-tests.factor index 003f382020..da7284dbe5 100644 --- a/basis/io/launcher/launcher-tests.factor +++ b/basis/io/launcher/launcher-tests.factor @@ -1,6 +1,3 @@ IN: io.launcher.tests USING: tools.test io.launcher ; -\ must-infer -\ must-infer -\ must-infer 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/parser/parser-tests.factor b/basis/io/launcher/unix/parser/parser-tests.factor index 07502e87a4..90504ccac2 100644 --- a/basis/io/launcher/unix/parser/parser-tests.factor +++ b/basis/io/launcher/unix/parser/parser-tests.factor @@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ; [ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test [ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test [ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test -[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] must-fail -[ "'abc def" tokenize-command ] must-fail -[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test +[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test +[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test +[ "\"abc def\" \"hey" tokenize-command ] must-fail +[ "\"abc def" tokenize-command ] must-fail +[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test [ V{ diff --git a/basis/io/launcher/unix/parser/parser.factor b/basis/io/launcher/unix/parser/parser.factor index 97e6dee95f..bcc5f965e9 100644 --- a/basis/io/launcher/unix/parser/parser.factor +++ b/basis/io/launcher/unix/parser/parser.factor @@ -1,33 +1,17 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: peg peg.parsers kernel sequences strings words ; +USING: peg peg.ebnf arrays sequences strings kernel ; IN: io.launcher.unix.parser ! Our command line parser. Supported syntax: ! foo bar baz -- simple tokens ! foo\ bar -- escaping the space -! 'foo bar' -- quotation ! "foo bar" -- quotation -: 'escaped-char' ( -- parser ) - "\\" token any-char 2seq [ second ] action ; - -: 'quoted-char' ( delimiter -- parser' ) - 'escaped-char' - swap [ member? not ] curry satisfy - 2choice ; inline - -: 'quoted' ( delimiter -- parser ) - dup 'quoted-char' repeat0 swap dup surrounded-by ; - -: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; - -: 'argument' ( -- parser ) - "\"" 'quoted' - "'" 'quoted' - 'unquoted' 3choice - [ >string ] action ; - -PEG: tokenize-command ( command -- ast/f ) - 'argument' " " token repeat1 list-of - " " token repeat0 tuck pack - just ; +EBNF: tokenize-command +space = " " +escaped-char = "\" .:ch => [[ ch ]] +quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]] +unquoted = (escaped-char | [^ "])+ +argument = (quoted | unquoted) => [[ >string ]] +command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]] +;EBNF diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index f375bb41e8..99d45e4fd7 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 [ ] [ @@ -52,7 +52,7 @@ concurrency.promises threads unix.process ; "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 04202365fd..53b3d3ce7e 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests +replace-environment+ >>environment-mode os-envs >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "A" swap at ] unit-test @@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = ] unit-test diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor index 21b3d294c9..a80ce3bc82 100644 --- a/basis/io/mmap/functor/functor.factor +++ b/basis/io/mmap/functor/functor.factor @@ -9,13 +9,14 @@ SLOT: length : mapped-file>direct ( mapped-file type -- alien length ) [ [ address>> ] [ length>> ] bi ] dip - heap-size [ 1- + ] keep /i ; + heap-size [ 1 - + ] keep /i ; FUNCTOR: define-mapped-array ( T -- ) - DEFINES - IS -with-mapped-A-file DEFINES with-mapped-${T}-file + DEFINES + IS +with-mapped-A-file DEFINES with-mapped-${T}-file +with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader WHERE @@ -25,4 +26,7 @@ WHERE : with-mapped-A-file ( path quot -- ) '[ @ ] with-mapped-file ; inline +: with-mapped-A-file-reader ( path quot -- ) + '[ @ ] with-mapped-file-reader ; inline + ;FUNCTOR diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index 5ef3400a6d..1da82e42e2 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -18,7 +18,13 @@ HELP: HELP: with-mapped-file { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } -{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } +{ $errors "Throws an error if a memory mapping could not be established." } ; + +HELP: with-mapped-file-reader +{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } +{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } { $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; @@ -54,11 +60,20 @@ ARTICLE: "io.mmap.arrays" "Memory-mapped arrays" ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly" "Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ; +ARTICLE: "io.mmap.examples" "Memory-mapped file example" +"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" +{ $code + "USING: accessors grouping io.files io.mmap.char kernel sequences ;" + "\"mydata.dat\" [" + " 4 [ reverse-here ] change-each" + "] with-mapped-char-file" +} ; + ARTICLE: "io.mmap" "Memory-mapped files" "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files." { $subsection } "Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." -$nl +{ $subsection "io.mmap.examples" } "A utility combinator which wraps the above:" { $subsection with-mapped-file } "Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:" diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index a4d55f3c1e..0e1cd1a036 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -7,6 +7,7 @@ IN: io.mmap.tests [ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test [ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test [ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 1a58471514..e03d5fb30b 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -8,14 +8,27 @@ IN: io.mmap TUPLE: mapped-file address handle length disposed ; -HOOK: (mapped-file) os ( path length -- address handle ) +HOOK: (mapped-file-reader) os ( path length -- address handle ) +HOOK: (mapped-file-r/w) os ( path length -- address handle ) ERROR: bad-mmap-size path size ; -: ( path -- mmap ) +> ] bi - dup 0 <= [ bad-mmap-size ] when - [ (mapped-file) ] keep + dup 0 <= [ bad-mmap-size ] when ; + +PRIVATE> + +: ( path -- mmap ) + prepare-mapped-file + [ (mapped-file-reader) ] keep + f mapped-file boa ; + +: ( path -- mmap ) + prepare-mapped-file + [ (mapped-file-r/w) ] keep f mapped-file boa ; HOOK: close-mapped-file io-backend ( mmap -- ) @@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ; : with-mapped-file ( path quot -- ) [ ] dip with-disposal ; inline +: with-mapped-file-reader ( path quot -- ) + [ ] dip with-disposal ; inline + { { [ os unix? ] [ "io.mmap.unix" require ] } { [ os winnt? ] [ "io.mmap.windows" require ] } diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 0fa8e1151f..7d12d52361 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -4,21 +4,23 @@ USING: alien io io.files kernel math math.bitwise system unix io.backend.unix io.ports io.mmap destructors locals accessors ; IN: io.mmap.unix -: open-r/w ( path -- fd ) O_RDWR file-mode open-file ; - -:: mmap-open ( path length prot flags -- alien fd ) +:: mmap-open ( path length prot flags open-mode -- alien fd ) [ f length prot flags - path open-r/w [ |dispose drop ] keep + path open-mode file-mode open-file [ |dispose drop ] keep [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep ] with-destructors ; -M: unix (mapped-file) +M: unix (mapped-file-r/w) { PROT_READ PROT_WRITE } flags { MAP_FILE MAP_SHARED } flags - mmap-open ; + O_RDWR mmap-open ; + +M: unix (mapped-file-reader) + { PROT_READ } flags + { MAP_FILE MAP_SHARED } flags + O_RDONLY mmap-open ; M: unix close-mapped-file ( mmap -- ) [ [ address>> ] [ length>> ] bi munmap io-error ] - [ handle>> close-file ] - bi ; + [ handle>> close-file ] bi ; diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index fcdf416511..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 @@ -28,7 +28,7 @@ M: win32-mapped-file dispose C: win32-mapped-file -M: windows (mapped-file) +M: windows (mapped-file-r/w) [ { GENERIC_WRITE GENERIC_READ } flags OPEN_ALWAYS @@ -37,6 +37,15 @@ M: windows (mapped-file) -rot ] with-destructors ; +M: windows (mapped-file-reader) + [ + GENERIC_READ + OPEN_ALWAYS + { PAGE_READONLY SEC_COMMIT } flags + FILE_MAP_READ mmap-open + -rot + ] with-destructors ; + M: windows close-mapped-file ( mapped-file -- ) [ [ handle>> &dispose drop ] diff --git a/basis/io/monitors/recursive/recursive-tests.factor b/basis/io/monitors/recursive/recursive-tests.factor index ace93ace44..db8e02ae73 100644 --- a/basis/io/monitors/recursive/recursive-tests.factor +++ b/basis/io/monitors/recursive/recursive-tests.factor @@ -4,8 +4,6 @@ concurrency.mailboxes tools.test destructors io.files.info io.pathnames io.files.temp io.directories.hierarchy ; IN: io.monitors.recursive.tests -\ pump-thread must-infer - SINGLETON: mock-io-backend TUPLE: counter i ; diff --git a/basis/io/monitors/windows/nt/nt-tests.factor b/basis/io/monitors/windows/nt/nt-tests.factor index 79cd7e9e9f..a7ee649400 100644 --- a/basis/io/monitors/windows/nt/nt-tests.factor +++ b/basis/io/monitors/windows/nt/nt-tests.factor @@ -1,4 +1,4 @@ IN: io.monitors.windows.nt.tests USING: io.monitors.windows.nt tools.test ; -\ fill-queue-thread must-infer + 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/ports/ports.factor b/basis/io/ports/ports.factor index 569366d4b8..b2d71fd535 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -189,4 +189,4 @@ HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } HINTS: decoder-readln { input-port utf8 } { input-port ascii } ; -HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ; +HINTS: encoder-write { object output-port utf8 } { object output-port ascii } ; 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 a3bfacc8a8..f87ad93fbd 100644 --- a/basis/io/sockets/secure/unix/unix-tests.factor +++ b/basis/io/sockets/secure/unix/unix-tests.factor @@ -5,7 +5,6 @@ io.backend.unix classes words destructors threads tools.test concurrency.promises byte-arrays locals calendar io.timeouts io.sockets.secure.unix.debug ; -\ must-infer { 1 0 } [ [ ] with-secure-context ] must-infer-as [ ] [ "port" set ] unit-test @@ -24,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/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index a66ed1d0c0..970aa34ea6 100644 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -56,12 +56,23 @@ $nl } "The " { $link inet } " address specifier is not supported by the " { $link send } " word because a single host name can resolve to any number of IPv4 or IPv6 addresses, therefore there is no way to know which address should be used. Applications should call " { $link resolve-host } " then use some kind of strategy to pick the correct address (for example, by sending a packet to each one and waiting for a response, or always assuming IPv4)." ; +ARTICLE: "network-examples" "Networking examples" +"Send some bytes to a remote host:" +{ $code + "USING: io io.encodings.ascii io.sockets strings ;" + "\"myhost\" 1033 ascii" + "[ B{ 12 17 102 } write ] with-client" +} +"Look up the IP addresses associated with a host name:" +{ $code "USING: io.sockets ;" "\"www.apple.com\" 80 resolve-host ." } ; + ARTICLE: "network-streams" "Networking" "Factor supports connection-oriented and packet-oriented communication over a variety of protocols:" { $list "TCP/IP and UDP/IP, over IPv4 and IPv6" "Unix domain sockets (Unix only)" } +{ $subsection "network-examples" } { $subsection "network-addressing" } { $subsection "network-connection" } { $subsection "network-packet" } diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 8dce527553..a0beb1f421 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local ) ] with-destructors ; : ( remote encoding -- stream local ) - [ (client) -rot ] dip swap ; + [ (client) ] dip swap [ ] dip ; SYMBOL: local-address diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index 36c257fb5e..86d652d17c 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -76,3 +76,9 @@ IN: io.streams.limited.tests [ decoder? ] both? ] with-destructors ] unit-test + +[ "HELL" ] [ + "HELLO" + [ f stream-throws limit-input 4 read ] + with-string-reader +] unit-test \ No newline at end of file diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index fe3dd9ad93..b1b07a08c0 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -22,7 +22,7 @@ M: decoder limit ( stream limit mode -- stream' ) [ clone ] 2dip '[ _ _ limit ] change-stream ; M: object limit ( stream limit mode -- stream' ) - ; + over [ ] [ 2drop ] if ; GENERIC: unlimited ( stream -- stream' ) @@ -32,9 +32,11 @@ M: decoder unlimited ( stream -- stream' ) M: object unlimited ( stream -- stream' ) stream>> stream>> ; -: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ; +: limit-input ( limit mode -- ) + [ input-stream ] 2dip '[ _ _ limit ] change ; -: unlimited-input ( -- ) input-stream [ unlimited ] change ; +: unlimited-input ( -- ) + input-stream [ unlimited ] change ; : with-unlimited-stream ( stream quot -- ) [ clone unlimited ] dip call ; inline diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor index a0087a70ee..85cb3022f5 100644 --- a/basis/io/streams/string/string.factor +++ b/basis/io/streams/string/string.factor @@ -33,5 +33,6 @@ M: sbuf stream-element-type drop +character+ ; 512 ; : with-string-writer ( quot -- str ) - swap [ output-stream get ] compose with-output-stream* - >string ; inline \ No newline at end of file + [ + swap with-output-stream* + ] keep >string ; inline \ No newline at end of file diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor old mode 100644 new mode 100755 index ed45d5ccb9..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 ; @@ -274,7 +274,7 @@ HELP: { $description "Creates a new " { $link input } "." } ; HELP: standard-table-style -{ $values { "style" hashtable } } +{ $values { "value" hashtable } } { $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ; ARTICLE: "io.streams.plain" "Plain writer streams" diff --git a/basis/io/styles/styles-tests.factor b/basis/io/styles/styles-tests.factor index 86c3681c2a..0259e4ab0b 100644 --- a/basis/io/styles/styles-tests.factor +++ b/basis/io/styles/styles-tests.factor @@ -1,8 +1,2 @@ IN: io.styles.tests USING: io.styles tools.test ; - -\ stream-format must-infer -\ stream-write-table must-infer -\ make-span-stream must-infer -\ make-block-stream must-infer -\ make-cell-stream must-infer \ No newline at end of file diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index 89fe90b568..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 ; @@ -135,11 +139,11 @@ SYMBOL: wrap-margin SYMBOL: table-gap SYMBOL: table-border -: standard-table-style ( -- style ) +CONSTANT: standard-table-style H{ { table-gap { 5 5 } } { table-border T{ rgba f 0.8 0.8 0.8 1.0 } } - } ; + } ! Input history TUPLE: input string ; @@ -156,3 +160,5 @@ M: input summary ] "" make ; : write-object ( str obj -- ) presented associate format ; + +: write-image ( image -- ) [ "" ] dip image associate format ; 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/basis/lcs/lcs-tests.factor b/basis/lcs/lcs-tests.factor index 7d9a9ffd27..3aa10a0687 100644 --- a/basis/lcs/lcs-tests.factor +++ b/basis/lcs/lcs-tests.factor @@ -2,10 +2,6 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test lcs ; -\ lcs must-infer -\ diff must-infer -\ levenshtein must-infer - [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test [ 3 ] [ "kitten" "sitting" levenshtein ] unit-test [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor index 8c67590697..d32b199873 100644 --- a/basis/lcs/lcs.factor +++ b/basis/lcs/lcs.factor @@ -8,7 +8,7 @@ IN: lcs 0 1 ? + [ [ 1+ ] bi@ ] dip min min ; : lcs-step ( insert delete change same? -- next ) - 1 -1./0. ? + max max ; ! -1./0. is -inf (float) + 1 -1/0. ? + max max ; ! -1/0. is -inf (float) :: loop-step ( i j matrix old new step -- ) i j 1+ matrix nth nth ! insertion diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index 014e096b1d..0f13b6dd86 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel io system prettyprint ; +USING: help.markup help.syntax kernel io system prettyprint continuations ; IN: listener ARTICLE: "listener-watch" "Watching variables in the listener" @@ -41,32 +41,18 @@ $nl { $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" } "The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them." { $subsection "listener-watch" } -"You can start a nested listener or exit a listener using the following words:" +"To start a nested listener:" { $subsection listener } -{ $subsection bye } -"Finally, the multi-line expression reading word can be used independently of the rest of the listener:" +"To exit the listener, invoke the " { $link return } " word." +$nl +"Multi-line quotations can be read independently of the rest of the listener:" { $subsection read-quot } ; ABOUT: "listener" - - HELP: read-quot { $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } } { $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ; -HELP: listen -{ $description "Prompts for an expression on " { $link input-stream } " and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." } -{ $errors "If the expression input by the user throws an error, the error is printed to " { $link output-stream } " and the word returns normally." } ; - HELP: listener { $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ; - -HELP: bye -{ $description "Exits the current listener." } -{ $notes "This word is for interactive use only. To exit the Factor runtime, use " { $link exit } "." } ; diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor index 0616794939..7ed082234a 100644 --- a/basis/listener/listener-tests.factor +++ b/basis/listener/listener-tests.factor @@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ; "\\ + 1 2 3 4" parse-interactive "cont" get continue-with ] ignore-errors - "USE: debugger :1" eval + "USE: debugger :1" eval( -- quot ) ] callcc1 ] unit-test ] with-file-vocabs @@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ; [ [ ] [ - "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive + "IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive drop ] unit-test ] with-file-vocabs diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 4f7ccf227e..68777f2f73 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory namespaces parser lexer sequences strings io.styles vectors words generic system combinators continuations debugger definitions compiler.units accessors colors prettyprint fry -sets vocabs.parser ; +sets vocabs.parser source-files.errors locals ; IN: listener GENERIC: stream-read-quot ( stream -- quot/f ) @@ -32,17 +32,9 @@ M: object stream-read-quot : read-quot ( -- quot/f ) input-stream get stream-read-quot ; - - -: bye ( -- ) quit-flag on ; - SYMBOL: visible-vars -: show-var ( var -- ) visible-vars [ swap suffix ] change ; +: show-var ( var -- ) visible-vars [ swap suffix ] change ; : show-vars ( seq -- ) visible-vars [ swap union ] change ; @@ -68,6 +60,10 @@ SYMBOL: max-stack-items 10 max-stack-items set-global +SYMBOL: error-summary? + +t error-summary? set-global + : listener ( -- ) - [ until-quit ] with-interactive-vocabs ; + [ [ { } (listener) ] with-interactive-vocabs ] with-return ; MAIN: listener diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 4b0abb7f2d..fecb76f1c0 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -106,7 +106,8 @@ PRIVATE> : deep-sequence>cons ( sequence -- cons ) [ ] keep nil - [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; + [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ] + with reduce ; vector) ( acc list quot: ( elt -- elt' ) -- acc ) 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 100% rename from extra/literals/literals-docs.factor rename to basis/literals/literals-docs.factor diff --git a/extra/literals/literals-tests.factor b/basis/literals/literals-tests.factor similarity index 85% rename from extra/literals/literals-tests.factor rename to basis/literals/literals-tests.factor index 024c94e4f2..29072f1299 100644 --- a/extra/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -19,3 +19,9 @@ 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 diff --git a/extra/literals/literals.factor b/basis/literals/literals.factor similarity index 52% rename from extra/literals/literals.factor rename to basis/literals/literals.factor index e55d78ab6e..7c7592dda8 100644 --- a/extra/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,6 +1,8 @@ ! (c) Joe Groff, see license for details -USING: accessors continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations +combinators.smart vectors sequences ; IN: literals SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; +SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] 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/backend/backend-tests.factor b/basis/locals/backend/backend-tests.factor index ee714f7ef7..ad78516059 100644 --- a/basis/locals/backend/backend-tests.factor +++ b/basis/locals/backend/backend-tests.factor @@ -1,14 +1,14 @@ IN: locals.backend.tests -USING: tools.test locals.backend kernel arrays ; +USING: tools.test locals.backend kernel arrays accessors ; : get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ; -\ get-local-test-1 must-infer +\ get-local-test-1 def>> must-infer [ 3 ] [ get-local-test-1 ] unit-test : get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ; -\ get-local-test-2 must-infer +\ get-local-test-2 def>> must-infer [ 3 ] [ get-local-test-2 ] unit-test diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 18dabed4b0..b1f0b6ca17 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -112,7 +112,15 @@ HELP: MEMO:: { $description "Defines a memoized word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } ; { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words + +HELP: M:: +{ $syntax "M:: class generic ( bindings... -- outputs... ) body... ;" } +{ $description "Defines a method with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } +{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ; +{ POSTPONE: M: POSTPONE: M:: } related-words + + ARTICLE: "locals-literals" "Locals in literals" "Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables." $nl @@ -237,13 +245,14 @@ $nl } "The reason is that locals are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to local transformation, however "{ $vocab-link "macros.expander" } " does not deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ; -ARTICLE: "locals" "Local variables and lexical closures" +ARTICLE: "locals" "Lexical variables and closures" "The " { $vocab-link "locals" } " vocabulary implements lexical scope with full closures, both downward and upward. Mutable bindings are supported, including assignment to bindings in outer scope." $nl "Compile-time transformation is used to compile local variables to efficient code; prettyprinter extensions are defined so that " { $link see } " can display original word definitions with local variables and not the closure-converted concatenative code which results." $nl "Applicative word definitions where the inputs are named local variables:" { $subsection POSTPONE: :: } +{ $subsection POSTPONE: M:: } { $subsection POSTPONE: MEMO:: } { $subsection POSTPONE: MACRO:: } "Lexical binding forms:" diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 8e61e39faf..1549a77663 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -43,8 +43,8 @@ IN: locals.tests [ { 1 2 } ] [ 2 let-test-4 ] unit-test -:: let-test-5 ( a -- b ) - a [let | a [ ] b [ ] | a b 2array ] ; +:: let-test-5 ( a b -- b ) + a b [let | a [ ] b [ ] | a b 2array ] ; [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test @@ -129,7 +129,8 @@ write-test-2 "q" set SYMBOL: a :: use-test ( a b c -- a b c ) - USE: kernel ; + USE: kernel + a b c ; [ t ] [ a symbol? ] unit-test @@ -171,9 +172,9 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; [ ] [ \ lambda-generic see ] unit-test -:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ; +:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ; -[ "[let | a! [ ] | ]" ] [ +[ "[let | a! [ 3 ] | ]" ] [ \ unparse-test-1 "lambda" word-prop body>> first unparse ] unit-test @@ -261,7 +262,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" -[ ] [ new-definition eval ] unit-test +[ ] [ new-definition eval( -- ) ] unit-test [ t ] [ [ \ a-word-with-locals see ] with-string-writer @@ -286,7 +287,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { [ a b > ] [ 5 ] } } cond ; -\ cond-test must-infer +\ cond-test def>> must-infer [ 3 ] [ 1 2 cond-test ] unit-test [ 4 ] [ 2 2 cond-test ] unit-test @@ -295,7 +296,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; :: 0&&-test ( a -- ? ) { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ; -\ 0&&-test must-infer +\ 0&&-test def>> must-infer [ f ] [ 1.5 0&&-test ] unit-test [ f ] [ 3 0&&-test ] unit-test @@ -305,7 +306,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; :: &&-test ( a -- ? ) { [ a integer? ] [ a even? ] [ a 10 > ] } && ; -\ &&-test must-infer +\ &&-test def>> must-infer [ f ] [ 1.5 &&-test ] unit-test [ f ] [ 3 &&-test ] unit-test @@ -321,7 +322,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; ] ] ; -\ let-and-cond-test-1 must-infer +\ let-and-cond-test-1 def>> must-infer [ 20 ] [ let-and-cond-test-1 ] unit-test @@ -332,7 +333,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; ] ] ; -\ let-and-cond-test-2 must-infer +\ let-and-cond-test-2 def>> must-infer [ { 10 20 } ] [ let-and-cond-test-2 ] unit-test @@ -388,7 +389,7 @@ ERROR: punned-class x ; { 5 [ a a ^ ] } } case ; -\ big-case-test must-infer +\ big-case-test def>> must-infer [ 9 ] [ 3 big-case-test ] unit-test @@ -400,7 +401,7 @@ ERROR: punned-class x ; [| x | x 12 + { "howdy" } nth ] } case ; -\ littledan-case-problem-1 must-infer +\ littledan-case-problem-1 def>> must-infer [ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test [ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test @@ -412,7 +413,7 @@ ERROR: punned-class x ; [| x | x a - { "howdy" } nth ] } case ; -\ littledan-case-problem-2 must-infer +\ littledan-case-problem-2 def>> must-infer [ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test [ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test @@ -424,7 +425,7 @@ ERROR: punned-class x ; [| x | x a - { "howdy" } nth ] } cond ; -\ littledan-cond-problem-1 must-infer +\ littledan-cond-problem-1 def>> must-infer [ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test [ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test @@ -448,62 +449,62 @@ ERROR: punned-class x ; : littledan-case-problem-4 ( a -- b ) [ 1 + ] littledan-case-problem-3 ; -\ littledan-case-problem-4 must-infer +\ littledan-case-problem-4 def>> must-infer */ GENERIC: lambda-method-forget-test ( a -- b ) -M:: integer lambda-method-forget-test ( a -- b ) ; +M:: integer lambda-method-forget-test ( a -- b ) a ; -[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test +[ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test [ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test [ "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]" - eval call + eval( -- ) call ] [ error>> >r/r>-in-fry-error? ] must-fail-with :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline : funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ; -\ funny-macro-test must-infer +\ funny-macro-test def>> must-infer [ t ] [ 3 funny-macro-test ] unit-test [ f ] [ 2 funny-macro-test ] unit-test ! Some odd parser corner cases -[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test :: FAILdog-1 ( -- b ) { [| c | c ] } ; -\ FAILdog-1 must-infer +\ FAILdog-1 def>> must-infer :: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ; -\ FAILdog-2 must-infer +\ FAILdog-2 def>> must-infer [ 3 ] [ 3 [| a | \ a ] call ] unit-test -[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail +[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail -[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail +[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail -[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail +[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail -[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail +[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail -[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail +[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail -[ "USE: locals [| | { :> a } ]" eval ] must-fail +[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail -[ "USE: locals 3 :> a" eval ] must-fail +[ "USE: locals 3 :> a" eval( -- ) ] must-fail [ 3 ] [ 3 [| | :> a a ] call ] unit-test @@ -518,7 +519,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ; { [ is-integer? ] [ is-even? ] [ >10? ] } && ] ; -\ wlet-&&-test must-infer +\ wlet-&&-test def>> must-infer [ f ] [ 1.5 wlet-&&-test ] unit-test [ f ] [ 3 wlet-&&-test ] unit-test [ f ] [ 8 wlet-&&-test ] unit-test @@ -527,13 +528,13 @@ M:: integer lambda-method-forget-test ( a -- b ) ; : fry-locals-test-1 ( -- n ) [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ; -\ fry-locals-test-1 must-infer +\ fry-locals-test-1 def>> must-infer [ 10 ] [ fry-locals-test-1 ] unit-test :: fry-locals-test-2 ( -- n ) [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ; -\ fry-locals-test-2 must-infer +\ fry-locals-test-2 def>> must-infer [ 10 ] [ fry-locals-test-2 ] unit-test [ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test @@ -584,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 \ No newline at end of file +[ 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/macros/macros-tests.factor b/basis/macros/macros-tests.factor index 91aa6880e6..bf483f72ea 100644 --- a/basis/macros/macros-tests.factor +++ b/basis/macros/macros-tests.factor @@ -13,11 +13,11 @@ unit-test [ t ] [ \ see-test macro? ] unit-test [ t ] [ - "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval + "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- ) [ \ see-test see ] with-string-writer = ] unit-test [ f ] [ \ see-test macro? ] unit-test -[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test +[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index a86b711340..0e5ef30f51 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -12,10 +12,11 @@ IN: macros PRIVATE> : define-macro ( word definition effect -- ) - real-macro-effect - [ [ memoize-quot [ call ] append ] keep define-declared ] - [ drop "macro" set-word-prop ] - 3bi ; + real-macro-effect { + [ [ memoize-quot [ call ] append ] keep define-declared ] + [ drop "macro" set-word-prop ] + [ 2drop changed-effect ] + } 3cleave ; SYNTAX: MACRO: (:) define-macro ; diff --git a/basis/match/match.factor b/basis/match/match.factor index b21d8c6d73..ec0cb8c9e6 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- ) } cond ; : match-replace ( object pattern1 pattern2 -- result ) - -rot - match [ "Pattern does not match" throw ] unless* + [ match [ "Pattern does not match" throw ] unless* ] dip swap [ replace-patterns ] bind ; : ?1-tail ( seq -- tail/f ) diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index 7698760f84..e10853af18 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -26,7 +26,7 @@ CONSTANT: b 2 [ 3 ] [ foo ] unit-test [ 3 ] [ { a b } flags ] unit-test -\ foo must-infer +\ foo def>> must-infer [ 1 ] [ { 1 } flags ] unit-test diff --git a/basis/math/blas/config/config.factor b/basis/math/blas/config/config.factor index 8ed515625d..09f736c036 100644 --- a/basis/math/blas/config/config.factor +++ b/basis/math/blas/config/config.factor @@ -15,9 +15,10 @@ blas-fortran-abi [ { { [ os macosx? ] [ intel-unix-abi ] } { [ os windows? cpu x86.32? and ] [ f2c-abi ] } + { [ os netbsd? cpu x86.64? and ] [ g95-abi ] } { [ os windows? cpu x86.64? and ] [ gfortran-abi ] } { [ os freebsd? ] [ gfortran-abi ] } - { [ os linux? cpu x86.32? and ] [ gfortran-abi ] } + { [ os linux? ] [ gfortran-abi ] } [ f2c-abi ] } cond ] initialize 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/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 4c9d151fd8..397a7cc2f3 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -22,9 +22,9 @@ IN: math.functions.tests [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test [ t ] [ 0 0 ^ fp-nan? ] unit-test -[ 1.0/0.0 ] [ 0 -2 ^ ] unit-test +[ 1/0. ] [ 0 -2 ^ ] unit-test [ t ] [ 0 0.0 ^ fp-nan? ] unit-test -[ 1.0/0.0 ] [ 0 -2.0 ^ ] unit-test +[ 1/0. ] [ 0 -2.0 ^ ] unit-test [ 0 ] [ 0 3.0 ^ ] unit-test [ 0 ] [ 0 3 ^ ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 1eac321e3b..c21053317e 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 @@ -81,7 +70,7 @@ PRIVATE> 2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline : 0^ ( x -- z ) - dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline + dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline : (^mod) ( n x y -- z ) make-bits 1 [ diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 378ca2fb4b..2b8b3dff24 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -255,11 +255,11 @@ IN: math.intervals.tests 0 pick interval-contains? over first \ recip eq? and [ 2drop t ] [ - [ [ random-element ] dip first execute ] 2keep - second execute interval-contains? + [ [ random-element ] dip first execute( a -- b ) ] 2keep + second execute( a -- b ) interval-contains? ] if ; -[ t ] [ 80000 [ drop unary-test ] all? ] unit-test +[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test : random-binary-op ( -- pair ) { @@ -286,11 +286,11 @@ IN: math.intervals.tests 0 pick interval-contains? over first { / /i mod rem } member? and [ 3drop t ] [ - [ [ [ random-element ] bi@ ] dip first execute ] 3keep - second execute interval-contains? + [ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep + second execute( a b -- c ) interval-contains? ] if ; -[ t ] [ 80000 [ drop binary-test ] all? ] unit-test +[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test : random-comparison ( -- pair ) { @@ -302,10 +302,10 @@ IN: math.intervals.tests : comparison-test ( -- ? ) random-interval random-interval random-comparison - [ [ [ random-element ] bi@ ] dip first execute ] 3keep - second execute dup incomparable eq? [ 2drop t ] [ = ] if ; + [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep + second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ; -[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test +[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test [ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test @@ -322,7 +322,7 @@ IN: math.intervals.tests [ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test ! Test that commutative interval ops really are -: random-interval-or-empty ( -- ) +: random-interval-or-empty ( -- obj ) 10 random 0 = [ empty-interval ] [ random-interval ] if ; : random-commutative-op ( -- op ) @@ -333,7 +333,7 @@ IN: math.intervals.tests } random ; [ t ] [ - 80000 [ + 80000 iota [ drop random-interval-or-empty random-interval-or-empty random-commutative-op diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 4fbc880971..02ea181f4e 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -40,13 +40,13 @@ TUPLE: interval { from read-only } { to read-only } ; : [a,a] ( a -- interval ) closed-point dup ; foldable -: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline +: [-inf,a] ( a -- interval ) -1/0. swap [a,b] ; inline -: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline +: [-inf,a) ( a -- interval ) -1/0. swap [a,b) ; inline -: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline +: [a,inf] ( a -- interval ) 1/0. [a,b] ; inline -: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline +: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline : [-inf,inf] ( -- interval ) full-interval ; inline diff --git a/basis/math/libm/libm-docs.factor b/basis/math/libm/libm-docs.factor index bf4c608d77..a890a59c19 100644 --- a/basis/math/libm/libm-docs.factor +++ b/basis/math/libm/libm-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions" $nl "They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:" { $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" } -{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" } +{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } "Trigonometric functions:" { $subsection fcos } { $subsection fsin } diff --git a/basis/tools/vocabs/monitor/authors.txt b/basis/math/matrices/authors.txt similarity index 100% rename from basis/tools/vocabs/monitor/authors.txt rename to basis/math/matrices/authors.txt diff --git a/core/compiler/errors/authors.txt b/basis/math/matrices/elimination/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/compiler/errors/authors.txt rename to basis/math/matrices/elimination/authors.txt diff --git a/extra/math/matrices/elimination/elimination-tests.factor b/basis/math/matrices/elimination/elimination-tests.factor similarity index 100% rename from extra/math/matrices/elimination/elimination-tests.factor rename to basis/math/matrices/elimination/elimination-tests.factor diff --git a/extra/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor similarity index 100% rename from extra/math/matrices/elimination/elimination.factor rename to basis/math/matrices/elimination/elimination.factor diff --git a/extra/math/matrices/elimination/summary.txt b/basis/math/matrices/elimination/summary.txt similarity index 100% rename from extra/math/matrices/elimination/summary.txt rename to basis/math/matrices/elimination/summary.txt diff --git a/extra/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor similarity index 100% rename from extra/math/matrices/matrices-tests.factor rename to basis/math/matrices/matrices-tests.factor diff --git a/extra/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor similarity index 92% rename from extra/math/matrices/matrices.factor rename to basis/math/matrices/matrices.factor index 7c687d753d..cfdbe17c06 100755 --- a/extra/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.order math.vectors sequences ; +USING: arrays kernel math math.order math.vectors +sequences sequences.private accessors columns ; IN: math.matrices ! Matrices diff --git a/extra/math/matrices/summary.txt b/basis/math/matrices/summary.txt similarity index 100% rename from extra/math/matrices/summary.txt rename to basis/math/matrices/summary.txt 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-docs.factor b/basis/math/ranges/ranges-docs.factor index 8987def80b..e35adb10e5 100644 --- a/basis/math/ranges/ranges-docs.factor +++ b/basis/math/ranges/ranges-docs.factor @@ -2,7 +2,7 @@ USING: help.syntax help.markup arrays sequences ; IN: math.ranges -ARTICLE: "ranges" "Ranges" +ARTICLE: "math.ranges" "Numeric ranges" "A " { $emphasis "range" } " is a virtual sequence with real number elements " "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } ". Ascending as well as descending ranges are supported." $nl @@ -24,4 +24,4 @@ $nl { $code "100 1 [a,b] product" } "A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ; -ABOUT: "ranges" \ No newline at end of file +ABOUT: "math.ranges" \ No newline at end of file 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/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..90174d144e 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -1,12 +1,18 @@ ! 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 prettyprint.custom prettyprint.backend ; 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 ; + +M: rect pprint* + \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; + : ( -- rect ) rect new ; inline : point>rect ( loc -- rect ) { 0 0 } ; inline @@ -55,4 +61,4 @@ 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 diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor index cfb5cffb37..a551272f43 100644 --- a/basis/memoize/memoize-docs.factor +++ b/basis/memoize/memoize-docs.factor @@ -3,6 +3,20 @@ USING: help.syntax help.markup words quotations effects ; IN: memoize +ARTICLE: "memoize" "Memoization" +"The " { $vocab-link "memoize" } " vocabulary implements a simple form of memoization, which is when a word caches results for every unique set of inputs that is supplied. Calling a memoized word with the same inputs more than once does not recalculate anything." +$nl +"Memoization is useful in situations where the set of possible inputs is small, but the results are expensive to compute and should be cached. Memoized words should not have any side effects." +$nl +"Defining a memoized word at parse time:" +{ $subsection POSTPONE: MEMO: } +"Defining a memoized word at run time:" +{ $subsection define-memoized } +"Clearing memoized results:" +{ $subsection reset-memoized } ; + +ABOUT: "memoize" + HELP: define-memoized { $values { "word" word } { "quot" quotation } { "effect" effect } } { $description "defines the given word at runtime as one which memoizes its output given a particular input" } diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 54378bd37e..d82abe5b07 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -9,7 +9,7 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail +[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail MEMO: see-test ( a -- b ) reverse ; @@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ; [ [ \ see-test see ] with-string-writer ] unit-test -[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test +[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor index 4e10fc3de4..74ca07cda3 100644 --- a/basis/memoize/memoize.factor +++ b/basis/memoize/memoize.factor @@ -61,3 +61,5 @@ M: memoized reset-word : invalidate-memoized ( inputs... word -- ) [ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ; + +\ invalidate-memoized t "no-compile" set-word-prop \ No newline at end of file diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index 0edfb05a30..0cf7556bcd 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -137,9 +137,6 @@ ERROR: no-content-disposition multipart ; [ no-content-disposition ] } case ; -: assert-sequence= ( a b -- ) - 2dup sequence= [ 2drop ] [ assert ] if ; - : read-assert-sequence= ( sequence -- ) [ length read ] keep assert-sequence= ; diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor index aad033600a..ed1f423bb0 100644 --- a/basis/mirrors/mirrors-tests.factor +++ b/basis/mirrors/mirrors-tests.factor @@ -56,6 +56,6 @@ TUPLE: color ! Test reshaping with a mirror 1 2 3 color boa "mirror" set -[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test +[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test [ 1 ] [ "red" "mirror" get at ] unit-test diff --git a/basis/models/arrow/smart/authors.txt b/basis/models/arrow/smart/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/models/arrow/smart/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/models/arrow/smart/smart-docs.factor b/basis/models/arrow/smart/smart-docs.factor new file mode 100644 index 0000000000..3cc22d8d40 --- /dev/null +++ b/basis/models/arrow/smart/smart-docs.factor @@ -0,0 +1,21 @@ +IN: models.arrow.smart +USING: help.syntax help.markup models.product ; + +HELP: +{ $values { "quot" { $quotation "( ... -- output )" } } } +{ $description "A macro that expands into a form with the stack effect of the quotation. The form constructs a model which applies the quotation to values from an underlying " { $link product } " model having as many components as the quotation has inputs." } +{ $examples + "A model which adds the values of two existing models:" + { $example + "USING: models models.arrow.smart accessors kernel math prettyprint ;" + "1 2 [ + ] " + "[ activate-model ] [ value>> ] bi ." + "3" + } +} ; + +ARTICLE: "models.arrow.smart" "Smart arrow models" +"The " { $vocab-link "models.arrow.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "." +{ $subsection } ; + +ABOUT: "models.arrow.smart" \ No newline at end of file diff --git a/basis/models/arrow/smart/smart-tests.factor b/basis/models/arrow/smart/smart-tests.factor new file mode 100644 index 0000000000..3e8375e512 --- /dev/null +++ b/basis/models/arrow/smart/smart-tests.factor @@ -0,0 +1,4 @@ +IN: models.arrows.smart.tests +USING: models.arrow.smart tools.test accessors models math kernel ; + +[ 7 ] [ 3 4 [ + ] [ activate-model ] [ value>> ] bi ] unit-test \ No newline at end of file diff --git a/basis/models/arrow/smart/smart.factor b/basis/models/arrow/smart/smart.factor new file mode 100644 index 0000000000..257a2bb1ea --- /dev/null +++ b/basis/models/arrow/smart/smart.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: models.arrow models.product stack-checker accessors fry +generalizations macros kernel ; +IN: models.arrow.smart + +MACRO: ( quot -- quot' ) + [ infer in>> dup ] keep + '[ _ narray [ _ firstn @ ] ] ; \ No newline at end of file diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 2b90bdb0d5..8f40a8adbe 100644 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -133,7 +133,6 @@ $nl { $subsection "models-impl" } { $subsection "models.arrow" } { $subsection "models.product" } -{ $subsection "models-history" } { $subsection "models-range" } { $subsection "models-delay" } ; diff --git a/basis/models/models-tests.factor b/basis/models/models-tests.factor index f875fa3140..7368a2aa54 100644 --- a/basis/models/models-tests.factor +++ b/basis/models/models-tests.factor @@ -31,6 +31,3 @@ T{ model-tester f f } "tester" set "tester" get "model-c" get value>> ] unit-test - -\ model-changed must-infer -\ set-model must-infer diff --git a/basis/models/search/search.factor b/basis/models/search/search.factor index 4bf74b3b92..5ecb0fa34a 100644 --- a/basis/models/search/search.factor +++ b/basis/models/search/search.factor @@ -1,12 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: arrays fry kernel models.product models.arrow -sequences unicode.case ; +USING: fry kernel models.arrow.smart sequences unicode.case ; IN: models.search : ( values search quot -- model ) - [ 2array ] dip - '[ first2 _ curry filter ] ; + '[ _ curry filter ] ; inline : ( values search quot -- model ) - '[ swap @ [ >case-fold ] bi@ subseq? ] ; + '[ swap @ [ >case-fold ] bi@ subseq? ] ; inline diff --git a/basis/models/sort/sort.factor b/basis/models/sort/sort.factor index 23c150796f..efd2e4927b 100644 --- a/basis/models/sort/sort.factor +++ b/basis/models/sort/sort.factor @@ -1,8 +1,7 @@ -! Copyright (C) 2008 Slava Pestov +! Copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: arrays fry kernel models.product models.arrow -sequences sorting ; +USING: sorting models.arrow.smart fry ; IN: models.sort : ( values sort -- model ) - 2array [ first2 sort ] ; \ No newline at end of file + [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] ; inline \ No newline at end of file diff --git a/basis/opengl/authors.txt b/basis/opengl/authors.txt index 55ac3c728e..f4e25322b8 100644 --- a/basis/opengl/authors.txt +++ b/basis/opengl/authors.txt @@ -1,3 +1,4 @@ Slava Pestov Eduardo Cavazos Joe Groff +Alex Chapman diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor index 09d49b33c2..ad04ce7fa5 100755 --- a/basis/opengl/capabilities/capabilities.factor +++ b/basis/opengl/capabilities/capabilities.factor @@ -32,6 +32,8 @@ IN: opengl.capabilities (gl-version) drop ; : gl-vendor-version ( -- version ) (gl-version) nip ; +: gl-vendor ( -- name ) + GL_VENDOR glGetString ; : has-gl-version? ( version -- ? ) gl-version version-before? ; : (make-gl-version-error) ( required-version -- ) diff --git a/basis/opengl/gl/authors.txt b/basis/opengl/gl/authors.txt index 1901f27a24..e9c193bac7 100644 --- a/basis/opengl/gl/authors.txt +++ b/basis/opengl/gl/authors.txt @@ -1 +1 @@ -Slava Pestov +Alex Chapman 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/opengl-docs.factor b/basis/opengl/opengl-docs.factor index f474c97b73..b773833280 100644 --- a/basis/opengl/opengl-docs.factor +++ b/basis/opengl/opengl-docs.factor @@ -15,8 +15,8 @@ HELP: do-enabled { $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ; HELP: do-matrix -{ $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } } -{ $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ; +{ $values { "quot" quotation } } +{ $description "Saves and restores the current matrix before and after calling the quotation." } ; HELP: gl-line { $values { "a" "a pair of integers" } { "b" "a pair of integers" } } diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 0a21f67376..72ca8b8cdb 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -3,7 +3,7 @@ ! Portions copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types continuations kernel libc math macros -namespaces math.vectors math.parser opengl.gl opengl.glu combinators +namespaces math.vectors math.parser opengl.gl combinators combinators.smart arrays sequences splitting words byte-arrays assocs colors colors.constants accessors generalizations locals fry specialized-arrays.float specialized-arrays.uint ; @@ -16,10 +16,23 @@ IN: opengl : gl-clear ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ; +: error>string ( n -- string ) + H{ + { HEX: 0 "No error" } + { HEX: 0501 "Invalid value" } + { HEX: 0500 "Invalid enumerant" } + { HEX: 0502 "Invalid operation" } + { HEX: 0503 "Stack overflow" } + { HEX: 0504 "Stack underflow" } + { HEX: 0505 "Out of memory" } + } at "Unknown error" or ; + +TUPLE: gl-error code string ; + : gl-error ( -- ) - glGetError dup zero? [ - "GL error: " over gluErrorString append throw - ] unless drop ; + glGetError dup 0 = [ drop ] [ + dup error>string \ gl-error boa throw + ] if ; : do-enabled ( what quot -- ) over glEnable dip glDisable ; inline @@ -44,9 +57,8 @@ MACRO: all-enabled ( seq quot -- ) MACRO: all-enabled-client-state ( seq quot -- ) [ words>values ] dip '[ _ _ (all-enabled-client-state) ] ; -: do-matrix ( mode quot -- ) - swap [ glMatrixMode glPushMatrix call ] keep - glMatrixMode glPopMatrix ; inline +: do-matrix ( quot -- ) + glPushMatrix call glPopMatrix ; inline : gl-material ( face pname params -- ) float-array{ } like glMaterialfv ; @@ -152,9 +164,6 @@ MACRO: all-enabled-client-state ( seq quot -- ) MACRO: set-draw-buffers ( buffers -- ) words>values '[ _ (set-draw-buffers) ] ; -: gl-look-at ( eye focus up -- ) - [ first3 ] tri@ gluLookAt ; - : gen-dlist ( -- id ) 1 glGenLists ; : make-dlist ( type quot -- id ) @@ -165,7 +174,7 @@ MACRO: set-draw-buffers ( buffers -- ) : delete-dlist ( id -- ) 1 glDeleteLists ; : with-translation ( loc quot -- ) - GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline + [ [ gl-translate ] dip call ] do-matrix ; inline : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) [ first2 [ >fixnum ] bi@ ] bi@ ; @@ -177,6 +186,7 @@ MACRO: set-draw-buffers ( buffers -- ) fix-coordinates glViewport ; : init-matrices ( -- ) + #! Leaves with matrix mode GL_MODELVIEW GL_PROJECTION glMatrixMode glLoadIdentity GL_MODELVIEW glMatrixMode 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-tests.factor b/basis/opengl/textures/textures-tests.factor index 163871028d..3efdb43cd8 100644 --- a/basis/opengl/textures/textures-tests.factor +++ b/basis/opengl/textures/textures-tests.factor @@ -5,56 +5,6 @@ opengl.textures.private images kernel namespaces accessors sequences ; IN: opengl.textures.tests -[ ] [ - T{ image - { dim { 3 5 } } - { component-order RGB } - { bitmap - B{ - 1 2 3 4 5 6 7 8 9 - 10 11 12 13 14 15 16 17 18 - 19 20 21 22 23 24 25 26 27 - 28 29 30 31 32 33 34 35 36 - 37 38 39 40 41 42 43 44 45 - } - } - } "image" set -] unit-test - -[ - T{ image - { dim { 4 8 } } - { component-order RGB } - { bitmap - B{ - 1 2 3 4 5 6 7 8 9 7 8 9 - 10 11 12 13 14 15 16 17 18 16 17 18 - 19 20 21 22 23 24 25 26 27 25 26 27 - 28 29 30 31 32 33 34 35 36 34 35 36 - 37 38 39 40 41 42 43 44 45 43 44 45 - 37 38 39 40 41 42 43 44 45 43 44 45 - 37 38 39 40 41 42 43 44 45 43 44 45 - 37 38 39 40 41 42 43 44 45 43 44 45 - } - } - } -] [ - "image" get power-of-2-image -] unit-test - -[ - T{ image - { dim { 0 0 } } - { component-order R32G32B32 } - { bitmap B{ } } } -] [ - T{ image - { dim { 0 0 } } - { component-order R32G32B32 } - { bitmap B{ } } - } power-of-2-image -] unit-test - [ { { { 0 0 } { 10 0 } } diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 3efe924fb5..d103e90bee 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -1,11 +1,23 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs cache colors.constants destructors fry kernel -opengl opengl.gl combinators images images.tesselation grouping -specialized-arrays.float locals sequences math math.vectors -math.matrices generalizations fry columns arrays ; +opengl opengl.gl opengl.capabilities combinators images +images.tesselation grouping specialized-arrays.float sequences math +math.vectors math.matrices generalizations fry arrays namespaces +system ; IN: opengl.textures +SYMBOL: non-power-of-2-textures? + +: check-extensions ( -- ) + #! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly. + #! See thread 'Linux font display problem' April 2009 on Factor-talk + gl-vendor "ATI Technologies Inc." = not os macosx? or [ + "2.0" { "GL_ARB_texture_non_power_of_two" } + has-gl-version-or-extensions? + non-power-of-2-textures? set + ] when ; + : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ; @@ -18,60 +30,52 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ; M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; +M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ; +M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ; -GENERIC: draw-texture ( texture -- ) +SLOT: display-list + +: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ; GENERIC: draw-scaled-texture ( dim texture -- ) > ] - [ dim>> first ] - [ component-order>> bytes-per-pixel ] - tri * group ; inline - -: power-of-2-image ( image -- image ) - dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [ - clone dup - [ image-rows ] - [ dim>> [ next-power-of-2 ] map ] - [ component-order>> bytes-per-pixel ] tri - power-of-2-bitmap - [ >>bitmap ] [ >>dim ] bi* +: adjust-texture-dim ( dim -- dim' ) + non-power-of-2-textures? get [ + [ dup 1 = [ next-power-of-2 ] unless ] map ] unless ; -:: make-texture ( image -- id ) +: (tex-image) ( image bitmap -- ) + [ + [ GL_TEXTURE_2D 0 GL_RGBA ] dip + [ dim>> adjust-texture-dim first2 0 ] + [ component-order>> component-order>format ] bi + ] dip + glTexImage2D ; + +: (tex-sub-image) ( image -- ) + [ GL_TEXTURE_2D 0 0 0 ] dip + [ dim>> 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 - GL_TEXTURE_2D - 0 - GL_RGBA - image dim>> first2 - 0 - image component-order>> component-order>format - image bitmap>> - glTexImage2D + 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_LINEAR glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ; @@ -100,20 +104,19 @@ TUPLE: single-texture image loc dim texture-coords texture display-list disposed ] with-texturing ; : texture-coords ( texture -- coords ) + [ [ dim>> ] [ image>> dim>> adjust-texture-dim ] bi v/ ] [ - [ dim>> ] [ image>> dim>> ] bi v/ - { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } - [ v* ] with map - ] keep - image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when - float-array{ } join ; + image>> upside-down?>> + { { 0 1 } { 1 1 } { 1 0 } { 0 0 } } + { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ? + ] bi + [ v* ] with map float-array{ } join ; : make-texture-display-list ( texture -- dlist ) GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ; -: ( image loc dim -- texture ) - [ power-of-2-image ] 2dip - single-texture new swap >>dim swap >>loc swap >>image +: ( image loc -- texture ) + single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi dup image>> dim>> product 0 = [ dup texture-coords >>texture-coords dup image>> make-texture >>texture @@ -124,21 +127,21 @@ M: single-texture dispose* [ texture>> [ delete-texture ] when* ] [ display-list>> [ delete-dlist ] when* ] bi ; -M: single-texture draw-texture display-list>> [ glCallList ] when* ; - M: single-texture draw-scaled-texture - dup texture>> [ draw-textured-rect ] [ 2drop ] if ; + 2dup dim>> = [ nip draw-texture ] [ + dup texture>> [ draw-textured-rect ] [ 2drop ] if + ] if ; TUPLE: multi-texture grid display-list loc disposed ; : image-locs ( image-grid -- loc-grid ) - [ first [ dim>> first ] map ] [ 0 [ dim>> second ] map ] bi + [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi [ 0 [ + ] accumulate nip ] bi@ cross-zip flip ; : ( image-grid loc -- grid ) [ dup image-locs ] dip - '[ [ _ v+ over dim>> |dispose ] 2map ] 2map ; + '[ [ _ v+ |dispose ] 2map ] 2map ; : draw-textured-grid ( grid -- ) [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ; @@ -165,7 +168,7 @@ TUPLE: multi-texture grid display-list loc disposed ; f multi-texture boa ] with-destructors ; -M: multi-texture draw-texture display-list>> [ glCallList ] when* ; +M: multi-texture draw-scaled-texture nip draw-texture ; M: multi-texture dispose* grid>> [ [ dispose ] each ] each ; @@ -173,10 +176,7 @@ CONSTANT: max-texture-size { 512 512 } PRIVATE> -: small-texture? ( dim -- ? ) - max-texture-size [ <= ] 2all? ; - -: ( image loc dim -- texture ) - pick dim>> small-texture? +: ( image loc -- texture ) + over dim>> max-texture-size [ <= ] 2all? [ ] - [ drop [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file + [ [ max-texture-size tesselate ] dip ] if ; diff --git a/basis/pango/layouts/layouts.factor b/basis/pango/layouts/layouts.factor index defcdec6f8..25aee74ca4 100644 --- a/basis/pango/layouts/layouts.factor +++ b/basis/pango/layouts/layouts.factor @@ -44,7 +44,7 @@ FUNCTION: PangoLayoutLine* pango_layout_get_line_readonly ( PangoLayout* layout, int line ) ; FUNCTION: void -pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, gboolean trailing, int* x_pos ) ; +pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, uint trailing, int* x_pos ) ; FUNCTION: gboolean pango_layout_line_x_to_index ( PangoLayoutLine* line, int x_pos, int* index_, int* trailing ) ; @@ -122,7 +122,7 @@ MEMO: missing-font-metrics ( font -- metrics ) : line-offset>x ( layout n -- x ) #! n is an index into the UTF8 encoding of the text [ drop first-line ] [ swap string>> >utf8-index ] 2bi - f 0 [ pango_layout_line_index_to_x ] keep + 0 0 [ pango_layout_line_index_to_x ] keep *int pango>float ; : x>line-offset ( layout x -- n ) @@ -205,4 +205,4 @@ SYMBOL: cached-layouts : cached-line ( font string -- line ) cached-layout layout>> first-line ; -[ cached-layouts set-global ] "pango.layouts" add-init-hook \ No newline at end of file +[ cached-layouts set-global ] "pango.layouts" add-init-hook diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index cc83a55c7e..329156d733 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -300,8 +300,6 @@ main = Primary "x[i][j].y" primary ] unit-test -'ebnf' compile must-infer - { V{ V{ "a" "b" } "c" } } [ "abc" [EBNF a="a" "b" foo=(a "c") EBNF] ] unit-test @@ -444,12 +442,12 @@ foo= 'd' "ad" parser4 ] unit-test -{ t } [ - "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t +{ } [ + "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" eval( -- ) ] unit-test [ - "USING: peg.ebnf ; " eval drop + "USING: peg.ebnf ; " eval( -- ) drop ] must-fail { t } [ @@ -521,12 +519,12 @@ Tok = Spaces (Number | Special ) "\\" [EBNF foo="\\" EBNF] ] unit-test -[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail +[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail [ <" USE: peg.ebnf [EBNF lol = a lol = b - EBNF] "> eval + EBNF] "> eval( -- ) ] [ error>> [ redefined-rule? ] [ name>> "lol" = ] bi and ] must-fail-with diff --git a/basis/peg/ebnf/tags.txt b/basis/peg/ebnf/tags.txt index 5af5dba748..1ccdafb2bb 100644 --- a/basis/peg/ebnf/tags.txt +++ b/basis/peg/ebnf/tags.txt @@ -1,2 +1,3 @@ +extensions text parsing diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 7d5cb1e76a..cae1e05dc8 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -5,8 +5,6 @@ USING: kernel tools.test strings namespaces make arrays sequences peg peg.private peg.parsers accessors words math accessors ; IN: peg.tests -\ parse must-infer - [ ] [ reset-pegs ] unit-test [ @@ -201,12 +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 - -[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test \ No newline at end of file diff --git a/basis/peg/search/search-tests.factor b/basis/peg/search/search-tests.factor index 96d89d4611..b22a5ef0d0 100644 --- a/basis/peg/search/search-tests.factor +++ b/basis/peg/search/search-tests.factor @@ -17,5 +17,3 @@ IN: peg.search.tests "abc 123 def 456" 'integer' [ 2 * number>string ] action replace ] unit-test -\ search must-infer -\ replace must-infer diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index 91f1dcf1f8..ca9a86b6d9 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -21,7 +21,7 @@ TUPLE: deque { front read-only } { back read-only } ; [ back>> ] [ front>> ] bi deque boa ; : flipped ( deque quot -- newdeque ) - [ flip ] dip call flip ; + [ flip ] dip call flip ; inline PRIVATE> : deque-empty? ( deque -- ? ) diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor index 5ed72e5d59..eea31dd34e 100644 --- a/basis/persistent/hashtables/hashtables-tests.factor +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -83,7 +83,7 @@ M: hash-0-b hashcode* 2drop 0 ; : random-string ( -- str ) 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ; -: random-assocs ( -- hash phash ) +: random-assocs ( n -- hash phash ) [ random-string ] replicate [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ] [ PH{ } clone swap [ spin new-at ] each-index ] @@ -92,7 +92,7 @@ M: hash-0-b hashcode* 2drop 0 ; : ok? ( assoc1 assoc2 -- ? ) [ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ; -: test-persistent-hashtables-1 ( n -- ) +: test-persistent-hashtables-1 ( n -- ? ) random-assocs ok? ; [ t ] [ 10 test-persistent-hashtables-1 ] unit-test @@ -106,7 +106,7 @@ M: hash-0-b hashcode* 2drop 0 ; [ t ] [ 10000 test-persistent-hashtables-1 ] unit-test [ t ] [ 50000 test-persistent-hashtables-1 ] unit-test -: test-persistent-hashtables-2 ( n -- ) +: test-persistent-hashtables-2 ( n -- ? ) random-assocs dup keys [ [ nip over delete-at ] [ swap pluck-at nip ] 3bi diff --git a/basis/persistent/vectors/vectors-tests.factor b/basis/persistent/vectors/vectors-tests.factor index c232db8533..95fa70558d 100644 --- a/basis/persistent/vectors/vectors-tests.factor +++ b/basis/persistent/vectors/vectors-tests.factor @@ -3,10 +3,6 @@ USING: accessors tools.test persistent.vectors persistent.sequences sequences kernel arrays random namespaces vectors math math.order ; -\ new-nth must-infer -\ ppush must-infer -\ ppop must-infer - [ 0 ] [ PV{ } length ] unit-test [ 1 ] [ 3 PV{ } ppush length ] 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 bcd91a4d94..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 ; @@ -35,24 +34,25 @@ M: effect pprint* effect>string "(" ")" surround text ; name>> "( no name )" or ; : pprint-word ( word -- ) - dup record-vocab - dup word-name* swap word-style styled-text ; + [ record-vocab ] + [ [ word-name* ] [ word-style ] bi styled-text ] bi ; : pprint-prefix ( word quot -- ) ; inline +M: parsing-word pprint* + \ POSTPONE: [ pprint-word ] pprint-prefix ; + M: word pprint* - dup parsing-word? [ - \ POSTPONE: [ pprint-word ] pprint-prefix - ] [ - { - [ "break-before" word-prop line-break ] - [ pprint-word ] - [ ?start-group ] - [ ?end-group ] - [ "break-after" word-prop line-break ] - } cleave - ] if ; + [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ; + +M: method-body pprint* + [ + [ + [ "M\\ " % "method-class" word-prop word-name* % ] + [ " " % "method-generic" word-prop word-name* % ] bi + ] "" make + ] [ word-style ] bi styled-text ; M: real pprint* number>string text ; @@ -134,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 ; @@ -201,13 +206,14 @@ 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 ; M: wrapper pprint* - dup wrapped>> word? [ - > pprint-word block> - ] [ - pprint-object - ] if ; + { + { [ dup wrapped>> method-body? ] [ wrapped>> pprint* ] } + { [ dup wrapped>> word? ] [ > pprint-word block> ] } + [ pprint-object ] + } cond ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 7e37aa0da5..25ee83985e 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -2,8 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private -continuations generic compiler.units tools.walker eval -accessors make vocabs.parser see ; +continuations generic compiler.units tools.continuations +tools.continuations.private eval accessors make vocabs.parser see ; IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test @@ -86,11 +86,10 @@ unit-test drop ; [ "drop ;" ] [ - \ blah f "inferred-effect" set-word-prop [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail* ] unit-test -: check-see ( expect name -- ) +: check-see ( expect name -- ? ) [ use [ clone ] change @@ -105,6 +104,7 @@ unit-test GENERIC: method-layout ( a -- b ) M: complex method-layout + drop "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ; @@ -116,8 +116,9 @@ M: object method-layout ; [ { - "USING: math prettyprint.tests ;" + "USING: kernel math prettyprint.tests ;" "M: complex method-layout" + " drop" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" " ;" "" @@ -180,37 +181,15 @@ DEFER: parse-error-file "string-layout-test" string-layout check-see ] unit-test -! Define dummy words for the below... -: ( a b c d -- e ) ; -: ( -- fmt ) ; -: send ( obj -- ) ; - -\ send soft "break-after" set-word-prop - -: final-soft-break-test ( -- str ) - { - "USING: kernel sequences ;" - "IN: prettyprint.tests" - ": final-soft-break-layout ( class dim -- view )" - " [ \"alloc\" send 0 0 ] dip first2 " - " \"initWithFrame:pixelFormat:\" send" - " dup 1 \"setPostsBoundsChangedNotifications:\" send" - " dup 1 \"setPostsFrameChangedNotifications:\" send ;" - } ; - -[ t ] [ - "final-soft-break-layout" final-soft-break-test check-see -] unit-test - -: narrow-test ( -- str ) +: narrow-test ( -- array ) { "USING: arrays combinators continuations kernel sequences ;" "IN: prettyprint.tests" - ": narrow-layout ( obj -- )" + ": narrow-layout ( obj1 obj2 -- obj3 )" " {" " { [ dup continuation? ] [ append ] }" " { [ dup not ] [ drop reverse ] }" - " { [ dup pair? ] [ delete ] }" + " { [ dup pair? ] [ [ delete ] keep ] }" " } cond ;" } ; @@ -218,7 +197,7 @@ DEFER: parse-error-file "narrow-layout" narrow-test check-see ] unit-test -: another-narrow-test ( -- str ) +: another-narrow-test ( -- array ) { "IN: prettyprint.tests" ": another-narrow-layout ( -- obj )" @@ -274,19 +253,15 @@ M: class-see-layout class-see-layout ; ! Regression [ t ] [ "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n" - dup eval + dup eval( -- ) "generic-decl-test" "prettyprint.tests" lookup [ see ] with-string-writer = ] unit-test -[ [ + ] ] [ - [ \ + (step-into-execute) ] (remove-breakpoints) -] unit-test - -[ [ (step-into-execute) ] ] [ - [ (step-into-execute) ] (remove-breakpoints) -] unit-test +[ [ + ] ] [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test +[ [ (step-into-execute) ] ] [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test + [ [ 2 2 + . ] ] [ [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints) ] unit-test @@ -300,11 +275,7 @@ GENERIC: generic-see-test-with-f ( obj -- obj ) M: f generic-see-test-with-f ; [ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [ - [ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer -] unit-test - -[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [ - [ \ f \ generic-see-test-with-f method see ] with-string-writer + [ M\ f generic-see-test-with-f see ] with-string-writer ] unit-test PREDICATE: predicate-see-test < integer even? ; @@ -331,5 +302,5 @@ GENERIC: ended-up-ballin' ( a -- b ) M: started-out-hustlin' ended-up-ballin' ; inline [ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [ - [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer + [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer ] unit-test diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index fe58e3d07c..c35d7488ac 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 ; + [ ] dip with-random ; inline [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test diff --git a/basis/random/random.factor b/basis/random/random.factor index ebde3802b4..d972e1e7ac 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -54,7 +54,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 ) 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/authors.txt b/basis/refs/authors.txt index 1901f27a24..22d592c1dd 100755 --- a/basis/refs/authors.txt +++ b/basis/refs/authors.txt @@ -1 +1,2 @@ Slava Pestov +Alex Chapman diff --git a/basis/refs/refs-docs.factor b/basis/refs/refs-docs.factor old mode 100644 new mode 100755 index a219f0ba8b..9971a1d4fa --- a/basis/refs/refs-docs.factor +++ b/basis/refs/refs-docs.factor @@ -1,52 +1,143 @@ -! Copyright (C) 2007 Slava Pestov +! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel ; +USING: boxes help.markup help.syntax kernel math namespaces assocs ; IN: refs -ARTICLE: "refs" "References to assoc entries" -"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary." -{ $subsection get-ref } -{ $subsection set-ref } -{ $subsection delete-ref } -"References to keys:" -{ $subsection key-ref } -{ $subsection } -"References to values:" -{ $subsection value-ref } -{ $subsection } -"References are used by the UI inspector." ; +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 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 } +"References to assoc keys:" +{ $subsection key-ref } +{ $subsection } +"References to assoc values:" +{ $subsection value-ref } +{ $subsection } +"References to variables:" +{ $subsection var-ref } +{ $subsection } +{ $subsection global-var-ref } +{ $subsection } +"References to tuple slots:" +{ $subsection slot-ref } +{ $subsection } +"Using boxes as references:" +{ $subsection "box-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" +"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" "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 class whose instances identify a key or value location in an associative structure. Instances of this clas are never used directly; only instances of " { $link key-ref } " and " { $link value-ref } " should be created." } ; +{ $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 } "." } ; HELP: delete-ref { $values { "ref" ref } } -{ $description "Deletes the association entry pointed at by this reference." } ; +{ $description "Deletes the value pointed to by this reference. In most references this simply sets the value to f, but in some cases it is more destructive, such as in " { $link value-ref } " and " { $link key-ref } ", where it actually deletes the entry from the underlying assoc." } ; HELP: get-ref { $values { "ref" ref } { "obj" object } } -{ $description "Outputs the key or the value pointed at by this reference." } ; +{ $description "Outputs the value pointed at by this reference." } ; HELP: set-ref { $values { "obj" object } { "ref" ref } } -{ $description "Stores a new key or value at by this reference." } ; +{ $description "Stores a new value at this reference." } ; +HELP: obj-ref +{ $class-description "Instances of this class contain a value which can be changed using the " { $link "refs-protocol" } ". New object references are created by calling " { $link } "." } ; + +HELP: +{ $values { "obj" object } { "obj-ref" obj-ref } } +{ $description "Creates a reference which contains the value it references." } ; + +HELP: var-ref +{ $class-description "Instances of this class reference a variable as defined by the " { $vocab-link "namespaces" } " vocabulary. New variable references are created by calling " { $link } "." } ; + +HELP: +{ $values { "var" object } { "var-ref" var-ref } } +{ $description "Creates a reference to the given variable. Note that this reference behaves just like any variable when it comes to dynamic scope. For example, if you use " { $link set-ref } " in an inner scope and then leave that scope, then calling " { $link get-ref } " may not return the expected value. If this is not what you want, try using an " { $link obj-ref } " instead." } ; + +HELP: global-var-ref +{ $class-description "Instances of this class reference a global variable. New global references are created by calling " { $link } "." } ; + +HELP: +{ $values { "var" object } { "global-var-ref" global-var-ref } } +{ $description "Creates a reference to a global variable." } ; + +HELP: slot-ref +{ $class-description "Instances of this class identify a particular slot of a particular instance of a tuple. New slot references are created by calling " { $link } "." } ; + +HELP: +{ $values { "tuple" tuple } { "slot" integer } { "slot-ref" slot-ref } } +{ $description "Creates a reference to the value in a particular slot of the given tuple. The slot must be given as an integer, where the first user-defined slot is number 2. This is mostly just a proof of concept until we have a way of generating this slot number from a slot name." } ; + 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 } related-words +{ get-ref set-ref delete-ref set-ref* } related-words + +{ } related-words -{ } related-words +HELP: set-ref* +{ $values { "ref" ref } { "obj" object } } +{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ; + +HELP: ref-on +{ $values { "ref" ref } } +{ $description "Sets the value of the ref to t." } ; + +HELP: ref-off +{ $values { "ref" ref } } +{ $description "Sets the value of the ref to f." } ; + +HELP: ref-inc +{ $values { "ref" ref } } +{ $description "Increment the value of the ref by 1." } ; + +HELP: ref-dec +{ $values { "ref" ref } } +{ $description "Decrement the value of the ref by 1." } ; + +HELP: take +{ $values { "ref" ref } { "obj" object } } +{ $description "Retrieve the value of the ref and then delete it, returning the value." } ; + +{ ref-on ref-off ref-inc ref-dec take } related-words +{ take delete-ref } related-words +{ on ref-on } related-words +{ off ref-off } related-words +{ inc ref-inc } related-words +{ dec ref-dec } related-words diff --git a/basis/refs/refs-tests.factor b/basis/refs/refs-tests.factor index 1d921854e9..bf58aaf43d 100644 --- a/basis/refs/refs-tests.factor +++ b/basis/refs/refs-tests.factor @@ -1,5 +1,7 @@ -USING: refs tools.test kernel ; +USING: boxes kernel namespaces refs tools.test ; +IN: refs.tests +! assoc-refs [ 3 ] [ H{ { "a" 3 } } "a" get-ref ] unit-test @@ -20,3 +22,84 @@ USING: refs tools.test kernel ; set-ref ] keep ] unit-test + +SYMBOLS: lion giraffe elephant rabbit ; + +! obj-refs +[ rabbit ] [ rabbit get-ref ] unit-test +[ rabbit ] [ f rabbit set-ref* get-ref ] unit-test +[ rabbit ] [ rabbit take ] unit-test +[ rabbit f ] [ rabbit [ take ] keep get-ref ] unit-test +[ lion ] [ rabbit dup [ drop lion ] change-ref get-ref ] unit-test + +! var-refs +[ giraffe ] [ [ giraffe rabbit set rabbit get-ref ] with-scope ] unit-test + +[ rabbit ] +[ + [ + lion rabbit set [ + rabbit rabbit set rabbit get-ref + ] with-scope + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + lion rabbit set [ + rabbit rabbit set get-ref + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant rabbit set [ + rabbit rabbit set + ] with-scope + get-ref + ] with-scope +] unit-test + +[ rabbit ] [ + rabbit + [ + elephant set-ref* [ + rabbit set-ref* get-ref + ] with-scope + ] with-scope +] unit-test + +[ elephant ] [ + rabbit + [ + elephant set-ref* [ + rabbit set-ref* + ] with-scope + get-ref + ] with-scope +] unit-test + +! Top Hats +[ lion ] [ lion rabbit set-global rabbit get-ref ] unit-test +[ giraffe ] [ rabbit giraffe set-ref* get-ref ] unit-test + +! Tuple refs +TUPLE: foo bar ; +C: foo + +: test-tuple ( -- tuple ) + rabbit ; + +: test-slot-ref ( -- slot-ref ) + test-tuple 2 ; ! hack! + +[ rabbit ] [ test-slot-ref get-ref ] unit-test +[ lion ] [ test-slot-ref lion set-ref* get-ref ] unit-test + +! Boxes as refs +[ rabbit ] [ rabbit set-ref* get-ref ] unit-test +[ rabbit set-ref* lion set-ref* ] must-fail +[ get-ref ] must-fail diff --git a/basis/refs/refs.factor b/basis/refs/refs.factor index 0164a1ea57..668cdd65c3 100644 --- a/basis/refs/refs.factor +++ b/basis/refs/refs.factor @@ -1,22 +1,77 @@ -! Copyright (C) 2007, 2008 Slava Pestov +! Copyright (C) 2007, 2008 Slava Pestov, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: classes.tuple kernel assocs accessors ; +USING: kernel assocs accessors boxes math namespaces ; IN: refs -TUPLE: ref assoc key ; +MIXIN: ref -: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline - -: delete-ref ( ref -- ) >ref< delete-at ; GENERIC: get-ref ( ref -- obj ) GENERIC: set-ref ( obj ref -- ) +GENERIC: delete-ref ( ref -- ) -TUPLE: key-ref < ref ; +! works like >>slot words +: set-ref* ( ref obj -- ref ) over set-ref ; + +! very similar to change, on, off, +@, inc, and dec from namespaces +: change-ref ( ref quot -- ) + [ [ get-ref ] keep ] dip dip set-ref ; inline +: ref-on ( ref -- ) t swap set-ref ; +: ref-off ( ref -- ) f swap set-ref ; +: ref-+@ ( n ref -- ) [ 0 or + ] change-ref ; +: ref-inc ( ref -- ) 1 swap ref-+@ ; +: ref-dec ( ref -- ) -1 swap ref-+@ ; + +: take ( ref -- obj ) + dup get-ref swap delete-ref ; + +! delete-ref defaults to setting ref to f +M: ref delete-ref ref-off ; + +TUPLE: obj-ref obj ; +C: obj-ref +M: obj-ref get-ref obj>> ; +M: obj-ref set-ref (>>obj) ; +INSTANCE: obj-ref ref + +TUPLE: var-ref var ; +C: var-ref +M: var-ref get-ref var>> get ; +M: var-ref set-ref var>> set ; +INSTANCE: var-ref ref + +TUPLE: global-var-ref var ; +C: global-var-ref +M: global-var-ref get-ref var>> get-global ; +M: global-var-ref set-ref var>> set-global ; +INSTANCE: global-var-ref ref + +USE: slots.private +TUPLE: slot-ref tuple slot ; +C: slot-ref +: >slot-ref< ( slot-ref -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline +M: slot-ref get-ref >slot-ref< slot ; +M: slot-ref set-ref >slot-ref< set-slot ; +INSTANCE: slot-ref ref + +M: box get-ref box> ; +M: box set-ref >box ; +M: box delete-ref box> drop ; +INSTANCE: box ref + +TUPLE: assoc-ref assoc key ; + +: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline + +M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ; + +TUPLE: key-ref < assoc-ref ; C: key-ref M: key-ref get-ref key>> ; -M: key-ref set-ref >ref< rename-at ; +M: key-ref set-ref >assoc-ref< rename-at ; +INSTANCE: key-ref ref -TUPLE: value-ref < ref ; +TUPLE: value-ref < assoc-ref ; C: value-ref -M: value-ref get-ref >ref< at ; -M: value-ref set-ref >ref< set-at ; +M: value-ref get-ref >assoc-ref< at ; +M: value-ref set-ref >assoc-ref< set-at ; +INSTANCE: value-ref ref diff --git a/basis/regexp/ast/ast.factor b/basis/regexp/ast/ast.factor index be657227e5..2916ef7c32 100644 --- a/basis/regexp/ast/ast.factor +++ b/basis/regexp/ast/ast.factor @@ -21,12 +21,12 @@ CONSTANT: epsilon T{ tagged-epsilon { tag t } } TUPLE: concatenation first second ; : ( seq -- concatenation ) - [ epsilon ] [ unclip [ concatenation boa ] reduce ] if-empty ; + [ epsilon ] [ [ ] [ concatenation boa ] map-reduce ] if-empty ; TUPLE: alternation first second ; : ( seq -- alternation ) - unclip [ alternation boa ] reduce ; + [ ] [ alternation boa ] map-reduce ; TUPLE: star term ; C: star diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index d137ee3e4f..2de4e8b0e0 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -51,10 +51,13 @@ IN: regexp.dfa [ condition-states ] 2dip '[ _ _ add-todo-state ] each ; +: ensure-state ( key table -- ) + 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; inline + :: new-transitions ( nfa dfa new-states visited-states -- nfa dfa ) new-states [ nfa dfa ] [ pop :> state - state dfa transitions>> maybe-initialize-key + state dfa transitions>> ensure-state state nfa find-transitions [| trans | state trans nfa find-closure :> new-state diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 9fcadc4008..70281aa798 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -102,8 +102,10 @@ MEMO: simple-category-table ( -- table ) { CHAR: s dotall } } ; +ERROR: nonexistent-option name ; + : ch>option ( ch -- singleton ) - options-assoc at ; + dup options-assoc at [ ] [ nonexistent-option ] ?if ; : option>ch ( option -- string ) options-assoc value-at ; diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 2234386803..1f72fa04ba 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -4,10 +4,6 @@ USING: regexp tools.test kernel sequences regexp.parser regexp.private eval strings multiline accessors ; IN: regexp-tests -\ must-infer -\ compile-regexp must-infer -\ matches? must-infer - [ f ] [ "b" "a*" matches? ] unit-test [ t ] [ "" "a*" matches? ] unit-test [ t ] [ "a" "a*" matches? ] unit-test @@ -262,11 +258,11 @@ IN: regexp-tests ! Comment inside a regular expression [ t ] [ "ac" "a(?#boo)c" matches? ] unit-test -[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test +[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval( -- ) ] unit-test -[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test +[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval( -- ) ] unit-test -[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test +[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval( -- ) ] unit-test [ "ab" ] [ "ab" "(a|ab)(bc)?" first-match >string ] unit-test [ "abc" ] [ "abc" "(a|ab)(bc)?" first-match >string ] unit-test diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor index 3c33ae8846..f452e3d24a 100644 --- a/basis/regexp/transition-tables/transition-tables.factor +++ b/basis/regexp/transition-tables/transition-tables.factor @@ -11,12 +11,7 @@ TUPLE: transition-table transitions start-state final-states ; H{ } clone >>transitions H{ } clone >>final-states ; -: maybe-initialize-key ( key hashtable -- ) - ! Why do we have to do this? - 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; - :: (set-transition) ( from to obj hash -- ) - to condition? [ to hash maybe-initialize-key ] unless from hash at [ [ to obj ] dip set-at ] [ to obj associate from hash set-at ] if* ; @@ -25,7 +20,6 @@ TUPLE: transition-table transitions start-state final-states ; transitions>> (set-transition) ; :: (add-transition) ( from to obj hash -- ) - to hash maybe-initialize-key from hash at [ [ to obj ] dip push-at ] [ to 1vector obj associate from hash set-at ] if* ; diff --git a/basis/see/see-docs.factor b/basis/see/see-docs.factor index 6d51b42a86..b2e99843c7 100644 --- a/basis/see/see-docs.factor +++ b/basis/see/see-docs.factor @@ -13,7 +13,12 @@ HELP: synopsis* HELP: see { $values { "defspec" "a definition specifier" } } -{ $contract "Prettyprints a definition." } ; +{ $contract "Prettyprints a definition." } +{ $examples + "A word:" { $code "\\ append see" } + "A method:" { $code "USE: arrays" "M\\ array length see" } + "A help article:" { $code "USE: help.topics" "\"help\" >link see" } +} ; HELP: see-methods { $values { "word" "a " { $link generic } " or a " { $link class } } } diff --git a/basis/see/see-tests.factor b/basis/see/see-tests.factor new file mode 100644 index 0000000000..3f11ec987e --- /dev/null +++ b/basis/see/see-tests.factor @@ -0,0 +1,11 @@ +IN: see.tests +USING: see tools.test io.streams.string math ; + +CONSTANT: test-const 10 +[ "IN: see.tests\nCONSTANT: test-const 10 inline\n" ] +[ [ \ test-const see ] with-string-writer ] unit-test + +ALIAS: test-alias + + +[ "USING: math ;\nIN: see.tests\nALIAS: test-alias + inline\n" ] +[ [ \ test-alias see ] with-string-writer ] unit-test diff --git a/basis/see/see.factor b/basis/see/see.factor index 32f49499db..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 ; +prettyprint.sections sequences sets sorting strings summary words +words.symbol words.constant words.alias ; IN: see GENERIC: synopsis* ( defspec -- ) @@ -29,8 +29,16 @@ GENERIC: see* ( defspec -- ) : comment. ( text -- ) H{ { font-style italic } } styled-text ; +GENERIC: print-stack-effect? ( word -- ? ) + +M: parsing-word print-stack-effect? drop f ; +M: symbol print-stack-effect? drop f ; +M: constant print-stack-effect? drop f ; +M: alias print-stack-effect? drop f ; +M: word print-stack-effect? drop t ; + : stack-effect. ( word -- ) - [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and + [ print-stack-effect? ] [ stack-effect ] bi and [ effect>string comment. ] when* ; ] with-use ; -M: method-spec see* - first2 method see* ; - GENERIC: see-class* ( word -- ) M: union-class see-class* diff --git a/basis/smtp/authors.txt b/basis/smtp/authors.txt index 159b1e91e9..ad5e36ed58 100644 --- a/basis/smtp/authors.txt +++ b/basis/smtp/authors.txt @@ -1,3 +1,5 @@ Elie Chaftari Dirk Vleugels Slava Pestov +Doug Coleman +Daniel Ehrenberg diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor index 5d7791292b..dbff4fd214 100644 --- a/basis/smtp/server/server.factor +++ b/basis/smtp/server/server.factor @@ -36,6 +36,7 @@ SYMBOL: data-mode : process ( -- ) read-crlf { + { [ dup not ] [ f ] } { [ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ] [ "220 and..?\r\n" write flush t ] diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index 453f4009e2..0b13113427 100644 --- a/basis/smtp/smtp-docs.factor +++ b/basis/smtp/smtp-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel quotations help.syntax help.markup -io.sockets strings calendar ; +io.sockets strings calendar io.encodings.utf8 ; IN: smtp HELP: smtp-domain @@ -41,7 +41,9 @@ HELP: email { { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." } { { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." } { { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." } - { { $slot "subject" } " The subject of the e-mail. A string." } + { { $slot "subject" } "The subject of the e-mail. A string." } + { { $slot "content-type" } { "The MIME type of the body. A string, default is " { $snippet "text/plain" } "." } } + { { $slot "encoding" } { "An encoding to send the body as. Default is " { $link utf8 } "." } } { { $slot "body" } " The body of the e-mail. A string." } } "The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional." diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index 8a9107b905..b8df0b7b5b 100644 --- a/basis/smtp/smtp-tests.factor +++ b/basis/smtp/smtp-tests.factor @@ -4,8 +4,6 @@ namespaces logging accessors assocs sorting smtp.private concurrency.promises system ; IN: smtp.tests -\ send-email must-infer - { 0 0 } [ [ ] with-smtp-connection ] must-infer-as [ "hello\nworld" validate-address ] must-fail @@ -16,7 +14,7 @@ IN: smtp.tests [ { "hello" "." "world" } validate-message ] must-fail [ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [ - "hello\nworld" [ send-body ] with-string-writer + T{ email { body "hello\nworld" } } [ send-body ] with-string-writer ] unit-test [ { "500 syntax error" } check-response ] @@ -51,7 +49,7 @@ IN: smtp.tests [ { { "Content-Transfer-Encoding" "base64" } - { "Content-Type" "Text/plain; charset=utf-8" } + { "Content-Type" "text/plain; charset=UTF-8" } { "From" "Doug " } { "MIME-Version" "1.0" } { "Subject" "Factor rules" } diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 03b9d8af11..83457defa5 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,12 +1,12 @@ -! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, -! Slava Pestov, Doug Coleman. +! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels, +! Slava Pestov, Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays namespaces make io io.encodings.string -io.encodings.utf8 io.timeouts io.sockets io.sockets.secure -io.encodings.ascii kernel logging sequences combinators -splitting assocs strings math.order math.parser random system -calendar summary calendar.format accessors sets hashtables -base64 debugger classes prettyprint io.crlf ; +USING: arrays namespaces make io io.encodings io.encodings.string +io.encodings.utf8 io.encodings.iana io.encodings.binary +io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf +kernel logging sequences combinators splitting assocs strings +math.order math.parser random system calendar summary calendar.format +accessors sets hashtables base64 debugger classes prettyprint words ; IN: smtp SYMBOL: smtp-domain @@ -44,6 +44,8 @@ TUPLE: email { cc array } { bcc array } { subject string } + { content-type string initial: "text/plain" } + { encoding word initial: utf8 } { body string } ; : ( -- email ) email new ; inline @@ -85,9 +87,10 @@ M: message-contains-dot summary ( obj -- string ) "." over member? [ message-contains-dot ] when ; -: send-body ( body -- ) - utf8 encode - >base64-lines write crlf +: send-body ( email -- ) + binary encode-output + [ body>> ] [ encoding>> ] bi encode >base64-lines write + ascii encode-output crlf "." command ; : quit ( -- ) @@ -162,9 +165,8 @@ M: plain-auth send-auth : encode-header ( string -- string' ) dup aux>> [ - "=?utf-8?B?" - swap utf8 encode >base64 - "?=" 3append + utf8 encode >base64 + "=?utf-8?B?" "?=" surround ] when ; ERROR: invalid-header-string string ; @@ -195,24 +197,23 @@ ERROR: invalid-header-string string ; ! This could be much smarter. " " split1-last swap or "<" ?head drop ">" ?tail drop ; -: utf8-mime-header ( -- alist ) - { - { "MIME-Version" "1.0" } - { "Content-Transfer-Encoding" "base64" } - { "Content-Type" "Text/plain; charset=utf-8" } - } ; +: email-content-type ( email -- content-type ) + [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ; -: email>headers ( email -- hashtable ) +: email>headers ( email -- assoc ) [ + now timestamp>rfc822 "Date" set + message-id "Message-Id" set + "1.0" "MIME-Version" set + "base64" "Content-Transfer-Encoding" set { [ from>> "From" set ] [ to>> ", " join "To" set ] [ cc>> ", " join [ "Cc" set ] unless-empty ] [ subject>> "Subject" set ] + [ email-content-type "Content-Type" set ] } cleave - now timestamp>rfc822 "Date" set - message-id "Message-Id" set - ] { } make-assoc utf8-mime-header append ; + ] { } make-assoc ; : (send-email) ( headers email -- ) [ @@ -227,7 +228,7 @@ ERROR: invalid-header-string string ; data get-ok swap write-headers crlf - body>> send-body get-ok + send-body get-ok quit get-ok ] with-smtp-connection ; diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index cc89d497e7..beb378d4bd 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -6,19 +6,21 @@ IN: sorting.slots HELP: compare-slots { $values - { "sort-specs" "a sequence of accessors ending with a comparator" } - { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } + { "obj1" object } + { "obj2" object } + { "sort-specs" "a sequence of accessors ending with a comparator" } + { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } } { $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ; -HELP: sort-by-slots +HELP: sort-by { $values { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" } - { "sortedseq" sequence } + { "seq'" sequence } } { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." } { $examples - "Sort by slot c, then b descending:" + "Sort by slot a, then b descending:" { $example "USING: accessors math.order prettyprint sorting.slots ;" "IN: scratchpad" @@ -27,32 +29,18 @@ HELP: sort-by-slots " T{ sort-me f 2 3 } T{ sort-me f 3 2 }" " T{ sort-me f 4 3 } T{ sort-me f 2 1 }" "}" - "{ { a>> <=> } { b>> >=< } } sort-by-slots ." + "{ { a>> <=> } { b>> >=< } } sort-by ." "{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}" } } ; -HELP: split-by-slots -{ $values - { "accessor-seqs" "a sequence of sequences of tuple accessors" } - { "quot" quotation } -} -{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ; - -HELP: sort-by -{ $values - { "seq" sequence } { "sort-seq" "a sequence of comparators" } - { "sortedseq" sequence } -} -{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ; - ARTICLE: "sorting.slots" "Sorting by slots" "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl "Comparing two objects by a sequence of slots:" { $subsection compare-slots } "Sorting a sequence of tuples by a slot/comparator pairs:" -{ $subsection sort-by-slots } -"Sorting a sequence by a sequence of comparators:" -{ $subsection sort-by } ; +{ $subsection sort-by } +{ $subsection sort-keys-by } +{ $subsection sort-values-by } ; ABOUT: "sorting.slots" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index 83900461c3..5ebd4438fe 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -24,7 +24,7 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots + } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test [ @@ -42,43 +42,14 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots + } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by ] unit-test -[ - { - { - T{ sort-test { a 1 } { b 1 } { c 10 } } - T{ sort-test { a 1 } { b 1 } { c 11 } } - } - { T{ sort-test { a 1 } { b 3 } { c 9 } } } - { - T{ sort-test { a 2 } { b 5 } { c 3 } } - T{ sort-test { a 2 } { b 5 } { c 2 } } - } - } -] [ - { - T{ sort-test f 1 3 9 } - T{ sort-test f 1 1 10 } - T{ sort-test f 1 1 11 } - T{ sort-test f 2 5 3 } - T{ sort-test f 2 5 2 } - } - { { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep - [ but-last-slice ] map split-by-slots [ >array ] map -] unit-test - -: split-test ( seq -- seq' ) - { { a>> } { b>> } } split-by-slots ; - -[ split-test ] must-infer +[ { } ] +[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test [ { } ] -[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test - -[ { } ] -[ { } { } sort-by-slots ] unit-test +[ { } { } sort-by ] unit-test [ { @@ -97,55 +68,7 @@ TUPLE: tuple2 d ; T{ sort-test f 6 f f T{ tuple2 f 3 } } T{ sort-test f 5 f f T{ tuple2 f 3 } } T{ sort-test f 6 f f T{ tuple2 f 2 } } - } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots -] unit-test - -[ - { - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 1 } } } - } - } - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 2 } } } - } - } - { - T{ sort-test - { a 5 } - { tuple2 T{ tuple2 { d 3 } } } - } - } - { - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 3 } } } - } - T{ sort-test - { a 6 } - { tuple2 T{ tuple2 { d 3 } } } - } - } - { - T{ sort-test - { a 5 } - { tuple2 T{ tuple2 { d 4 } } } - } - } - } -] [ - { - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } } - T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } } - T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } } - } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map + } { { tuple2>> d>> <=> } { a>> <=> } } sort-by ] unit-test @@ -159,3 +82,15 @@ TUPLE: tuple2 d ; { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } } { length-test<=> <=> } sort-by ] unit-test + +[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ] +[ + { { 3 2 } { 1 2 } { 0 1 } { 1 1 } } + { length-test<=> <=> } sort-keys-by +] unit-test + +[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ] +[ + { { 3 2 } { 1 2 } { 0 1 } { 1 1 } } + { length-test<=> <=> } sort-values-by +] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index efec960c27..e3b4bc88ca 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -1,45 +1,28 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.short-circuit fry kernel macros math.order -sequences words sorting sequences.deep assocs splitting.monotonic -math ; +USING: arrays fry kernel math.order sequences sorting ; IN: sorting.slots -/f ) + execute( obj1 obj2 -- <=> ) dup +eq+ eq? [ drop f ] when ; -: short-circuit-comparator ( obj1 obj2 word -- comparator/? ) - execute dup +eq+ eq? [ drop f ] when ; inline +: execute-accessor ( obj1 obj2 word -- obj1' obj2' ) + '[ _ execute( tuple -- value ) ] bi@ ; -: slot-comparator ( seq -- quot ) - [ - but-last-slice - [ '[ [ _ execute ] bi@ ] ] map concat - ] [ - peek - '[ @ _ short-circuit-comparator ] - ] bi ; - -PRIVATE> - -MACRO: compare-slots ( sort-specs -- <=> ) +: compare-slots ( obj1 obj2 sort-specs -- <=> ) #! sort-spec: { accessors comparator } - [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; + [ + dup array? [ + unclip-last-slice + [ [ execute-accessor ] each ] dip + ] when execute-comparator + ] with with map-find drop +eq+ or ; -MACRO: sort-by-slots ( sort-specs -- quot ) - '[ [ _ compare-slots ] sort ] ; +: sort-by-with ( seq sort-specs quot -- seq' ) + swap '[ _ bi@ _ compare-slots ] sort ; inline -MACRO: compare-seq ( seq -- quot ) - [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; +: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ; -MACRO: sort-by ( sort-seq -- quot ) - '[ [ _ compare-seq ] sort ] ; +: sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ; -MACRO: sort-keys-by ( sort-seq -- quot ) - '[ [ first ] bi@ _ compare-seq ] sort ; - -MACRO: sort-values-by ( sort-seq -- quot ) - '[ [ second ] bi@ _ compare-seq ] sort ; - -MACRO: split-by-slots ( accessor-seqs -- quot ) - [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map - '[ [ _ 2&& ] slice monotonic-slice ] ; +: sort-values-by ( seq sort-seq -- seq' ) [ second ] sort-by-with ; diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 9e867f4fbb..338b052316 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -1,10 +1,9 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! 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 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 @@ -121,19 +120,13 @@ M: object apply-object push-literal ; : infer-r> ( n -- ) consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; -: undo-infer ( -- ) - recorded get [ f "inferred-effect" set-word-prop ] each ; - -: (consume/produce) ( effect -- inputs outputs ) - [ in>> length consume-d ] [ out>> length produce-d ] bi ; - : consume/produce ( effect quot: ( inputs outputs -- ) -- ) - '[ (consume/produce) @ ] + '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ] [ terminated?>> [ terminate ] when ] bi ; inline -: infer-word-def ( word -- ) - [ specialized-def ] [ add-recursive-state ] bi infer-quot ; +: apply-word/effect ( word effect -- ) + swap '[ _ #call, ] consume/produce ; : end-infer ( -- ) meta-d clone #return, ; @@ -141,56 +134,20 @@ M: object apply-object push-literal ; : required-stack-effect ( word -- effect ) dup stack-effect [ ] [ missing-effect ] ?if ; -: check-effect ( word effect -- ) - over required-stack-effect 2dup effect<= - [ 3drop ] [ effect-error ] if ; - -: finish-word ( word -- ) - [ current-effect check-effect ] - [ recorded get push ] - [ t "inferred-effect" set-word-prop ] - tri ; - -: cannot-infer-effect ( word -- * ) - "cannot-infer" word-prop rethrow ; - -: maybe-cannot-infer ( word quot -- ) - [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline - -: infer-word ( word -- effect ) - [ - [ - init-inference - init-known-values - stack-visitor off - dependencies off - generic-dependencies off - [ infer-word-def end-infer ] - [ finish-word ] - [ stack-effect ] - tri - ] with-scope - ] maybe-cannot-infer ; - -: apply-word/effect ( word effect -- ) - swap '[ _ #call, ] consume/produce ; - -: call-recursive-word ( word -- ) - dup required-stack-effect apply-word/effect ; - -: cached-infer ( word -- ) - dup stack-effect apply-word/effect ; +: infer-word ( word -- ) + { + { [ dup macro? ] [ do-not-compile ] } + { [ dup "no-compile" word-prop ] [ do-not-compile ] } + [ dup required-stack-effect apply-word/effect ] + } cond ; : with-infer ( quot -- effect visitor ) [ - [ - V{ } clone recorded set - init-inference - init-known-values - stack-visitor off - call - end-infer - current-effect - stack-visitor get - ] [ ] [ undo-infer ] cleanup + init-inference + init-known-values + stack-visitor off + call + end-infer + current-effect + stack-visitor get ] with-scope ; inline 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 bd1f7c73c3..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 ; +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>> [ ] [ @@ -54,6 +76,8 @@ M: quotation cached-effect \ call-effect-slow [ call-effect-slow>quot ] 1 define-transform +\ call-effect-slow t "no-compile" set-word-prop + : call-effect-fast ( quot effect inline-cache -- ) 2over call-effect-unsafe? [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ] @@ -71,11 +95,13 @@ M: quotation cached-effect ] ] 0 define-transform +\ call-effect t "no-compile" set-word-prop + : execute-effect-slow ( word 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? @@ -93,3 +119,5 @@ M: quotation cached-effect inline-cache new '[ _ _ execute-effect-ic ] ; \ execute-effect [ execute-effect>quot ] 1 define-transform + +\ execute-effect t "no-compile" set-word-prop \ No newline at end of file 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 5b314a3154..6a67b815cd --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -3,10 +3,9 @@ sequences.private words ; IN: stack-checker.errors HELP: literal-expected -{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } -{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } +{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } { $examples - "In this example, words calling " { $snippet "literal-expected-example" } " will compile, even if " { $snippet "literal-expected-example" } " does not compile itself:" + "In this example, words calling " { $snippet "literal-expected-example" } " will have a static stac keffect, even if " { $snippet "literal-expected-example" } " does not:" { $code ": literal-expected-example ( quot -- )" " [ call ] [ call ] bi ; inline" @@ -16,10 +15,8 @@ HELP: literal-expected HELP: unbalanced-branches-error { $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } } { $description "Throws an " { $link unbalanced-branches-error } "." } -{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height." } -{ $notes "Conditionals with variable stack effects are considered to be bad style and should be avoided since they do not compile." -$nl -"If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } +{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height. See " { $link "inference-branches" } " for details." } +{ $notes "If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } { $examples { $code ": unbalanced-branches-example ( a b c -- )" @@ -86,25 +83,27 @@ HELP: inconsistent-recursive-call-error } } ; -ARTICLE: "inference-errors" "Inference warnings and errors" -"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "." -$nl -"Main wrapper for all inference warnings and errors:" -{ $subsection inference-error } -"Inference warnings:" +ARTICLE: "inference-errors" "Stack checker errors" +"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 } -"Inference errors:" -{ $subsection recursive-quotation-error } -{ $subsection unbalanced-branches-error } +"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" { $subsection effect-error } -{ $subsection missing-effect } -"Inference errors for inline recursive words:" +"Error thrown when branches have incompatible stack effects (see " { $link "inference-branches" } "):" +{ $subsection unbalanced-branches-error } +"Inference errors for inline recursive words (see " { $link "inference-recursive-combinators" } "):" { $subsection undeclared-recursion-error } { $subsection diverging-recursion-error } { $subsection unbalanced-recursion-error } { $subsection inconsistent-recursive-call-error } -"Retain stack usage errors:" +"More obscure errors that are unlikely to arise in ordinary code:" +{ $subsection recursive-quotation-error } { $subsection too-many->r } -{ $subsection too-many-r> } ; +{ $subsection too-many-r> } +{ $subsection missing-effect } ; ABOUT: "inference-errors" diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 07c26ad100..b1071df708 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -1,83 +1,38 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generic sequences io words arrays summary effects -continuations assocs accessors namespaces compiler.errors -stack-checker.values stack-checker.recursive-state ; +USING: kernel stack-checker.values ; IN: stack-checker.errors -: pretty-word ( word -- word' ) - dup method-body? [ "method-generic" word-prop ] when ; +TUPLE: inference-error ; -TUPLE: inference-error error type word ; +ERROR: do-not-compile < inference-error word ; -M: inference-error compiler-error-type type>> ; +ERROR: literal-expected < inference-error what ; -: (inference-error) ( ... class type -- * ) - [ boa ] dip - recursive-state get word>> - \ inference-error boa rethrow ; inline +ERROR: unbalanced-branches-error < inference-error branches quots ; -: inference-error ( ... class -- * ) - +error+ (inference-error) ; inline +ERROR: too-many->r < inference-error ; -: inference-warning ( ... class -- * ) - +warning+ (inference-error) ; inline +ERROR: too-many-r> < inference-error ; -TUPLE: literal-expected what ; +ERROR: missing-effect < inference-error word ; -: literal-expected ( what -- * ) \ literal-expected inference-warning ; +ERROR: effect-error < inference-error inferred declared ; -M: object (literal) "literal value" literal-expected ; +ERROR: recursive-quotation-error < inference-error quot ; -TUPLE: unbalanced-branches-error branches quots ; +ERROR: undeclared-recursion-error < inference-error word ; -: unbalanced-branches-error ( branches quots -- * ) - \ unbalanced-branches-error inference-error ; +ERROR: diverging-recursion-error < inference-error word ; -TUPLE: too-many->r ; +ERROR: unbalanced-recursion-error < inference-error word height ; -: too-many->r ( -- * ) \ too-many->r inference-error ; +ERROR: inconsistent-recursive-call-error < inference-error word ; -TUPLE: too-many-r> ; +ERROR: unknown-primitive-error < inference-error ; -: too-many-r> ( -- * ) \ too-many-r> inference-error ; +ERROR: transform-expansion-error < inference-error word error ; -TUPLE: missing-effect word ; +ERROR: bad-declaration-error < inference-error declaration ; -: missing-effect ( word -- * ) - pretty-word \ missing-effect inference-error ; - -TUPLE: effect-error word inferred declared ; - -: effect-error ( word inferred declared -- * ) - \ effect-error inference-error ; - -TUPLE: recursive-quotation-error quot ; - -: recursive-quotation-error ( word -- * ) - \ recursive-quotation-error inference-error ; - -TUPLE: undeclared-recursion-error word ; - -: undeclared-recursion-error ( word -- * ) - \ undeclared-recursion-error inference-error ; - -TUPLE: diverging-recursion-error word ; - -: diverging-recursion-error ( word -- * ) - \ diverging-recursion-error inference-error ; - -TUPLE: unbalanced-recursion-error word height ; - -: unbalanced-recursion-error ( word height -- * ) - \ unbalanced-recursion-error inference-error ; - -TUPLE: inconsistent-recursive-call-error word ; - -: inconsistent-recursive-call-error ( word -- * ) - \ inconsistent-recursive-call-error inference-error ; - -TUPLE: unknown-primitive-error ; - -: unknown-primitive-error ( -- * ) - \ unknown-primitive-error inference-warning ; +M: object (literal) "literal value" literal-expected ; \ No newline at end of file diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 9dc82339b5..5be5722c23 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -1,67 +1,62 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel prettyprint io debugger sequences assocs stack-checker.errors summary effects ; IN: stack-checker.errors.prettyprint -M: inference-error error-help error>> error-help ; +M: literal-expected summary + what>> "Got a computed value where a " " was expected" surround ; -M: inference-error error. - [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; +M: literal-expected error. summary print ; -M: literal-expected error. - "Got a computed value where a " write what>> write " was expected" print ; +M: unbalanced-branches-error summary + drop "Unbalanced branches" ; M: unbalanced-branches-error error. - "Unbalanced branches:" print + dup summary print [ quots>> ] [ branches>> [ length ] { } assoc>map ] bi zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; M: too-many->r summary - drop - "Quotation pushes elements on retain stack without popping them" ; + drop "Quotation pushes elements on retain stack without popping them" ; M: too-many-r> summary - drop - "Quotation pops retain stack elements which it did not push" ; + drop "Quotation pops retain stack elements which it did not push" ; -M: missing-effect error. - "The word " write - word>> pprint - " must declare a stack effect" print ; +M: missing-effect summary + drop "Missing stack effect declaration" ; -M: effect-error error. - "Stack effects of the word " write - [ word>> pprint " do not match." print ] - [ "Inferred: " write inferred>> . ] - [ "Declared: " write declared>> . ] tri ; +M: effect-error summary + drop "Stack effect declaration is wrong" ; -M: recursive-quotation-error error. - "The quotation " write - quot>> pprint - " calls itself." print - "Stack effect inference is undecidable when quotation-level recursion is permitted." print ; +M: recursive-quotation-error summary + drop "Recursive quotation" ; -M: undeclared-recursion-error error. - "The inline recursive word " write - word>> pprint - " must be declared recursive" print ; +M: undeclared-recursion-error summary + word>> name>> + "The inline recursive word " " must be declared recursive" surround ; -M: diverging-recursion-error error. - "The recursive word " write - word>> pprint - " digs arbitrarily deep into the stack" print ; +M: diverging-recursion-error summary + word>> name>> + "The recursive word " " digs arbitrarily deep into the stack" surround ; -M: unbalanced-recursion-error error. - "The recursive word " write - word>> pprint - " leaves with the stack having the wrong height" print ; +M: unbalanced-recursion-error summary + word>> name>> + "The recursive word " " leaves with the stack having the wrong height" surround ; -M: inconsistent-recursive-call-error error. - "The recursive word " write - word>> pprint - " calls itself with a different set of quotation parameters than were input" print ; +M: inconsistent-recursive-call-error summary + word>> name>> + "The recursive word " + " calls itself with a different set of quotation parameters than were input" surround ; -M: unknown-primitive-error error. - drop - "Cannot determine stack effect statically" print ; +M: unknown-primitive-error summary + word>> name>> "The " " word cannot be called from optimized words" surround ; + +M: transform-expansion-error summary + word>> name>> "Macro expansion of " " threw an error" surround ; + +M: transform-expansion-error error. + [ summary print ] [ error>> error. ] bi ; + +M: do-not-compile summary + word>> name>> "Cannot compile call to " prepend ; \ 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 c55e69a8a2..f6f94bf20d 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, ; @@ -142,7 +147,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 ; @@ -216,10 +221,19 @@ M: object infer-call* dispatch exit load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect alien-callback -} [ t "special" set-word-prop ] each +} [ + [ t "special" set-word-prop ] + [ t "no-compile" set-word-prop ] bi +] each -{ call execute dispatch load-locals get-local drop-locals } -[ t "no-compile" set-word-prop ] each +! Exceptions to the above +\ curry f "no-compile" set-word-prop +\ compose f "no-compile" set-word-prop + +! More words not to compile +\ call t "no-compile" set-word-prop +\ execute t "no-compile" set-word-prop +\ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) dup called-dependency depends-on @@ -229,14 +243,11 @@ M: object infer-call* { [ dup "primitive" word-prop ] [ infer-primitive ] } { [ dup "transform-quot" word-prop ] [ apply-transform ] } { [ dup "macro" word-prop ] [ apply-macro ] } - { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] } - { [ dup "inferred-effect" word-prop ] [ cached-infer ] } { [ dup local? ] [ infer-local-reader ] } { [ dup local-reader? ] [ infer-local-reader ] } { [ dup local-writer? ] [ infer-local-writer ] } { [ dup local-word? ] [ infer-local-word ] } - { [ dup recursive-word? ] [ call-recursive-word ] } - [ dup infer-word apply-word/effect ] + [ infer-word ] } cond ; : define-primitive ( word inputs outputs -- ) @@ -279,14 +290,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 @@ -300,9 +308,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 @@ -460,9 +465,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 @@ -476,9 +481,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 @@ -593,7 +598,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 @@ -663,3 +668,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/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor index 9abfb1fcd5..345e69e653 100644 --- a/basis/stack-checker/recursive-state/recursive-state.factor +++ b/basis/stack-checker/recursive-state/recursive-state.factor @@ -1,38 +1,19 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays sequences kernel sequences assocs -namespaces stack-checker.recursive-state.tree ; +USING: accessors kernel namespaces stack-checker.recursive-state.tree ; IN: stack-checker.recursive-state -TUPLE: recursive-state word words quotations inline-words ; +TUPLE: recursive-state quotations inline-words ; -: prepare-recursive-state ( word rstate -- rstate ) - swap >>word - f >>quotations - f >>inline-words ; inline +: ( -- state ) recursive-state new ; inline -: initial-recursive-state ( word -- state ) - recursive-state new - f >>words - prepare-recursive-state ; inline + recursive-state set-global -f initial-recursive-state recursive-state set-global - -: add-recursive-state ( word -- rstate ) - recursive-state get clone - [ word>> dup ] keep [ store ] change-words - prepare-recursive-state ; - -: add-local-quotation ( recursive-state quot -- rstate ) +: add-local-quotation ( rstate quot -- rstate ) swap clone [ dupd store ] change-quotations ; : add-inline-word ( word label -- rstate ) - swap recursive-state get clone - [ store ] change-inline-words ; - -: recursive-word? ( word -- ? ) - recursive-state get 2dup word>> eq? - [ 2drop t ] [ words>> lookup ] if ; + swap recursive-state get clone [ store ] change-inline-words ; : inline-recursive-label ( word -- label/f ) recursive-state get inline-words>> lookup ; diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 28090918bb..7d18482bff 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -4,38 +4,54 @@ stack-checker.backend stack-checker.branches stack-checker.errors stack-checker.transforms -stack-checker.state ; +stack-checker.state +continuations ; IN: stack-checker ARTICLE: "inference-simple" "Straight-line stack effects" -"The simplest case to look at is that of a quotation which does not have any branches or recursion, and just pushes literals and calls words, each of which has a known stack effect." +"The simplest case is when a piece of code does not have any branches or recursion, and just pushes literals and calls words." $nl -"Stack effect inference works by stepping through the quotation, while maintaining a \"shadow stack\" which tracks stack height at the current position in the quotation. Initially, the shadow stack is empty. If a word is encountered which expects more values than there are on the shadow stack, a global counter is incremented. This counter keeps track of the number of inputs the quotation expects on the stack. When inference is done, this counter, together with the final height of the shadow stack, gives the inferred stack effect." -{ $subsection d-in } -{ $subsection meta-d } -"When a literal is encountered, it is simply pushed on the shadow stack. For example, the stack effect of the following quotation is inferred by pushing all three literals on the shadow stack, then taking the value of " { $link d-in } " and the length of " { $link meta-d } ":" +"Pushing a literal has stack effect " { $snippet "( -- object )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "." +$nl +"The stack effect of each element in a code snippet is composed. The result is then the stack effect of the snippet." +$nl +"An example:" { $example "[ 1 2 3 ] infer." "( -- object object object )" } -"In the following example, the call to " { $link + } " expects two values on the shadow stack, but only one value is present, the literal which was pushed previously. This increments the " { $link d-in } " counter by one:" -{ $example "[ 2 + ] infer." "( object -- object )" } -"After the call to " { $link + } ", the shadow stack contains a \"computed value placeholder\", since the inferencer has no way to know what the resulting value actually is (in fact it is arbitrary)." ; +"Another example:" +{ $example "[ 2 + ] infer." "( object -- object )" } ; ARTICLE: "inference-combinators" "Combinator stack effects" -"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." -{ $example "[ dup call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } -"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:" -{ $example "[ [ 2 + ] call ] infer." "( object -- object )" } -"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:" -{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" } -"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":" -{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object )" } -"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred." +"If a word, call it " { $snippet "W" } ", calls a combinator, one of the following two conditions must hold:" +{ $list + { "The combinator may be called with a quotation that is either a literal, or built from literals, " { $link curry } " and " { $link compose } "." } + { "The combinator must be called on an input parameter, or be built from input parameters, literals, " { $link curry } " and " { $link compose } ", " { $strong "if" } " the word " { $snippet "W" } " must be declared " { $link POSTPONE: inline } ". Then " { $snippet "W" } " is itself considered to be a combinator, and its callers must satisfy one of these two conditions." } +} +"If neither condition holds, the stack checker throws a " { $link literal-expected } " error, and an escape hatch such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by currying the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "." +{ $heading "Examples" } +{ $subheading "Calling a combinator" } +"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":" +{ $example "[ [ + ] curry map ] infer." "( object object -- object )" } +{ $subheading "Defining an inline combinator" } +"The following word calls a quotation twice; the word is declared " { $link POSTPONE: inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:" +{ $code ": twice ( value quot -- result ) dup compose call ; inline" } +"The following code now passes the stack checker; it would fail were " { $snippet "twice" } " not declared " { $link POSTPONE: inline } ":" +{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( object -- object )" } +{ $subheading "Defining a combinator for unknown quotations" } +"In the next example, " { $link POSTPONE: call( } " must be used because the quotation the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:" +{ $code + "TUPLE: action name quot ;" + ": perform ( value action -- result ) quot>> call( value -- result ) ;" +} +{ $subheading "Passing an unknown quotation to an inline combinator" } +"Suppose we want to write :" +{ $code ": perform ( values action -- results ) quot>> map ;" } +"However this fails to pass the stack checker since there is no guarantee the quotation has the right stack effect for " { $link map } ". It can be wrapped in a new quotation with a declaration:" +{ $code ": perform ( values action -- results )" " quot>> [ call( value -- result ) ] curry map ;" } +{ $heading "Explanation" } +"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." $nl -"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "." -$nl -"Here is an example where the stack effect cannot be inferred:" -{ $code ": foo ( -- n quot ) 0 [ + ] ;" "[ foo reduce ] infer." } -"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":" -{ $example ": foo ( -- n quot ) 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } +"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point." +{ $heading "Limitations" } "Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:" { $example "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." @@ -46,30 +62,25 @@ $nl } ; ARTICLE: "inference-branches" "Branch stack effects" -"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "." +"Conditionals such as " { $link if } " and combinators built on top have the same restrictions as " { $link POSTPONE: inline } " combinators (see " { $link "inference-combinators" } ") with the additional requirement that all branches leave the stack at the same height. If this is not the case, the stack checker throws a " { $link unbalanced-branches-error } "." $nl "If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example," { $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" } "The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ; -ARTICLE: "inference-recursive" "Stack effects of recursive words" -"When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect." +ARTICLE: "inference-recursive-combinators" "Recursive combinator stack effects" +"Most combinators do not call themselves recursively directly; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } ". In these cases, the rules outlined in " { $link "inference-combinators" } " apply." $nl -"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":" -{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." } -"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ; - -ARTICLE: "inference-recursive-combinators" "Recursive combinator inference" -"Most combinators are not explicitly recursive; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } "." -$nl -"Combinators which are recursive require additional care." -$nl -"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "." -$nl -"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:" +"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:" +{ $heading "Input quotation declaration" } +"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:" { $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } "The following is correct:" { $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" } +"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter." +{ $heading "Data flow restrictions" } +"The stack checker does not trace data flow in two instances." +$nl "An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:" { $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } "However a small change can be made:" @@ -80,23 +91,48 @@ $nl "[ [ 5 ] t foo ] infer." } ; -ARTICLE: "inference" "Stack effect inference" -"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." -$nl -"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:" -{ $subsection infer. } -"Instead of printing the inferred information, it can be returned as objects on the stack:" +ARTICLE: "tools.inference" "Stack effect tools" +{ $link "inference" } " can be used interactively to print stack effects of quotations without running them. It can also be used from " { $link "combinators.smart" } "." { $subsection infer } -"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "." +{ $subsection infer. } +"There are also some words for working with " { $link effect } " instances. Getting a word's declared stack effect:" +{ $subsection stack-effect } +"Converting a stack effect to a string form:" +{ $subsection effect>string } +"Comparing effects:" +{ $subsection effect-height } +{ $subsection effect<= } +{ $subsection effect= } +"The class of stack effects:" +{ $subsection effect } +{ $subsection effect? } ; + +ARTICLE: "inference-escape" "Stack effect checking escape hatches" +"In a static checking regime, sometimes it is necessary to step outside the boundaries and run some code which cannot be statically checked; perhaps this code is constructed at run-time. There are two ways to get around the static stack checker." $nl -"The following articles describe the implementation of the stack effect inference algorithm:" +"If the stack effect of a word or quotation is known, but the word or quotation itself is not, " { $link POSTPONE: execute( } " or " { $link POSTPONE: call( } " can be used. See " { $link "call" } " for details." +$nl +"If the stack effect is not known, the code being called cannot manipulate the datastack directly. Instead, it must reflect the datastack into an array:" +{ $subsection with-datastack } +"The surrounding code has a static stack effect since " { $link with-datastack } " has one. However, the array passed in as input may be transformed arbitrarily by calling this combinator." ; + +ARTICLE: "inference" "Stack effect checking" +"The " { $link "compiler" } " checks the " { $link "effects" } " of words before they can be run. This ensures that words take exactly the number of inputs and outputs that the programmer declares in source." +$nl +"Words that do not pass the stack checker are rejected and cannot be run, and so essentially this defines a very simple and permissive type system that nevertheless catches some invalid programs and enables compiler optimizations." +$nl +"If a word's stack effect cannot be inferred, a compile error is reported. See " { $link "compiler-errors" } "." +$nl +"The following articles describe how different control structures are handled by the stack checker." { $subsection "inference-simple" } -{ $subsection "inference-recursive" } { $subsection "inference-combinators" } { $subsection "inference-recursive-combinators" } { $subsection "inference-branches" } +"Stack checking catches several classes of errors." { $subsection "inference-errors" } -{ $see-also "effects" } ; +"Sometimes code with a dynamic stack effect has to be run." +{ $subsection "inference-escape" } +{ $see-also "effects" "tools.inference" "tools.errors" } ; ABOUT: "inference" @@ -109,7 +145,6 @@ HELP: inference-error "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "." } ; - HELP: infer { $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } } { $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." } @@ -121,11 +156,3 @@ HELP: infer. { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; { infer infer. } related-words - -HELP: forget-errors -{ $description "Removes markers indicating which words do not have stack effects." -$nl -"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." } -{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:" -{ $code "forget-errors" } -"Subsequent invocations of the compiler will consider all words for compilation." } ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 117b6845b8..919cd098f6 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -10,7 +10,7 @@ sequences.private destructors combinators eval locals.backend system compiler.units ; IN: stack-checker.tests -\ infer. must-infer +[ 1234 infer ] must-fail { 0 2 } [ 2 "Hello" ] must-infer-as { 1 2 } [ dup ] must-infer-as @@ -65,11 +65,6 @@ IN: stack-checker.tests { 1 1 } [ simple-recursion-2 ] must-infer-as -: bad-recursion-2 ( obj -- obj ) - dup [ dup first swap second bad-recursion-2 ] [ ] if ; - -[ [ bad-recursion-2 ] infer ] must-fail - : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; @@ -196,94 +191,11 @@ DEFER: blah4 over string? [ 2array throw ] unless ] must-infer-as -! Regression - -! This order of branches works -DEFER: do-crap -: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ; -: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ; -[ [ do-crap ] infer ] must-fail - -! This one does not -DEFER: do-crap* -: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ; -: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ; -[ [ do-crap* ] infer ] must-fail - ! Regression : too-deep ( a b -- c ) dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive { 2 1 } [ too-deep ] must-infer-as -! Error reporting is wrong -MATH: xyz ( a b -- c ) -M: fixnum xyz 2array ; -M: float xyz - [ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ; - -[ [ xyz ] infer ] [ inference-error? ] must-fail-with - -! Doug Coleman discovered this one while working on the -! calendar library -DEFER: A -DEFER: B -DEFER: C - -: A ( a -- ) - dup { - [ drop ] - [ A ] - [ \ A no-method ] - [ dup C A ] - } dispatch ; - -: B ( b -- ) - dup { - [ C ] - [ B ] - [ \ B no-method ] - [ dup B B ] - } dispatch ; - -: C ( c -- ) - dup { - [ A ] - [ C ] - [ \ C no-method ] - [ dup B C ] - } dispatch ; - -{ 1 0 } [ A ] must-infer-as -{ 1 0 } [ B ] must-infer-as -{ 1 0 } [ C ] must-infer-as - -! I found this bug by thinking hard about the previous one -DEFER: Y -: X ( a b -- c d ) dup [ swap Y ] [ ] if ; -: Y ( a b -- c d ) X ; - -{ 2 2 } [ X ] must-infer-as -{ 2 2 } [ Y ] must-infer-as - -! This one comes from UI code -DEFER: #1 -: #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline -: #3 ( a -- ) [ #1 ] #2 ; -: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; -: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; - -[ \ #4 def>> infer ] must-fail -[ [ #1 ] infer ] must-fail - -! Similar -DEFER: bar -: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ; -: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ; - -[ [ foo ] infer ] must-fail - -[ 1234 infer ] must-fail - ! This used to hang [ [ [ dup call ] dup call ] infer ] [ inference-error? ] must-fail-with @@ -311,16 +223,6 @@ DEFER: bar [ [ [ [ drop 3 ] swap call ] dup call ] infer ] [ inference-error? ] must-fail-with -! This form should not have a stack effect - -: bad-recursion-1 ( a -- b ) - dup [ drop bad-recursion-1 5 ] [ ] if ; - -[ [ bad-recursion-1 ] infer ] must-fail - -: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ [ bad-bin ] infer ] must-fail - [ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with ! Regression @@ -333,114 +235,14 @@ DEFER: bar [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail -! Test number protocol -\ bitor must-infer -\ bitand must-infer -\ bitxor must-infer -\ mod must-infer -\ /i must-infer -\ /f must-infer -\ /mod must-infer -\ + must-infer -\ - must-infer -\ * must-infer -\ / must-infer -\ < must-infer -\ <= must-infer -\ > must-infer -\ >= must-infer -\ number= must-infer - -! Test object protocol -\ = must-infer -\ clone must-infer -\ hashcode* must-infer - -! Test sequence protocol -\ length must-infer -\ nth must-infer -\ set-length must-infer -\ set-nth must-infer -\ new must-infer -\ new-resizable must-infer -\ like must-infer -\ lengthen must-infer - -! Test assoc protocol -\ at* must-infer -\ set-at must-infer -\ new-assoc must-infer -\ delete-at must-infer -\ clear-assoc must-infer -\ assoc-size must-infer -\ assoc-like must-infer -\ assoc-clone-like must-infer -\ >alist must-infer { 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as -! Test some random library words -\ 1quotation must-infer -\ string>number must-infer -\ get must-infer - -\ push must-infer -\ append must-infer -\ peek must-infer - -\ reverse must-infer -\ member? must-infer -\ remove must-infer -\ natural-sort must-infer - -\ forget must-infer -\ define-class must-infer -\ define-tuple-class must-infer -\ define-union-class must-infer -\ define-predicate-class must-infer -\ instance? must-infer -\ next-method-quot must-infer - ! Test words with continuations { 0 0 } [ [ drop ] callcc0 ] must-infer-as { 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as { 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as { 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as -\ dispose must-infer - -! Test stream protocol -\ set-timeout must-infer -\ stream-read must-infer -\ stream-read1 must-infer -\ stream-readln must-infer -\ stream-read-until must-infer -\ stream-write must-infer -\ stream-write1 must-infer -\ stream-nl must-infer -\ stream-flush must-infer - -! Test stream utilities -\ lines must-infer -\ contents must-infer - -! Test prettyprinting -\ . must-infer -\ short. must-infer -\ unparse must-infer - -\ describe must-infer -\ error. must-infer - -! Test odds and ends -\ io-thread must-infer - -! Incorrect stack declarations on inline recursive words should -! be caught -: fooxxx ( a b -- c ) over [ foo ] when ; inline -: barxxx ( a b -- c ) fooxxx ; - -[ [ barxxx ] infer ] must-fail - ! A typo { 1 0 } [ { [ ] } dispatch ] must-infer-as @@ -463,7 +265,6 @@ DEFER: deferred-word { 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as - DEFER: an-inline-word : normal-word-3 ( -- ) @@ -503,9 +304,7 @@ ERROR: custom-error ; ] unit-test ! Regression -: missing->r-check ( a -- ) 1 load-locals ; - -[ [ missing->r-check ] infer ] must-fail +[ [ 1 load-locals ] infer ] must-fail ! Corner case [ [ [ f dup ] [ dup ] produce ] infer ] must-fail @@ -513,35 +312,12 @@ ERROR: custom-error ; [ [ [ f dup ] [ ] while ] infer ] must-fail : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive - [ [ erg's-inference-bug ] infer ] must-fail - -: inference-invalidation-a ( -- ) ; -: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline -: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline - -[ 7 ] [ 4 3 inference-invalidation-c ] unit-test - -{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as - -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test - -[ 3 ] [ inference-invalidation-c ] unit-test - -{ 0 1 } [ inference-invalidation-c ] must-infer-as - -GENERIC: inference-invalidation-d ( obj -- ) - -M: object inference-invalidation-d inference-invalidation-c 2drop ; - -\ inference-invalidation-d must-infer - -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test - -[ [ inference-invalidation-d ] infer ] must-fail +FORGET: erg's-inference-bug : bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive [ [ bad-recursion-3 ] infer ] must-fail +FORGET: bad-recursion-3 : bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive [ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail @@ -562,6 +338,8 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ; [ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with +FORGET: unbalanced-retain-usage + DEFER: eee' : ddd' ( ? -- ) [ f eee' ] when ; inline recursive : eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive @@ -587,4 +365,10 @@ DEFER: eee' [ forget-test ] must-infer [ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test -[ forget-test ] must-infer \ No newline at end of file +[ forget-test ] must-infer + +[ [ cond ] infer ] must-fail +[ [ bi ] infer ] must-fail +[ at ] must-infer + +[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor index e18a6f0840..759988a61f 100644 --- a/basis/stack-checker/stack-checker.factor +++ b/basis/stack-checker/stack-checker.factor @@ -16,17 +16,4 @@ M: callable infer ( quot -- effect ) #! Safe to call from inference transforms. infer effect>string print ; -: forget-errors ( -- ) - all-words [ - dup subwords [ f "cannot-infer" set-word-prop ] each - f "cannot-infer" set-word-prop - ] each ; - -: forget-effects ( -- ) - forget-errors - all-words [ - dup subwords [ f "inferred-effect" set-word-prop ] each - f "inferred-effect" set-word-prop - ] each ; - "stack-checker.call-effect" require \ No newline at end of file diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 6ae12dbd0c..a76d302a7e 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -64,6 +64,3 @@ SYMBOL: generic-dependencies : depends-on-generic ( generic class -- ) generic-dependencies get dup [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ; - -! Words we've inferred the stack effect of, for rollback -SYMBOL: recorded diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 0aa3876907..fe0fa08356 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -1,11 +1,16 @@ IN: stack-checker.transforms.tests USING: sequences stack-checker.transforms tools.test math kernel -quotations stack-checker accessors combinators words arrays +quotations stack-checker stack-checker.errors accessors combinators words arrays classes classes.tuple ; +: compose-n ( quot n -- ) "OOPS" throw ; + +<< : compose-n-quot ( word n -- quot' ) >quotation ; -: compose-n ( quot n -- ) compose-n-quot call ; \ compose-n [ compose-n-quot ] 2 define-transform +\ compose-n t "no-compile" set-word-prop +>> + : compose-n-test ( a b c -- x ) 2 \ + compose-n ; [ 6 ] [ 1 2 3 compose-n-test ] unit-test @@ -70,4 +75,11 @@ DEFER: curry-folding-test ( quot -- ) : member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ; [ f ] [ 1.0 member?-test ] unit-test -[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test \ No newline at end of file +[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test + +! Macro expansion should throw its own type of error +: bad-macro ( -- ) ; + +\ bad-macro [ "OOPS" throw ] 0 define-transform + +[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index c2b348f5f1..8113a662d6 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,30 +1,27 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel kernel.private combinators.private -words sequences generic math math.order namespaces make quotations assocs -combinators combinators.short-circuit classes.tuple +words sequences generic math math.order namespaces quotations +assocs combinators combinators.short-circuit classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations locals -generalizations stack-checker.backend stack-checker.state -stack-checker.visitor stack-checker.errors stack-checker.values -stack-checker.recursive-state ; +sequences.private generalizations stack-checker.backend +stack-checker.state stack-checker.visitor stack-checker.errors +stack-checker.values stack-checker.recursive-state ; IN: stack-checker.transforms -: give-up-transform ( word -- ) - { - { [ dup "inferred-effect" word-prop ] [ cached-infer ] } - { [ dup recursive-word? ] [ call-recursive-word ] } - [ dup infer-word apply-word/effect ] - } cond ; +: call-transformer ( word stack quot -- newquot ) + '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ] + [ transform-expansion-error ] + recover ; :: ((apply-transform)) ( word quot values stack rstate -- ) rstate recursive-state - [ stack quot with-datastack first ] with-variable + [ word stack quot call-transformer ] with-variable [ - word inlined-dependency depends-on values [ length meta-d shorten-by ] [ #drop, ] bi rstate infer-quot - ] [ word give-up-transform ] if* ; + ] [ word infer-word ] if* ; : literals? ( values -- ? ) [ literal-value? ] all? ; @@ -36,7 +33,7 @@ IN: stack-checker.transforms [ first literal recursion>> ] tri ] if ((apply-transform)) - ] [ 2drop give-up-transform ] if ; + ] [ 2drop infer-word ] if ; : apply-transform ( word -- ) [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri @@ -54,6 +51,8 @@ IN: stack-checker.transforms ! Combinators \ cond [ cond>quot ] 1 define-transform +\ cond t "no-compile" set-word-prop + \ case [ [ [ no-case ] @@ -66,14 +65,24 @@ IN: stack-checker.transforms ] if-empty ] 1 define-transform +\ case t "no-compile" set-word-prop + \ cleave [ cleave>quot ] 1 define-transform +\ cleave t "no-compile" set-word-prop + \ 2cleave [ 2cleave>quot ] 1 define-transform +\ 2cleave t "no-compile" set-word-prop + \ 3cleave [ 3cleave>quot ] 1 define-transform +\ 3cleave t "no-compile" set-word-prop + \ spread [ spread>quot ] 1 define-transform +\ spread t "no-compile" set-word-prop + \ (call-next-method) [ [ [ "method-class" word-prop ] @@ -85,6 +94,8 @@ IN: stack-checker.transforms ] bi ] 1 define-transform +\ (call-next-method) t "no-compile" set-word-prop + ! Constructors \ boa [ dup tuple-class? [ @@ -95,51 +106,79 @@ IN: stack-checker.transforms ] [ drop f ] if ] 1 define-transform +\ boa t "no-compile" set-word-prop + \ new [ dup tuple-class? [ dup inlined-dependency depends-on - [ - [ all-slots [ initial>> literalize , ] each ] - [ literalize , ] bi - \ boa , - ] [ ] make + [ all-slots [ initial>> literalize ] map ] + [ tuple-layout '[ _ ] ] + bi append ] [ drop f ] if ] 1 define-transform -! Membership testing -CONSTANT: bit-member-max 256 +! Fast at for integer maps +CONSTANT: lookup-table-at-max 256 -: bit-member? ( seq -- ? ) +: lookup-table-at? ( assoc -- ? ) #! Can we use a fast byte array test here? { - [ length 4 > ] - [ [ integer? ] all? ] - [ [ 0 bit-member-max between? ] any? ] + [ assoc-size 4 > ] + [ values [ ] all? ] + [ keys [ integer? ] all? ] + [ keys [ 0 lookup-table-at-max between? ] all? ] } 1&& ; -: bit-member-seq ( seq -- flags ) - [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ; +: lookup-table-seq ( assoc -- table ) + [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; -: bit-member-quot ( seq -- newquot ) - bit-member-seq +: lookup-table-quot ( seq -- newquot ) + lookup-table-seq '[ - _ { - { [ over fixnum? ] [ ?nth 1 eq? ] } - { [ over bignum? ] [ ?nth 1 eq? ] } - [ 2drop f ] - } cond + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup >boolean + ] [ 2drop f f ] if + ] [ 2drop f f ] if ] ; -: member-quot ( seq -- newquot ) - dup bit-member? [ - bit-member-quot - ] [ - dup length 4 <= [ - [ drop f ] swap - [ literalize [ t ] ] { } map>assoc linear-case-quot +: fast-lookup-table-at? ( assoc -- ? ) + values { + [ [ integer? ] all? ] + [ [ 0 254 between? ] all? ] + } 1&& ; + +: fast-lookup-table-seq ( assoc -- table ) + lookup-table-seq [ 255 or ] B{ } map-as ; + +: fast-lookup-table-quot ( seq -- newquot ) + fast-lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup 255 eq? [ drop f f ] [ t ] if + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: at-quot ( assoc -- quot ) + dup lookup-table-at? [ + dup fast-lookup-table-at? [ + fast-lookup-table-quot ] [ - unique [ key? ] curry + lookup-table-quot ] if + ] [ drop f ] if ; + +\ at* [ at-quot ] 1 define-transform + +! Membership testing +: member-quot ( seq -- newquot ) + dup length 4 <= [ + [ drop f ] swap + [ literalize [ t ] ] { } map>assoc linear-case-quot + ] [ + unique [ key? ] curry ] if ; \ member? [ @@ -170,4 +209,4 @@ CONSTANT: bit-member-max 256 \ shuffle [ shuffle-mapping nths-quot -] 1 define-transform \ No newline at end of file +] 1 define-transform 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/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor index 3ea037352c..b0bd5a2ff5 100644 --- a/basis/syndication/syndication-tests.factor +++ b/basis/syndication/syndication-tests.factor @@ -2,9 +2,6 @@ USING: syndication io kernel io.files tools.test io.encodings.binary calendar urls xml.writer ; IN: syndication.tests -\ download-feed must-infer -\ feed>xml must-infer - : load-news-file ( filename -- feed ) #! Load an news syndication file and process it, returning #! it as an feed tuple. diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index a1d7e50594..dbdb69b3e9 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -48,7 +48,7 @@ ARTICLE: "thread-impl" "Thread implementation" { $subsection sleep-queue } ; ARTICLE: "threads" "Lightweight co-operative threads" -"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." +"Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." $nl "Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads." $nl diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index adac84338d..610a664c7b 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -31,7 +31,7 @@ yield [ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with -:: spawn-namespace-test ( -- ) +:: spawn-namespace-test ( -- ? ) [let | p [ ] g [ gensym ] | [ g "x" set diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index f47852aca7..bbd2ac2ca8 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -18,7 +18,7 @@ M: integer some-generic 1+ ; [ 4 ] [ 3 some-generic ] unit-test -[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test +[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test [ 2 ] [ 3 some-generic ] unit-test @@ -33,7 +33,7 @@ M: object another-generic ; \ another-generic watch -[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval ] unit-test +[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval( -- ) ] unit-test [ ] [ \ another-generic reset ] unit-test @@ -43,6 +43,6 @@ GENERIC: blah-generic ( a -- b ) M: string blah-generic ; -{ string blah-generic } watch +[ ] [ M\ string blah-generic watch ] unit-test [ "hi" ] [ "hi" blah-generic ] unit-test diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 8c3d95f2b8..2639d48be2 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -3,7 +3,7 @@ USING: accessors kernel math sorting words parser io summary quotations sequences prettyprint continuations effects definitions compiler.units namespaces assocs tools.walker -tools.time generic inspector fry ; +tools.time generic inspector fry tools.continuations ; IN: tools.annotations GENERIC: reset ( word -- ) @@ -20,9 +20,6 @@ M: word reset f "unannotated-def" set-word-prop ] [ drop ] if ; -M: method-spec reset - first2 method reset ; - ERROR: cannot-annotate-twice word ; word ( obj -- word ) - dup method-spec? [ first2 method ] when ; - : save-unannotated-def ( word -- ) dup def>> "unannotated-def" set-word-prop ; @@ -44,7 +38,7 @@ ERROR: cannot-annotate-twice word ; PRIVATE> : annotate ( word quot -- ) - [ method-spec>word check-annotate-twice ] dip + [ check-annotate-twice ] dip [ over save-unannotated-def (annotate) ] with-compilation-unit ; i i accum push + accum i 1+ full t ] [ - drop f -1 f + f -1 full f ] if* ; : fuzzy ( full short -- indices ) - dup length -rot 0 -rot - [ -rot [ (fuzzy) ] keep swap ] all? 3drop ; + dup [ length 0 ] curry 2dip + [ (fuzzy) ] all? 3drop ; : (runs) ( runs n seq -- runs n ) [ diff --git a/basis/tools/continuations/authors.txt b/basis/tools/continuations/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/continuations/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor new file mode 100644 index 0000000000..8c572f4ae3 --- /dev/null +++ b/basis/tools/continuations/continuations.factor @@ -0,0 +1,156 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +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.single definitions make sbufs tools.crossref ; +IN: tools.continuations + + + +SYMBOL: break-hook + +: break ( -- ) + continuation callstack >>call + break-hook get call( continuation -- continuation' ) + after-break ; + +\ break t "break?" set-word-prop + +GENERIC: add-breakpoint ( quot -- quot' ) + +> (step-into-quot) ] + } cond ; + +\ (step-into-execute) t "step-into?" set-word-prop + +: (step-into-continuation) ( -- ) + continuation callstack >>call break ; + +: (step-into-call-next-method) ( method -- ) + next-method-quot (step-into-quot) ; + +<< { + (step-into-quot) + (step-into-dip) + (step-into-2dip) + (step-into-3dip) + (step-into-if) + (step-into-dispatch) + (step-into-execute) + (step-into-continuation) + (step-into-call-next-method) +} [ t "no-compile" set-word-prop ] each >> + +: 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 + +PRIVATE> + +: continuation-step ( continuation -- continuation' ) + [ + 2dup length = [ nip [ break ] append ] [ + 2dup nth \ break = [ nip ] [ + swap 1+ cut [ break ] glue + ] if + ] if + ] change-frame ; + +: continuation-step-out ( continuation -- continuation' ) + [ nip \ break suffix ] change-frame ; + + +{ + { call [ (step-into-quot) ] } + { dip [ (step-into-dip) ] } + { 2dip [ (step-into-2dip) ] } + { 3dip [ (step-into-3dip) ] } + { execute [ (step-into-execute) ] } + { if [ (step-into-if) ] } + { dispatch [ (step-into-dispatch) ] } + { continuation [ (step-into-continuation) ] } + { (call-next-method) [ (step-into-call-next-method) ] } +} [ "step-into" set-word-prop ] assoc-each + +! Never step into these words +: don't-step-into ( word -- ) + dup [ execute break ] curry "step-into" set-word-prop ; + +{ + >n ndrop >c c> + continue continue-with + stop suspend (spawn) +} [ don't-step-into ] each + +\ break [ break ] "step-into" set-word-prop + +: continuation-step-into ( continuation -- continuation' ) + [ + swap cut [ + swap % + [ \ break , ] [ + unclip { + { [ dup \ break eq? ] [ , ] } + { [ dup quotation? ] [ add-breakpoint , \ break , ] } + { [ dup array? ] [ add-breakpoint , \ break , ] } + { [ dup word? ] [ literalize , \ (step-into-execute) , ] } + [ , \ break , ] + } cond % + ] if-empty + ] [ ] make + ] change-frame ; + +: continuation-current ( continuation -- obj ) + call>> + [ innermost-frame-scan 1+ ] + [ innermost-frame-quot ] bi ?nth ; diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor index f49ac7ea76..9108777554 100644 --- a/basis/tools/crossref/crossref-docs.factor +++ b/basis/tools/crossref/crossref-docs.factor @@ -1,15 +1,57 @@ -USING: help.markup help.syntax words definitions prettyprint ; +USING: help.markup help.syntax words definitions prettyprint +tools.crossref.private math quotations assocs kernel ; IN: tools.crossref -ARTICLE: "tools.crossref" "Cross-referencing tools" +ARTICLE: "tools.crossref" "Definition cross referencing" +"Definitions can answer a sequence of definitions they directly depend on:" +{ $subsection uses } +"An inverted index of the above:" +{ $subsection get-crossref } +"Words to access it:" +{ $subsection usage } +{ $subsection smart-usage } +"Tools for interactive use:" { $subsection usage. } +{ $subsection vocab-uses. } +{ $subsection vocab-usage. } { $see-also "definitions" "words" "see" } ; ABOUT: "tools.crossref" +HELP: uses +{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } +{ $description "Outputs a sequence of definitions directory called by the given definition." } +{ $notes "The sequence might include the definition itself, if it is a recursive word." } +{ $examples + "We can ask the " { $link sq } " word to produce a list of words it calls:" + { $unchecked-example "\ sq uses ." "{ dup * }" } +} ; + +HELP: crossref +{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } ". This variable is reset to " { $link f } " every time a definition is added or removed. Call " { $link get-crossref } " to lazily construct the graph instead of using this variable directly." } ; + +HELP: get-crossref +{ $values { "crossref" assoc } } +{ $description "Outputs the cross-referencing index, mapping definitions to usages, building it first if necessary." } +{ $notes "This word is used to implement " { $link usage } " and " { $link usage. } "." } ; + +HELP: crossref-def +{ $values { "defspec" "a definition specifier" } } +{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." } +$low-level-note ; + +HELP: usage +{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } +{ $description "Outputs a sequence of definitions that directly call the given definition." } +{ $notes "The sequence might include the definition itself, if it is a recursive word." } ; + HELP: usage. { $values { "word" "a word" } } { $description "Prints an list of all callers of a word. This may include the word itself, if it is recursive." } { $examples { $code "\\ reverse usage." } } ; +HELP: quot-uses +{ $values { "obj" object } { "assoc" "an assoc with words as keys" } } +{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ; + { usage usage. } related-words diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor index d08a17fd02..80f5367fb6 100755 --- a/basis/tools/crossref/crossref-tests.factor +++ b/basis/tools/crossref/crossref-tests.factor @@ -1,6 +1,6 @@ USING: math kernel sequences io.files io.pathnames tools.crossref tools.test parser namespaces source-files generic -definitions ; +definitions words accessors compiler.units ; IN: tools.crossref.tests GENERIC: foo ( a b -- c ) @@ -11,3 +11,40 @@ M: integer foo + ; [ t ] [ integer \ foo method \ + usage member? ] unit-test [ t ] [ \ foo usage [ pathname? ] any? ] unit-test + +! Issues with forget +GENERIC: generic-forget-test-1 ( a b -- c ) + +M: integer generic-forget-test-1 / ; + +[ t ] [ + \ / usage [ word? ] filter + [ name>> "integer=>generic-forget-test-1" = ] any? +] unit-test + +[ ] [ + [ \ generic-forget-test-1 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ / usage [ word? ] filter + [ name>> "integer=>generic-forget-test-1" = ] any? +] unit-test + +GENERIC: generic-forget-test-2 ( a b -- c ) + +M: sequence generic-forget-test-2 = ; + +[ t ] [ + \ = usage [ word? ] filter + [ name>> "sequence=>generic-forget-test-2" = ] any? +] unit-test + +[ ] [ + [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ = usage [ word? ] filter + [ name>> "sequence=>generic-forget-test-2" = ] any? +] unit-test \ No newline at end of file diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index 36ccaadc98..6082933bcb 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -1,9 +1,100 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs definitions io io.styles kernel prettyprint -sorting see ; +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.single threads compiler.units init ; IN: tools.crossref +SYMBOL: crossref + +GENERIC: uses ( defspec -- seq ) + +alist ] dip (seq-uses) + ] if ; + +M: array quot-uses seq-uses ; + +M: hashtable quot-uses assoc-uses ; + +M: callable quot-uses seq-uses ; + +M: wrapper quot-uses [ wrapped>> ] dip quot-uses ; + +M: callable uses ( quot -- assoc ) + V{ } clone visited [ + H{ } clone [ quot-uses ] keep keys + ] with-variable ; + +M: word uses def>> uses ; + +M: link uses { $subsection $link $see-also } article-links ; + +M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ; + +GENERIC: crossref-def ( defspec -- ) + +M: object crossref-def + dup uses crossref get add-vertex ; + +M: word crossref-def + [ call-next-method ] [ subwords [ crossref-def ] each ] bi ; + +: build-crossref ( -- crossref ) + "Computing usage index... " write flush yield + H{ } clone crossref [ + all-words + source-files get keys [ ] map + [ [ crossref-def ] each ] bi@ + crossref get + ] with-variable + "done" print flush ; + +: get-crossref ( -- crossref ) + crossref global [ drop build-crossref ] cache ; + +GENERIC: irrelevant? ( defspec -- ? ) + +M: object irrelevant? drop f ; + +M: default-method irrelevant? drop t ; + +M: predicate-engine irrelevant? drop t ; + +PRIVATE> + +: usage ( defspec -- seq ) get-crossref at keys ; + +GENERIC: smart-usage ( defspec -- seq ) + +M: object smart-usage usage [ irrelevant? not ] filter ; + +M: method-body smart-usage "method-generic" word-prop smart-usage ; + +M: f smart-usage drop \ f smart-usage ; + : synopsis-alist ( definitions -- alist ) [ [ synopsis ] keep ] { } map>assoc ; @@ -15,3 +106,34 @@ IN: tools.crossref : usage. ( word -- ) smart-usage sorted-definitions. ; + +: vocab-xref ( vocab quot -- vocabs ) + [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map + [ + [ [ word? ] [ generic? not ] bi and ] filter [ + dup method-body? + [ "method-generic" word-prop ] when + vocabulary>> + ] map + ] gather natural-sort remove sift ; inline + +: vocabs. ( seq -- ) + [ dup >vocab-link write-object nl ] each ; + +: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; + +: vocab-uses. ( vocab -- ) vocab-uses vocabs. ; + +: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; + +: vocab-usage. ( vocab -- ) vocab-usage vocabs. ; + + \ No newline at end of file diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 28a32790dc..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 ; +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 ) @@ -88,7 +87,7 @@ DEFER: ?make-staging-image [ drop ] [ make-staging-image ] if ; : make-deploy-config ( vocab -- file ) - [ deploy-config unparse-use ] + [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ] [ "deploy-config-" prepend temp-file ] bi [ utf8 set-file-contents ] keep ; 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 79335fd032..fd43d1ccc9 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 ; @@ -15,6 +15,7 @@ QUALIFIED: definitions QUALIFIED: init QUALIFIED: layouts QUALIFIED: source-files +QUALIFIED: source-files.errors QUALIFIED: vocabs IN: tools.deploy.shaker @@ -36,7 +37,7 @@ IN: tools.deploy.shaker ] when strip-dictionary? [ "compiler.units" init-hooks get delete-at - "tools.vocabs" init-hooks get delete-at + "vocabs.cache" init-hooks get delete-at ] when ; : strip-debugger ( -- ) @@ -96,14 +97,13 @@ IN: tools.deploy.shaker { "alias" "boa-check" - "cannot-infer" "coercer" "combination" - "compiled-status" "compiled-generic-uses" "compiled-uses" "constraints" "custom-inlining" + "decision-tree" "declared-effect" "default" "default-method" @@ -113,15 +113,12 @@ IN: tools.deploy.shaker "engines" "forgotten" "identities" - "if-intrinsics" - "infer" - "inferred-effect" "inline" "inlined-block" "input-classes" "instances" "interval" - "intrinsics" + "intrinsic" "lambda" "loc" "local-reader" @@ -138,7 +135,7 @@ IN: tools.deploy.shaker "method-generic" "modular-arithmetic" "no-compile" - "optimizer-hooks" + "owner-generic" "outputs" "participants" "predicate" @@ -151,17 +148,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" @@ -170,8 +163,6 @@ IN: tools.deploy.shaker strip-prettyprint? [ { - "break-before" - "break-after" "delimiter" "flushable" "foldable" @@ -266,8 +257,8 @@ IN: tools.deploy.shaker compiled-crossref compiled-generic-crossref compiler-impl + compiler.errors:compiler-errors definition-observers - definitions:crossref interactive-vocabs layouts:num-tags layouts:num-types @@ -277,6 +268,7 @@ IN: tools.deploy.shaker lexer-factory print-use-hook root-cache + source-files.errors:error-types vocabs:dictionary vocabs:load-vocab-hook word @@ -356,12 +348,10 @@ IN: tools.deploy.shaker : finish-deploy ( final-image -- ) "Finishing up" show - [ { } set-datastack ] dip - { } set-retainstack V{ } set-namestack V{ } set-catchstack "Saving final image" show - [ save-image-and-exit ] call-clear ; + save-image-and-exit ; SYMBOL: deploy-vocab @@ -378,9 +368,9 @@ SYMBOL: deploy-vocab [:c] [print-error] '[ - [ _ execute ] [ - _ execute nl - _ execute + [ _ execute( obj -- ) ] [ + _ execute( obj -- ) nl + _ execute( obj -- ) ] recover ] % ] if @@ -425,10 +415,10 @@ SYMBOL: deploy-vocab : deploy-error-handler ( quot -- ) [ strip-debugger? - [ error-continuation get call>> callstack>array die ] + [ error-continuation get call>> callstack>array die 1 exit ] ! Don't reference these words literally, if we're stripping the ! debugger out we don't want to load the prettyprinter at all - [ [:c] execute nl [print-error] execute flush ] if + [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if 1 exit ] recover ; inline diff --git a/basis/tools/deploy/test/11/11.factor b/basis/tools/deploy/test/11/11.factor index b4f8622627..3310686f05 100644 --- a/basis/tools/deploy/test/11/11.factor +++ b/basis/tools/deploy/test/11/11.factor @@ -3,6 +3,6 @@ USING: eval ; IN: tools.deploy.test.11 -: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval ; +: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval( -- ) ; MAIN: foo \ No newline at end of file diff --git a/basis/tools/deploy/test/7/7.factor b/basis/tools/deploy/test/7/7.factor index a16e3c82c5..5d6816121d 100644 --- a/basis/tools/deploy/test/7/7.factor +++ b/basis/tools/deploy/test/7/7.factor @@ -9,7 +9,7 @@ GENERIC: my-generic ( x -- b ) M: integer my-generic sq ; -M: fixnum my-generic call-next-method my-var get call ; +M: fixnum my-generic call-next-method my-var get call( a -- b ) ; : test-7 ( -- ) [ 1 + ] my-var set-global 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 96f5a04378..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 -[ ] [ { string pprint* } disassemble ] unit-test +"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each \ No newline at end of file diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor index 83b7dfef81..744318a0a4 100755 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -16,8 +16,6 @@ M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ; M: word disassemble word-xt 2array disassemble ; -M: method-spec disassemble first2 method disassemble ; - cpu x86? "tools.disassembler.udis" "tools.disassembler.gdb" ? diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 51e399c1c3..cd9dd9cf4b 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 << @@ -47,11 +47,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 +85,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/errors/authors.txt b/basis/tools/errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor new file mode 100644 index 0000000000..4eb9115d05 --- /dev/null +++ b/basis/tools/errors/errors-docs.factor @@ -0,0 +1,48 @@ +IN: tools.errors +USING: help.markup help.syntax source-files.errors words io +compiler.errors classes ; + +ARTICLE: "compiler-errors" "Compiler errors" +"After loading a vocabulary, you might see a message like:" +{ $code + ":errors - print 2 compiler errors" +} +"This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "." +$nl +"Words to view errors:" +{ $subsection :errors } +{ $subsection :linkage } +"Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; + +HELP: compiler-error +{ $values { "error" compiler-error } } +{ $description "Saves the error for viewing with " { $link :errors } "." } ; + +HELP: linkage-error +{ $values { "error" linkage-error } { "word" word } { "class" class } } +{ $description "Saves the error for viewing with " { $link :linkage } "." } ; + +HELP: :errors +{ $description "Prints all compiler errors." } ; + +HELP: :linkage +{ $description "Prints all C library interface linkage errors." } ; + +{ :errors :linkage } related-words + +HELP: errors. +{ $values { "errors" "a sequence of " { $link source-file-error } " instances" } } +{ $description "Prints a list of errors, grouped by source file." } ; + +ARTICLE: "tools.errors" "Batch error reporting" +"Some tools, such as the " { $link "compiler" } ", " { $link "tools.test" } " and " { $link "help.lint" } " need to report multiple errors at a time. Each error is associated with a source file, line number, and optionally, a definition. " { $link "errors" } " cannot be used for this purpose, so the " { $vocab-link "source-files.errors" } " vocabulary provides an alternative mechanism. Note that the words in this vocabulary are used for implementation only; to actually list errors, consult the documentation for the relevant tools." +$nl +"Source file errors inherit from a class:" +{ $subsection source-file-error } +"Printing an error summary:" +{ $subsection error-summary } +"Printing a list of errors:" +{ $subsection errors. } +"Batch errors are reported in the " { $link "ui.tools.error-list" } "." ; + +ABOUT: "tools.errors" \ No newline at end of file diff --git a/basis/tools/errors/errors-tests.factor b/basis/tools/errors/errors-tests.factor new file mode 100644 index 0000000000..709adafb4e --- /dev/null +++ b/basis/tools/errors/errors-tests.factor @@ -0,0 +1,13 @@ +USING: compiler.errors stack-checker.errors tools.test words ; +IN: tools.errors + +DEFER: blah + +[ ] [ + { + T{ compiler-error + { error T{ do-not-compile f blah } } + { asset blah } + } + } errors. +] unit-test \ No newline at end of file diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor new file mode 100644 index 0000000000..b53d4ef7a2 --- /dev/null +++ b/basis/tools/errors/errors.factor @@ -0,0 +1,45 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs debugger io kernel sequences source-files.errors +summary accessors continuations make math.parser io.styles namespaces +compiler.errors prettyprint ; +IN: tools.errors + +#! Tools for source-files.errors. Used by tools.tests and others +#! for error reporting + +M: source-file-error compute-restarts error>> compute-restarts ; + +M: source-file-error error-help error>> error-help ; + +CONSTANT: +listener-input+ "" + +M: source-file-error summary + [ + [ file>> [ % ": " % ] [ +listener-input+ % ] if* ] + [ line#>> [ # ] when* ] bi + ] "" make ; + +M: source-file-error error. + [ summary print nl ] + [ asset>> [ "Asset: " write short. nl ] when* ] + [ error>> error. ] + tri ; + +: errors. ( errors -- ) + group-by-source-file sort-errors + [ + [ nl "==== " write +listener-input+ or print nl ] + [ [ nl ] [ error. ] interleave ] + bi* + ] assoc-each ; + +: :errors ( -- ) compiler-errors get values errors. ; + +: :linkage ( -- ) linkage-errors get values errors. ; + +M: not-compiled summary + word>> name>> "The word " " cannot be executed because it failed to compile" surround ; + +M: not-compiled error. + [ summary print nl ] [ error>> error. ] bi ; \ No newline at end of file diff --git a/basis/tools/errors/model/authors.txt b/basis/tools/errors/model/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/errors/model/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/errors/model/model.factor b/basis/tools/errors/model/model.factor new file mode 100644 index 0000000000..c874363fe6 --- /dev/null +++ b/basis/tools/errors/model/model.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: models source-files.errors namespaces models.delay init +kernel calendar ; +IN: tools.errors.model + +SYMBOLS: (error-list-model) error-list-model ; + +(error-list-model) [ f ] initialize + +error-list-model [ (error-list-model) get-global 100 milliseconds ] initialize + +SINGLETON: updater + +M: updater errors-changed drop f (error-list-model) get-global set-model ; + +[ updater add-error-observer ] "ui.tools.error-list" add-init-hook + diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 8d882099de..146a119a63 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -75,7 +75,7 @@ M: object file-spec>string ( file-listing spec -- string ) : list-files-slow ( listing-tool -- array ) [ path>> ] [ sort>> ] [ specs>> ] tri '[ [ dup name>> file-info file-listing boa ] map - _ [ sort-by-slots ] when* + _ [ sort-by ] when* [ _ [ file-spec>string ] with map ] map ] with-directory-entries ; inline diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index 63b55729fb..666e051088 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -16,10 +16,11 @@ IN: tools.hexdump 16 * >hex 8 CHAR: 0 pad-head write "h: " write ; : >hex-digit ( digit -- str ) - >hex 2 CHAR: 0 pad-head " " append ; + >hex 2 CHAR: 0 pad-head ; : >hex-digits ( bytes -- str ) - [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ; + [ >hex-digit " " append ] { } map-as concat + 48 CHAR: \s pad-tail ; : >ascii ( bytes -- str ) [ [ printable? ] keep CHAR: . ? ] "" map-as ; diff --git a/basis/tools/memory/memory-tests.factor b/basis/tools/memory/memory-tests.factor index 60b54c2a0d..4b75cf0bfa 100644 --- a/basis/tools/memory/memory-tests.factor +++ b/basis/tools/memory/memory-tests.factor @@ -1,8 +1,5 @@ USING: tools.test tools.memory ; IN: tools.memory.tests -\ room. must-infer [ ] [ room. ] unit-test - -\ heap-stats. must-infer [ ] [ heap-stats. ] unit-test diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor index a786cdfef1..efd2e164a3 100644 --- a/basis/tools/profiler/profiler-docs.factor +++ b/basis/tools/profiler/profiler-docs.factor @@ -1,5 +1,5 @@ -USING: tools.profiler.private tools.time help.markup help.syntax -quotations io strings words definitions ; +USING: tools.profiler.private tools.time tools.crossref +help.markup help.syntax quotations io strings words definitions ; IN: tools.profiler ARTICLE: "profiler-limitations" "Profiler limitations" @@ -23,7 +23,7 @@ $nl { $subsection vocabs-profile. } { $subsection method-profile. } { $subsection "profiler-limitations" } -{ $see-also "ui-profiler" } ; +{ $see-also "ui.tools.profiler" } ; ABOUT: "profiling" diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index 0bd3663729..d2e605ecdc 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -34,7 +34,7 @@ words ; [ 1 ] [ \ foobar counter>> ] unit-test -: fooblah ( -- ) { } [ ] like call ; +: fooblah ( -- ) { } [ ] like call( -- ) ; : foobaz ( -- ) fooblah fooblah ; diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index 864a637096..219344db3b 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -3,11 +3,11 @@ USING: accessors words sequences math prettyprint kernel arrays io io.styles namespaces assocs kernel.private strings combinators sorting math.parser vocabs definitions tools.profiler.private -continuations generic compiler.units sets classes fry ; +tools.crossref continuations generic compiler.units sets classes fry ; IN: tools.profiler : profile ( quot -- ) - [ t profiling call ] [ f profiling ] [ ] cleanup ; + [ t profiling call ] [ f profiling ] [ ] cleanup ; inline : filter-counts ( alist -- alist' ) [ second 0 > ] filter ; diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 73e896d5ff..5c8b868483 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -5,7 +5,8 @@ io.encodings.utf8 hashtables kernel namespaces sequences 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 ; +splitting ascii combinators.short-circuit alarms words.symbol +system summary ; IN: tools.scaffold SYMBOL: developer-name @@ -15,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 ? ) @@ -234,6 +246,7 @@ PRIVATE> [ (help.) ] [ nl vocabulary>> link-vocab ] bi ; : scaffold-help ( vocab -- ) + ensure-vocab-exists [ dup "-docs.factor" vocab/suffix>path scaffolding? [ set-scaffold-docs-file @@ -268,6 +281,7 @@ PRIVATE> PRIVATE> : scaffold-tests ( vocab -- ) + ensure-vocab-exists dup "-tests.factor" vocab/suffix>path scaffolding? [ set-scaffold-tests-file @@ -292,12 +306,20 @@ 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 ( -- ) ".factor-boot-rc" scaffold-rc ; +: scaffold-factor-boot-rc ( -- ) + os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ; -: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ; +: 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/lint/authors.txt b/basis/tools/scaffold/windows/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from extra/lint/authors.txt rename to basis/tools/scaffold/windows/authors.txt diff --git a/basis/tools/scaffold/windows/tags.txt b/basis/tools/scaffold/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/tools/scaffold/windows/tags.txt @@ -0,0 +1 @@ +unportable 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-docs.factor b/basis/tools/test/test-docs.factor index 3cabff457f..ac7b33d41e 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -3,33 +3,26 @@ IN: tools.test ARTICLE: "tools.test.write" "Writing unit tests" "Assert that a quotation outputs a specific set of values:" -{ $subsection unit-test } +{ $subsection POSTPONE: unit-test } "Assert that a quotation throws an error:" -{ $subsection must-fail } -{ $subsection must-fail-with } +{ $subsection POSTPONE: must-fail } +{ $subsection POSTPONE: must-fail-with } "Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):" -{ $subsection must-infer } -{ $subsection must-infer-as } ; +{ $subsection POSTPONE: must-infer } +{ $subsection POSTPONE: must-infer-as } +"All of the above are used like ordinary words but are actually parsing words. This ensures that parse-time state, namely the line number, can be associated with the test in question, and reported in test failures." ; ARTICLE: "tools.test.run" "Running unit tests" "The following words run test harness files; any test failures are collected and printed at the end:" { $subsection test } -{ $subsection test-all } ; - -ARTICLE: "tools.test.failure" "Handling test failures" -"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "." -$nl -"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:" -{ $list - { { $snippet "error" } " - the error thrown by the unit test" } - { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" } - { { $snippet "continuation" } " - the traceback at the point of the error" } -} -"The following words run test harness files and output failures:" -{ $subsection run-tests } -{ $subsection run-all-tests } +{ $subsection test-all } "The following word prints failures:" -{ $subsection test-failures. } ; +{ $subsection :test-failures } +"Test failures are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." +$nl +"Unit test failures are instances of a class, and are stored in a global variable:" +{ $subsection test-failure } +{ $subsection test-failures } ; ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." @@ -45,12 +38,12 @@ $nl $nl "If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested." { $subsection "tools.test.write" } -{ $subsection "tools.test.run" } -{ $subsection "tools.test.failure" } ; +{ $subsection "tools.test.run" } ; ABOUT: "tools.test" HELP: unit-test +{ $syntax "[ output ] [ input ] unit-test" } { $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ; @@ -65,8 +58,8 @@ HELP: must-fail-with { $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ; HELP: must-infer -{ $values { "word/quot" "a quotation or a word" } } -{ $description "Ensures that the quotation or word has a static stack effect without running it." } +{ $values { "quot" quotation } } +{ $description "Ensures that the quotation has a static stack effect without running it." } { $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; HELP: must-infer-as @@ -78,17 +71,8 @@ HELP: test { $values { "prefix" "a vocabulary name" } } { $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ; -HELP: run-tests -{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } -{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; - HELP: test-all { $description "Runs unit tests for all loaded vocabularies." } ; -HELP: run-all-tests -{ $values { "failures" "an association list of unit test failures" } } -{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; - -HELP: test-failures. -{ $values { "assoc" "an association list of unit test failures" } } -{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ; +HELP: :test-failures +{ $description "Prints all pending unit test failures." } ; diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor index 473335645f..c8ce3e01c7 100644 --- a/basis/tools/test/test-tests.factor +++ b/basis/tools/test/test-tests.factor @@ -1,4 +1,16 @@ IN: tools.test.tests -USING: tools.test ; +USING: tools.test tools.test.private namespaces kernel sequences ; -\ test-all must-infer +: fake-unit-test ( quot -- ) + [ + "fake" file set + V{ } clone test-failures set + call + test-failures get + ] with-scope ; inline + +[ 1 ] [ + [ + [ "OOPS" ] must-fail + ] fake-unit-test length +] unit-test \ No newline at end of file diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index c6dea08d18..3dc7b8740b 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -1,95 +1,144 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces arrays prettyprint sequences kernel -vectors quotations words parser assocs combinators continuations -debugger io io.styles io.files vocabs vocabs.loader source-files -compiler.units summary stack-checker effects tools.vocabs fry ; +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 +vocabs.files words tools.errors source-files.errors +io.streams.string make compiler.errors ; IN: tools.test -SYMBOL: failures +TUPLE: test-failure < source-file-error continuation ; -: ( error what -- triple ) - error-continuation get 3array ; +SYMBOL: +test-failure+ -: failure ( error what -- ) +M: test-failure error-type drop +test-failure+ ; + +SYMBOL: test-failures + +test-failures [ V{ } clone ] initialize + +T{ error-type + { type +test-failure+ } + { word ":test-failures" } + { plural "unit test failures" } + { icon "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } + { quot [ test-failures get ] } +} define-error-type + + ( error experiment file line# -- triple ) + test-failure new + swap >>line# + swap >>file + swap >>asset + swap >>error + error-continuation get >>continuation ; + +: failure ( error experiment file line# -- ) "--> test failed!" print - failures get push ; + test-failures get push + notify-error-observers ; -SYMBOL: this-test +SYMBOL: file -: (unit-test) ( what quot -- ) - swap dup . flush this-test set - failures get [ - [ this-test get failure ] recover - ] [ - call - ] if ; inline +: file-failure ( error -- ) + f file get f failure ; -: unit-test ( output input -- ) - [ 2array ] 2keep '[ - _ { } _ with-datastack swap >array assert= - ] (unit-test) ; +:: (unit-test) ( output input -- error ? ) + [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ; : short-effect ( effect -- pair ) [ in>> length ] [ out>> length ] bi 2array ; -: must-infer-as ( effect quot -- ) - [ 1quotation ] dip '[ _ infer short-effect ] unit-test ; +:: (must-infer-as) ( effect quot -- error ? ) + [ quot infer short-effect effect assert= f f ] [ t ] recover ; -: must-infer ( word/quot -- ) - dup word? [ 1quotation ] when - '[ _ infer drop ] [ ] swap unit-test ; +:: (must-infer) ( quot -- error ? ) + [ quot infer drop f f ] [ t ] recover ; -: must-fail-with ( quot pred -- ) - [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ; +TUPLE: did-not-fail ; +CONSTANT: did-not-fail T{ did-not-fail } -: must-fail ( quot -- ) - [ drop t ] must-fail-with ; +M: did-not-fail summary drop "Did not fail" ; -: (run-test) ( vocab -- ) +:: (must-fail-with) ( quot pred -- error ? ) + [ { } quot with-datastack drop did-not-fail t ] + [ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover ; + +:: (must-fail) ( quot -- error ? ) + [ { } quot with-datastack drop did-not-fail t ] [ drop f f ] recover ; + +: experiment-title ( word -- string ) + "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ; + +MACRO: ( word -- ) + [ stack-effect in>> length dup ] + [ name>> experiment-title ] bi + '[ _ ndup _ narray _ prefix ] ; + +: experiment. ( seq -- ) + [ first write ": " write ] [ rest . ] bi ; + +:: experiment ( word: ( -- error ? ) line# -- ) + word :> e + e experiment. + word execute [ + file get [ + e file get line# failure + ] [ rethrow ] if + ] [ drop ] if ; inline + +: parse-test ( accum word -- accum ) + literalize parsed + lexer get line>> parsed + \ experiment parsed ; inline + +<< + +SYNTAX: TEST: + scan + [ create-in ] + [ "(" ")" surround search '[ _ parse-test ] ] bi + define-syntax ; + +>> + +: run-test-file ( path -- ) + dup file [ + test-failures get file get +test-failure+ delete-file-errors + '[ _ run-file ] [ file-failure ] recover + ] with-variable ; + +: run-vocab-tests ( vocab -- ) dup vocab source-loaded?>> [ - vocab-tests [ run-file ] each + vocab-tests [ run-test-file ] each ] [ drop ] if ; -: run-test ( vocab -- failures ) - V{ } clone [ - failures [ - [ (run-test) ] [ swap failure ] recover - ] with-variable - ] keep ; +: traceback-button. ( failure -- ) + "[" write [ "Traceback" ] dip continuation>> write-object "]" print ; -: failure. ( triple -- ) - dup second . - dup first print-error - "Traceback" swap third write-object ; +PRIVATE> -: test-failures. ( assoc -- ) - [ - nl - [ - "==== ALL TESTS PASSED" print - ] [ - "==== FAILING TESTS:" print - [ - swap vocab-heading. - [ failure. nl ] each - ] assoc-each - ] if-empty - ] [ - "==== NOTHING TO TEST" print - ] if* ; +TEST: unit-test +TEST: must-infer-as +TEST: must-infer +TEST: must-fail-with +TEST: must-fail -: run-tests ( prefix -- failures ) - child-vocabs [ f ] [ - [ dup run-test ] { } map>assoc - [ second empty? not ] filter - ] if-empty ; +M: test-failure error. ( error -- ) + { + [ summary print nl ] + [ asset>> [ experiment. nl ] when* ] + [ error>> error. ] + [ traceback-button. ] + } cleave ; + +: :test-failures ( -- ) test-failures get errors. ; : test ( prefix -- ) - run-tests test-failures. ; + child-vocabs [ run-vocab-tests ] each ; -: run-all-tests ( -- failures ) - "" run-tests ; - -: test-all ( -- ) - run-all-tests test-failures. ; +: test-all ( -- ) "" test ; diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 58fc531623..65e87f976f 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 ; +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 - 4 cut* - "==== GARBAGE COLLECTION" print nl +: time. ( time -- ) + "== Running time ==" print nl 1000000 /f pprint " seconds" print ; + +: gc-stats. ( stats -- ) + 5 cut* + "== 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,12 +32,43 @@ IN: tools.time [ nl { - "Total GC time (us):" + "Total GC time:" "Cards scanned:" "Decks scanned:" + "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/authors.txt b/basis/tools/trace/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/trace/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/trace/trace-tests.factor b/basis/tools/trace/trace-tests.factor new file mode 100644 index 0000000000..74f7c40943 --- /dev/null +++ b/basis/tools/trace/trace-tests.factor @@ -0,0 +1,4 @@ +IN: tools.trace.tests +USING: tools.trace tools.test sequences ; + +[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test \ No newline at end of file diff --git a/basis/tools/trace/trace.factor b/basis/tools/trace/trace.factor new file mode 100644 index 0000000000..e2c6bf864b --- /dev/null +++ b/basis/tools/trace/trace.factor @@ -0,0 +1,83 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +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 ; +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 + +: include? ( vocab -- ? ) + include-vocabs get dup [ member? ] [ 2drop t ] if ; + +: exclude? ( vocab -- ? ) + exclude-vocabs get dup [ member? ] [ 2drop f ] if ; + +: into? ( obj -- ? ) + { + [ word? ] + [ predicate? not ] + [ math-generic? not ] + [ + { + [ inline? ] + [ + { + [ vocabulary>> include? ] + [ vocabulary>> exclude? not ] + } 1&& + ] + } 1|| + ] + } 1&& ; + +TUPLE: trace-step word inputs ; + +M: trace-step summary + [ + [ "Word: " % word>> name>> % ] + [ " -- inputs: " % inputs>> unparse-short % ] bi + ] "" make ; + +: ( continuation word -- trace-step ) + [ nip ] [ [ data>> ] [ stack-effect in>> length ] bi* short tail* ] 2bi + \ trace-step boa ; + +: print-step ( continuation -- ) + dup continuation-current dup word? [ + [ nip name>> ] [ ] 2bi write-object nl + ] [ + nip short. + ] if ; + +: print-depth ( continuation -- ) + call>> callstack-depth + [ CHAR: \s write ] + [ number>string write ": " write ] bi ; + +: 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 ; + +: trace ( quot -- data ) + [ [ trace-step ] break-hook ] dip + [ break ] [ end drop ] surround + with-variable ; + +<< \ trace t "no-compile" set-word-prop >> \ No newline at end of file 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 6167a5be23..0000000000 --- a/basis/tools/vocabs/vocabs.factor +++ /dev/null @@ -1,310 +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-xref ( vocab quot -- vocabs ) - [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map - [ - [ [ word? ] [ generic? not ] bi and ] filter [ - dup method-body? - [ "method-generic" word-prop ] when - vocabulary>> - ] map - ] gather natural-sort remove sift ; inline - -: vocabs. ( seq -- ) - [ dup >vocab-link write-object nl ] each ; - -: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; - -: vocab-uses. ( vocab -- ) vocab-uses vocabs. ; - -: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ; - -: vocab-usage. ( vocab -- ) vocab-usage 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-compiler-errors ; - -: 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/debug/debug.factor b/basis/tools/walker/debug/debug.factor index f2155ec125..80113607d4 100644 --- a/basis/tools/walker/debug/debug.factor +++ b/basis/tools/walker/debug/debug.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.promises models tools.walker kernel -sequences concurrency.messaging locals continuations -threads namespaces namespaces.private assocs accessors ; +USING: concurrency.promises models tools.walker tools.continuations +kernel sequences concurrency.messaging locals continuations threads +namespaces namespaces.private assocs accessors ; IN: tools.walker.debug :: test-walker ( quot -- data ) diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor index 3a5877c286..6f87792faa 100644 --- a/basis/tools/walker/walker-tests.factor +++ b/basis/tools/walker/walker-tests.factor @@ -1,7 +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 ; +generic.single sequences.private kernel.private +tools.continuations accessors words ; IN: tools.walker.tests [ { } ] [ @@ -112,3 +113,22 @@ IN: tools.walker.tests [ { } ] [ [ "a" "b" set "c" "d" set [ ] test-walker ] with-scope ] unit-test + +: breakpoint-test ( -- x ) break 1 2 + ; + +\ breakpoint-test don't-step-into + +[ f ] [ \ breakpoint-test optimized? ] unit-test + +[ { 3 } ] [ [ breakpoint-test ] test-walker ] 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 ] test-walker ] unit-test \ No newline at end of file diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index b4ace6b770..4208c4420f 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -1,10 +1,11 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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 ; +generic generic.standard definitions make sbufs +tools.continuations parser ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -31,66 +32,18 @@ DEFER: start-walker-thread 2dup start-walker-thread ] if* ; -: show-walker ( -- thread ) - get-walker-thread - [ show-walker-hook get call ] keep ; - -: after-break ( object -- ) - { - { [ dup continuation? ] [ (continue) ] } - { [ dup quotation? ] [ call ] } - { [ dup not ] [ "Single stepping abandoned" rethrow ] } - } cond ; - -: break ( -- ) - continuation callstack >>call - show-walker send-synchronous - after-break ; - -\ break t "break?" set-word-prop - : walk ( quot -- quot' ) \ break prefix [ break rethrow ] recover ; -GENERIC: add-breakpoint ( quot -- quot' ) +<< \ walk t "no-compile" set-word-prop >> -M: callable add-breakpoint - dup [ break ] head? [ \ break prefix ] unless ; - -M: array add-breakpoint - [ add-breakpoint ] map ; - -M: object add-breakpoint ; - -: (step-into-quot) ( quot -- ) add-breakpoint call ; - -: (step-into-dip) ( quot -- ) add-breakpoint dip ; - -: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ; - -: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ; - -: (step-into-if) ( true false ? -- ) ? (step-into-quot) ; - -: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ; - -: (step-into-execute) ( word -- ) - { - { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] } - { [ dup standard-generic? ] [ effective-method (step-into-execute) ] } - { [ dup hook-generic? ] [ effective-method (step-into-execute) ] } - { [ dup uses \ suspend swap member? ] [ execute break ] } - { [ dup primitive? ] [ execute break ] } - [ def>> (step-into-quot) ] - } cond ; - -\ (step-into-execute) t "step-into?" set-word-prop - -: (step-into-continuation) ( -- ) - continuation callstack >>call break ; - -: (step-into-call-next-method) ( method -- ) - next-method-quot (step-into-quot) ; +break-hook [ + [ + get-walker-thread + [ show-walker-hook get call ] keep + send-synchronous + ] +] initialize ! Messages sent to walker thread SYMBOL: step @@ -106,74 +59,6 @@ SYMBOL: +running+ SYMBOL: +suspended+ SYMBOL: +stopped+ -: 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 - -: step-msg ( continuation -- continuation' ) USE: io - [ - 2dup length = [ nip [ break ] append ] [ - 2dup nth \ break = [ nip ] [ - swap 1+ cut [ break ] glue - ] if - ] if - ] change-frame ; - -: step-out-msg ( continuation -- continuation' ) - [ nip \ break suffix ] change-frame ; - -{ - { call [ (step-into-quot) ] } - { dip [ (step-into-dip) ] } - { 2dip [ (step-into-2dip) ] } - { 3dip [ (step-into-3dip) ] } - { execute [ (step-into-execute) ] } - { if [ (step-into-if) ] } - { dispatch [ (step-into-dispatch) ] } - { continuation [ (step-into-continuation) ] } - { (call-next-method) [ (step-into-call-next-method) ] } -} [ "step-into" set-word-prop ] assoc-each - -! Never step into these words -{ - >n ndrop >c c> - continue continue-with - stop suspend (spawn) -} [ - dup [ execute break ] curry - "step-into" set-word-prop -] each - -\ break [ break ] "step-into" set-word-prop - -: step-into-msg ( continuation -- continuation' ) - [ - swap cut [ - swap % - [ \ break , ] [ - unclip { - { [ dup \ break eq? ] [ , ] } - { [ dup quotation? ] [ add-breakpoint , \ break , ] } - { [ dup array? ] [ add-breakpoint , \ break , ] } - { [ dup word? ] [ literalize , \ (step-into-execute) , ] } - [ , \ break , ] - } cond % - ] if-empty - ] [ ] make - ] change-frame ; - : status ( -- symbol ) walker-status tget value>> ; @@ -200,13 +85,13 @@ SYMBOL: +stopped+ { f [ +stopped+ set-status f ] } [ [ walker-continuation tget set-model ] - [ step-into-msg ] bi + [ continuation-step-into ] bi ] } case ] handle-synchronous ] while ; -: step-back-msg ( continuation -- continuation' ) +: continuation-step-back ( continuation -- continuation' ) walker-history tget [ pop* ] [ [ nip pop ] unless-empty ] bi ; @@ -220,20 +105,20 @@ SYMBOL: +stopped+ { ! These are sent by the walker tool. We reply ! and keep cycling. - { step [ step-msg keep-running ] } - { step-out [ step-out-msg keep-running ] } - { step-into [ step-into-msg keep-running ] } + { step [ continuation-step keep-running ] } + { step-out [ continuation-step-out keep-running ] } + { step-into [ continuation-step-into keep-running ] } { step-all [ keep-running ] } { step-into-all [ step-into-all-loop ] } { abandon [ drop f keep-running ] } ! Pass quotation to debugged thread { call-in [ keep-running ] } ! Pass previous continuation to debugged thread - { step-back [ step-back-msg ] } + { step-back [ continuation-step-back ] } } case f ] handle-synchronous ] while ; - + : walker-loop ( -- ) +running+ set-status [ status +stopped+ eq? ] [ @@ -276,4 +161,4 @@ SYMBOL: +stopped+ ! For convenience IN: syntax -: B ( -- ) break ; +SYNTAX: B \ break parsed ; diff --git a/basis/tuple-arrays/authors.txt b/basis/tuple-arrays/authors.txt index f990dd0ed2..d4f5d6b3ae 100644 --- a/basis/tuple-arrays/authors.txt +++ b/basis/tuple-arrays/authors.txt @@ -1 +1 @@ -Daniel Ehrenberg +Slava Pestov \ No newline at end of file diff --git a/basis/tuple-arrays/summary.txt b/basis/tuple-arrays/summary.txt old mode 100644 new mode 100755 index ac05ae9bcc..6f5c8b7244 --- a/basis/tuple-arrays/summary.txt +++ b/basis/tuple-arrays/summary.txt @@ -1 +1 @@ -Packed homogeneous tuple arrays +Efficient arrays of tuples with value semantics for elements diff --git a/basis/tuple-arrays/tags.txt b/basis/tuple-arrays/tags.txt old mode 100644 new mode 100755 diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor deleted file mode 100644 index 18f5547e7f..0000000000 --- a/basis/tuple-arrays/tuple-arrays-docs.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: help.syntax help.markup splitting kernel sequences ; -IN: tuple-arrays - -HELP: tuple-array -{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ; - -HELP: -{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } -{ $description "Creates an instance of the " { $link } " class with the given length and containing the given tuple class." } ; - -HELP: >tuple-array -{ $values { "seq" sequence } { "tuple-array" tuple-array } } -{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ; diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 7aa49b880f..2eeae20aa1 100644 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -5,17 +5,28 @@ IN: tuple-arrays.tests SYMBOL: mat TUPLE: foo bar ; C: foo -[ 2 ] [ 2 foo dup mat set length ] unit-test +TUPLE-ARRAY: foo + +[ 2 ] [ 2 dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test -[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test +[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test [ T{ foo f 3 } t ] -[ mat get [ bar>> 2 + ] map [ first ] keep tuple-array? ] unit-test +[ mat get [ bar>> 2 + ] map [ first ] keep foo-array? ] unit-test -[ 2 ] [ 2 foo dup mat set length ] unit-test +[ 2 ] [ 2 dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test TUPLE: baz { bing integer } bong ; -[ 0 ] [ 1 baz first bing>> ] unit-test -[ f ] [ 1 baz first bong>> ] unit-test +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 af62c0b0d7..35d771416c 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -1,34 +1,73 @@ -! Copyright (C) 2007 Daniel Ehrenberg. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: splitting grouping classes.tuple classes math kernel -sequences arrays accessors ; +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 -TUPLE: tuple-array { seq read-only } { class read-only } ; + ( length class -- tuple-array ) - [ - new tuple>array 1 tail - [ concat ] [ length ] bi - ] [ ] bi tuple-array boa ; +MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ ] ; -M: tuple-array nth - [ seq>> nth ] [ class>> ] bi prefix >tuple ; +MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; -M: tuple-array set-nth ( elt n seq -- ) - [ tuple>array 1 tail ] 2dip seq>> set-nth ; +: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline -M: tuple-array new-sequence - class>> ; +: smart-tuple>array ( tuple class -- array ) + '[ [ _ boa ] undo ] output>array ; inline -: >tuple-array ( seq -- tuple-array ) - dup empty? [ - 0 over first class clone-like - ] unless ; +: tuple-prototype ( class -- array ) + [ new ] [ smart-tuple>array ] bi ; inline -M: tuple-array like - drop dup tuple-array? [ >tuple-array ] unless ; +: tuple-slice ( n seq -- slice ) + [ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline -M: tuple-array length seq>> length ; +: read-tuple ( slice class -- tuple ) + '[ _ boa-unsafe ] input [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] + bi '[ _ dip @ ] ; + +PRIVATE> + +FUNCTOR: define-tuple-array ( CLASS -- ) + +CLASS IS ${CLASS} + +CLASS-array DEFINES-CLASS ${CLASS}-array +CLASS-array? IS ${CLASS-array}? + + DEFINES <${CLASS}-array> +>CLASS-array DEFINES >${CLASS}-array + +WHERE + +TUPLE: CLASS-array +{ seq array read-only } +{ n array-capacity read-only } +{ length array-capacity read-only } ; + +: ( length -- tuple-array ) + [ \ CLASS [ tuple-prototype concat ] [ tuple-arity ] bi ] keep + \ CLASS-array boa ; inline + +M: CLASS-array length length>> ; + +M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; + +M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; + +M: CLASS-array new-sequence drop ; + +: >CLASS-array ( seq -- tuple-array ) 0 clone-like ; + +M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; + +INSTANCE: CLASS-array sequence + +;FUNCTOR + +SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ; diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 76fbc7286b..9c844d3663 100755 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces opengl opengl.gl ; +USING: kernel namespaces opengl opengl.gl fry ; IN: ui.backend SYMBOL: ui-backend @@ -28,7 +28,7 @@ GENERIC: flush-gl-context ( handle -- ) HOOK: offscreen-pixels ui-backend ( world -- alien w h ) : with-gl-context ( handle quot -- ) - swap [ select-gl-context call ] keep - glFlush flush-gl-context gl-error ; inline + '[ select-gl-context @ ] + [ flush-gl-context gl-error ] bi ; inline HOOK: (with-ui) ui-backend ( quot -- ) \ No newline at end of file diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index fc392c595d..5b1b4b0c2a 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 { $ NSOpenGLPFASingleRenderer $ 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 @@ -39,13 +77,16 @@ M: pasteboard set-clipboard-contents [ 0 0 ] dip dim>> first2 ; : auto-position ( window loc -- ) + #! Note: if this is the initial window, the length of the windows + #! vector should be 1, since (open-window) calls auto-position + #! after register-window. dup { 0 0 } = [ drop - windows get [ -> center ] [ - peek second window-loc>> + windows get length 1 <= [ -> center ] [ + windows get peek second window-loc>> dupd first2 -> cascadeTopLeftFromPoint: -> setFrameTopLeftPoint: - ] if-empty + ] if ] [ first2 -> setFrameTopLeftPoint: ] if ; M: cocoa-ui-backend set-title ( string world -- ) @@ -67,11 +108,12 @@ 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 - window world window-loc>> auto-position world view register-window + window world window-loc>> auto-position world window save-position window install-window-delegate view window world (>>handle) @@ -94,18 +136,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 46ecc1a37f..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 -- ) @@ -70,7 +71,7 @@ CLASS: { ! Service support; evaluate Factor code from other apps :: do-service ( pboard error quot -- ) pboard error ?pasteboard-string - dup [ quot call ] when + dup [ quot call( string -- result/f ) ] when [ pboard set-pasteboard-string ] when* ; CLASS: { diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index b59848260d..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 @@ -336,7 +336,7 @@ CLASS: { ! Initialization { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" } - [ 2drop dup view-dim swap window (>>dim) yield ] + [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ] } { "doCommandBySelector:" "void" { "id" "SEL" "SEL" } @@ -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..24ae72740f 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 ; 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,54 @@ 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 ; + +: hwnd>RECT ( hwnd -- RECT ) + "RECT" [ GetWindowRect win32-error=0/f ] keep ; + +: 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 422efbd188..76fd9fa30c 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -3,11 +3,12 @@ USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets ui.gadgets.private ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render ui.event-loop assocs kernel math -namespaces opengl sequences strings x11.xlib x11.events x11.xim -x11.glx x11.clipboard x11.constants x11.windows io.encodings.string -io.encodings.ascii io.encodings.utf8 combinators command-line -math.vectors classes.tuple opengl.gl threads math.rectangles -environment ascii ; +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 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 ; @@ -196,7 +232,7 @@ M: world client-event QueuedAfterFlush events-queued 0 > [ next-event dup None XFilterEvent 0 = [ drop wait-event ] unless - ] [ ui-wait wait-event ] if ; + ] [ wait-for-display wait-event ] if ; M: x11-ui-backend do-events wait-event dup XAnyEvent-window window dup @@ -224,6 +260,10 @@ M: x-clipboard paste-clipboard [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip utf8 encode dup length XChangeProperty drop ; +: set-class ( dpy window -- ) + XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor" + utf8 encode dup length XChangeProperty drop ; + M: x11-ui-backend set-title ( string world -- ) handle>> window>> swap [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; @@ -242,11 +282,15 @@ M: x11-ui-backend set-fullscreen* ( ? world -- ) M: x11-ui-backend (open-window) ( world -- ) dup gadget-window - handle>> window>> dup set-closable map-window ; + handle>> window>> + [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ; M: x11-ui-backend raise-window* ( world -- ) handle>> [ - dpy get swap window>> XRaiseWindow drop + dpy get swap window>> + [ RevertToPointerRoot CurrentTime XSetInputFocus drop ] + [ XRaiseWindow drop ] + 2bi ] when* ; M: x11-handle select-gl-context ( handle -- ) @@ -266,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/baseline-alignment/baseline-alignment.factor b/basis/ui/baseline-alignment/baseline-alignment.factor index e02c6188f5..f7f7a757f5 100644 --- a/basis/ui/baseline-alignment/baseline-alignment.factor +++ b/basis/ui/baseline-alignment/baseline-alignment.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel locals math math.order math.vectors +USING: arrays kernel locals math math.functions math.order math.vectors sequences ui.gadgets accessors combinators ; IN: ui.baseline-alignment @@ -24,35 +24,47 @@ TUPLE: gadget-metrics height ascent descent cap-height ; [ dup [ 2dup - ] [ f ] if ] dip gadget-metrics boa ; inline +: ?supremum ( seq -- n/f ) + sift [ f ] [ supremum ] if-empty ; + : max-ascent ( seq -- n ) - 0 [ ascent>> [ max ] when* ] reduce ; inline + [ ascent>> ] map ?supremum ; : max-cap-height ( seq -- n ) - 0 [ cap-height>> [ max ] when* ] reduce ; inline + [ cap-height>> ] map ?supremum ; : max-descent ( seq -- n ) - 0 [ descent>> [ max ] when* ] reduce ; inline + [ descent>> ] map ?supremum ; : max-text-height ( seq -- y ) - 0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ; + [ ascent>> ] filter [ height>> ] map ?supremum ; : max-graphics-height ( seq -- y ) - 0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ; - -: (align-baselines) ( y max leading -- y' ) [ swap - ] dip + ; + [ ascent>> not ] filter [ height>> ] map ?supremum 0 or ; :: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' ) - cap-height 2 / :> mid-line - graphics-height 2 / - [ ascent mid-line - max mid-line + >integer ] - [ descent mid-line + max mid-line - >integer ] bi ; + ascent [ + cap-height 2 / :> mid-line + graphics-height 2 / + [ ascent mid-line - max mid-line + floor >integer ] + [ descent mid-line + max mid-line - ceiling >integer ] bi + ] [ f f ] if ; + +: (measure-metrics) ( children sizes -- graphics-height ascent descent cap-height ) + [ ] 2map + { + [ max-graphics-height ] + [ max-ascent ] + [ max-descent ] + [ max-cap-height ] + } cleave ; PRIVATE> :: align-baselines ( gadgets -- ys ) gadgets [ dup pref-dim ] map - dup max-ascent :> max-ascent - dup max-cap-height :> max-cap-height + dup max-ascent 0 or :> max-ascent + dup max-cap-height 0 or :> max-cap-height dup max-graphics-height :> max-graphics-height max-cap-height max-graphics-height + 2 /i :> critical-line @@ -61,20 +73,12 @@ PRIVATE> [ dup ascent>> - [ ascent>> max-ascent text-leading ] - [ height>> max-graphics-height graphics-leading ] if - (align-baselines) + [ ascent>> max-ascent swap - text-leading ] + [ height>> max-graphics-height swap - 2/ graphics-leading ] if + ] map ; : measure-metrics ( children sizes -- ascent descent ) - [ ] 2map - { - [ max-graphics-height ] - [ max-ascent ] - [ max-descent ] - [ max-cap-height ] - } cleave - combine-metrics ; + (measure-metrics) combine-metrics ; : measure-height ( children sizes -- height ) - measure-metrics + ; \ No newline at end of file + (measure-metrics) dup [ combine-metrics + ] [ 3drop ] if ; \ No newline at end of file diff --git a/basis/ui/event-loop/event-loop-tests.factor b/basis/ui/event-loop/event-loop-tests.factor index ae1d7ec8bc..ac263cb79c 100644 --- a/basis/ui/event-loop/event-loop-tests.factor +++ b/basis/ui/event-loop/event-loop-tests.factor @@ -1,4 +1,2 @@ IN: ui.event-loop.tests USING: ui.event-loop tools.test ; - -\ event-loop must-infer diff --git a/basis/ui/gadgets/books/books-tests.factor b/basis/ui/gadgets/books/books-tests.factor index dab9ef5acf..3076ffc004 100644 --- a/basis/ui/gadgets/books/books-tests.factor +++ b/basis/ui/gadgets/books/books-tests.factor @@ -1,4 +1,2 @@ IN: ui.gadgets.books.tests USING: tools.test ui.gadgets.books ; - -\ must-infer diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index 6042a39886..a28a6aef84 100644 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/basis/ui/gadgets/buttons/buttons-docs.factor @@ -26,7 +26,7 @@ HELP: { $description "Creates a new " { $link button } " derived from a " { $link } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ; HELP: button-pen -{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:" +{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words by delegating to an object in one of four slots which depend on the state of the button being drawn:" { $list { { $snippet "plain" } " - the button is inactive" } { { $snippet "rollover" } " - the button is under the mouse" } diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor index 0aa12f7279..f7c73b2438 100644 --- a/basis/ui/gadgets/buttons/buttons-tests.factor +++ b/basis/ui/gadgets/buttons/buttons-tests.factor @@ -28,10 +28,6 @@ T{ foo-gadget } "t" set } "religion" set ] unit-test -\ must-infer - -\ must-infer - [ 0 ] [ "religion" get gadget-child value>> ] unit-test diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor index bd610ba53b..3ba32dc3c2 100644 --- a/basis/ui/gadgets/editors/editors-tests.factor +++ b/basis/ui/gadgets/editors/editors-tests.factor @@ -42,8 +42,6 @@ IN: ui.gadgets.editors.tests ] with-grafted-gadget ] unit-test -\ must-infer - "hello" "field" set "field" get [ diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 3eb40a5135..9461b2348f 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -452,6 +452,7 @@ editor "caret-motion" f { editor "selection" f { { T{ button-down f { S+ } 1 } extend-selection } + { T{ button-up f { S+ } 1 } com-copy-selection } { T{ drag } drag-selection } { gain-focus focus-editor } { lose-focus unfocus-editor } diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor index 03219c66fd..77860ba5b5 100644 --- a/basis/ui/gadgets/gadgets-tests.factor +++ b/basis/ui/gadgets/gadgets-tests.factor @@ -152,16 +152,3 @@ M: mock-gadget ungraft* { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each ] with-string-writer print - -\ must-infer -\ unparent must-infer -\ add-gadget must-infer -\ add-gadgets must-infer -\ clear-gadget must-infer - -\ relayout must-infer -\ relayout-1 must-infer -\ pref-dim must-infer - -\ graft* must-infer -\ ungraft* must-infer \ No newline at end of file diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index bc07006d62..f9f397d46f 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,7 +3,8 @@ USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry ; +concurrency.flags math.order math.rectangles fry locals +prettyprint.backend prettyprint.custom ; IN: ui.gadgets ! Values for orientation slot @@ -27,6 +28,9 @@ interior boundary model ; +! Don't print gadgets with RECT: syntax +M: gadget pprint* pprint-tuple ; + M: gadget equal? 2drop f ; M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ; @@ -66,8 +70,8 @@ M: gadget children-on nip children>> ; : ((fast-children-on)) ( gadget dim axis -- <=> ) [ swap loc>> v- ] dip v. 0 <=> ; -: (fast-children-on) ( dim axis children -- i ) - -rot '[ _ _ ((fast-children-on)) ] search drop ; +:: (fast-children-on) ( dim axis children -- i ) + children [ dim axis ((fast-children-on)) ] search drop ; PRIVATE> 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/icons/icons.factor b/basis/ui/gadgets/icons/icons.factor index ddadb6b99e..123f7a540d 100644 --- a/basis/ui/gadgets/icons/icons.factor +++ b/basis/ui/gadgets/icons/icons.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors ui.images ui.pens -ui.pens.image ui.gadgets ; +ui.pens.image ui.gadgets ui.gadgets.labels ; IN: ui.gadgets.icons TUPLE: icon < gadget ; @@ -9,4 +9,6 @@ TUPLE: icon < gadget ; : ( image-name -- icon ) icon new swap t >>fill? >>interior ; -M: icon pref-dim* dup interior>> pen-pref-dim ; \ No newline at end of file +M: icon pref-dim* dup interior>> pen-pref-dim ; + +M: image-name >label ; \ No newline at end of file diff --git a/basis/ui/gadgets/packs/packs-tests.factor b/basis/ui/gadgets/packs/packs-tests.factor index cae7d12dc3..b49f46c05a 100644 --- a/basis/ui/gadgets/packs/packs-tests.factor +++ b/basis/ui/gadgets/packs/packs-tests.factor @@ -90,4 +90,50 @@ IN: ui.gadgets.packs.tests [ ] [ "g" get prefer ] unit-test -[ ] [ "g" get layout ] unit-test \ No newline at end of file +[ ] [ "g" get layout ] unit-test + +! Baseline alignment without any text gadgets should behave like align=1/2 + +baseline+ >>align + { 30 30 } >>dim add-gadget + { 30 20 } >>dim add-gadget +"g" set + +[ { 60 30 } ] [ "g" get pref-dim ] unit-test + +[ ] [ "g" get prefer ] unit-test + +[ ] [ "g" get layout ] unit-test + +[ V{ { 0 0 } { 30 5 } } ] +[ "g" get children>> [ loc>> ] map ] unit-test + + +baseline+ >>align + { 30 30 } >>dim add-gadget +10 10 { 10 10 } add-gadget +"g" set + +[ ] [ "g" get prefer ] unit-test + +[ ] [ "g" get layout ] unit-test + +[ V{ { 0 0 } { 30 10 } } ] +[ "g" get children>> [ loc>> ] map ] unit-test + + +baseline+ >>align + { 30 30 } >>dim add-gadget add-gadget +10 10 { 10 10 } add-gadget +"g" set + +[ ] [ "g" get prefer ] unit-test + +[ ] [ "g" get layout ] unit-test + +[ V{ { 0 0 } { 30 10 } } ] +[ "g" get children>> [ loc>> ] map ] unit-test + + +baseline+ >>align + { 24 24 } >>dim add-gadget +12 9 { 15 15 } add-gadget +"g" set + +[ { 39 24 } ] [ "g" get pref-dim ] unit-test \ No newline at end of file diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index 95f04dfe4d..f47b374aeb 100644 --- a/basis/ui/gadgets/packs/packs.factor +++ b/basis/ui/gadgets/packs/packs.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences ui.gadgets ui.baseline-alignment kernel math -math.functions math.vectors math.order math.rectangles namespaces -accessors fry combinators arrays ; +USING: sequences ui.gadgets ui.baseline-alignment +ui.baseline-alignment.private kernel math math.functions math.vectors +math.order math.rectangles namespaces accessors fry combinators arrays ; IN: ui.gadgets.packs TUPLE: pack < gadget @@ -84,8 +84,7 @@ M: pack pref-dim* children>> dup pref-dims measure-metrics drop ; : pack-cap-height ( pack -- n ) - children>> [ cap-height ] map sift - [ f ] [ supremum ] if-empty ; + children>> [ cap-height ] map ?supremum ; PRIVATE> diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor index 0529437a76..01abe8b3d9 100644 --- a/basis/ui/gadgets/panes/panes-tests.factor +++ b/basis/ui/gadgets/panes/panes-tests.factor @@ -2,7 +2,7 @@ USING: alien ui.gadgets.panes ui.gadgets namespaces kernel sequences io io.styles io.streams.string tools.test prettyprint definitions help help.syntax help.markup help.stylesheet splitting ui.gadgets.debug models math summary -inspector accessors help.topics see ; +inspector accessors help.topics see fry ; IN: ui.gadgets.panes.tests : #children ( -- n ) "pane" get children>> length ; @@ -18,8 +18,9 @@ IN: ui.gadgets.panes.tests [ t ] [ #children "num-children" get = ] unit-test : test-gadget-text ( quot -- ? ) - dup make-pane gadget-text dup print "======" print - swap with-string-writer dup print = ; + '[ _ call( -- ) ] + [ make-pane gadget-text dup print "======" print ] + [ with-string-writer dup print ] bi = ; [ t ] [ [ "hello" write ] test-gadget-text ] unit-test [ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test diff --git a/basis/ui/gadgets/paragraphs/paragraphs-tests.factor b/basis/ui/gadgets/paragraphs/paragraphs-tests.factor index fcc121e584..c8494216b4 100644 --- a/basis/ui/gadgets/paragraphs/paragraphs-tests.factor +++ b/basis/ui/gadgets/paragraphs/paragraphs-tests.factor @@ -27,7 +27,7 @@ INSTANCE: fake-break word-break [ { 0 0 } ] [ "a" get loc>> ] unit-test -[ { 45 15 } ] [ "b" get loc>> ] unit-test +[ { 45 7 } ] [ "b" get loc>> ] unit-test [ { 0 30 } ] [ "c" get loc>> ] unit-test diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor index 621e7006c9..a0799c7b86 100644 --- a/basis/ui/gadgets/presentations/presentations.factor +++ b/basis/ui/gadgets/presentations/presentations.factor @@ -10,7 +10,7 @@ IN: ui.gadgets.presentations TUPLE: presentation < button object hook ; : invoke-presentation ( presentation command -- ) - [ [ dup hook>> call ] [ object>> ] bi ] dip + [ [ dup hook>> call( presentation -- ) ] [ object>> ] bi ] dip invoke-command ; : invoke-primary ( presentation -- ) diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor index 8e0131ec31..011afa5c97 100644 --- a/basis/ui/gadgets/scrollers/scrollers-docs.factor +++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor @@ -11,11 +11,11 @@ HELP: find-scroller { $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } } { $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ; -HELP: scroller-value +HELP: scroll-position { $values { "scroller" scroller } { "loc" "a pair of integers" } } { $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; -{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words +{ scroll-position set-scroll-position scroll>bottom scroll>top scroll>rect } related-words HELP: { $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } } @@ -23,7 +23,7 @@ HELP: { } related-words -HELP: scroll +HELP: set-scroll-position { $values { "scroller" scroller } { "value" "a pair of integers" } } { $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; @@ -48,8 +48,8 @@ ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets" { $subsection scroller } { $subsection } "Getting and setting the scroll position:" -{ $subsection scroller-value } -{ $subsection scroll } +{ $subsection scroll-position } +{ $subsection set-scroll-position } "Writing scrolling-aware gadgets:" { $subsection scroll>bottom } { $subsection scroll>top } diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index d4cdc95daf..4002c8b40e 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -45,13 +45,13 @@ IN: ui.gadgets.scrollers.tests [ { 100 100 } ] [ "s" get viewport>> gadget-child pref-dim ] unit-test - [ ] [ { 0 0 } "s" get scroll ] unit-test + [ ] [ { 0 0 } "s" get set-scroll-position ] unit-test [ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test [ { 100 100 } ] [ "s" get model>> range-max-value ] unit-test - [ ] [ { 10 20 } "s" get scroll ] unit-test + [ ] [ { 10 20 } "s" get set-scroll-position ] unit-test [ { 10 20 } ] [ "s" get model>> range-value ] unit-test @@ -74,7 +74,7 @@ dup layout drop "g2" get scroll>gadget "s" get layout - "s" get scroller-value + "s" get scroll-position ] map [ { 0 0 } = ] all? ] unit-test @@ -104,5 +104,3 @@ dup layout model>> dependencies>> [ range-max value>> ] map { 0 0 } = ] unit-test - -\ must-infer diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index a526cc618b..0852a6fe5d 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -29,6 +29,13 @@ M: gadget viewport-column-header drop f ; : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ; +: set-scroll-position ( value scroller -- ) + [ + viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi + 4array flip + ] keep + 2dup control-value = [ 2drop ] [ set-control-value ] if ; + > [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi - 4array flip - ] keep - 2dup control-value = [ 2drop ] [ set-control-value ] if ; - : (scroll>rect) ( rect scroller -- ) { - [ scroller-value vneg offset-rect ] + [ scroll-position vneg offset-rect ] [ viewport>> dim>> rect-min ] [ viewport>> loc>> offset-rect ] [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ] - [ scroller-value v+ ] - [ scroll ] + [ scroll-position v+ ] + [ set-scroll-position ] } cleave ; : relative-scroll-rect ( rect gadget scroller -- newrect ) @@ -72,7 +72,7 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ; 2&& ; : (update-scroller) ( scroller -- ) - [ scroller-value ] keep scroll ; + [ scroll-position ] keep set-scroll-position ; : (scroll>gadget) ( gadget scroller -- ) 2dup swap child? [ @@ -82,7 +82,8 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ; ] [ f >>follows (update-scroller) drop ] if ; : (scroll>bottom) ( scroller -- ) - [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ; + [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep + set-scroll-position ; GENERIC: update-scroller ( scroller follows -- ) diff --git a/basis/ui/gadgets/search-tables/search-tables-tests.factor b/basis/ui/gadgets/search-tables/search-tables-tests.factor new file mode 100644 index 0000000000..5a627286f9 --- /dev/null +++ b/basis/ui/gadgets/search-tables/search-tables-tests.factor @@ -0,0 +1,3 @@ +IN: ui.gadgets.search-tables.tests +USING: ui.gadgets.search-tables sequences tools.test ; +[ [ second ] ] must-infer diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor index 4a2983bfe0..fc564b6ffe 100644 --- a/basis/ui/gadgets/search-tables/search-tables.factor +++ b/basis/ui/gadgets/search-tables/search-tables.factor @@ -28,6 +28,7 @@ TUPLE: search-field < track field ; : ( model -- gadget ) horizontal search-field new-track + 0 >>fill { 5 5 } >>gap +baseline+ >>align swap 10 >>min-cols >>field @@ -73,7 +74,7 @@ CONSULT: table-protocol search-table table>> ; dup field>> { 2 2 } f track-add values search 500 milliseconds quot renderer f >>takes-focus? >>table - dup table>> 1 track-add ; + dup table>> 1 track-add ; inline M: search-table model-changed nip field>> clear-search-field ; 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/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor index 592900d0cb..39e42aa723 100644 --- a/basis/ui/gadgets/slots/slots.factor +++ b/basis/ui/gadgets/slots/slots.factor @@ -23,14 +23,14 @@ TUPLE: slot-editor < track ref close-hook update-hook text ; } define-command : close ( slot-editor -- ) - dup close-hook>> call ; + dup close-hook>> call( slot-editor -- ) ; \ close H{ { +description+ "Close the slot editor without saving changes." } } define-command : close-and-update ( slot-editor -- ) - [ update-hook>> call ] [ close ] bi ; + [ update-hook>> call( -- ) ] [ close ] bi ; : slot-editor-value ( slot-editor -- object ) text>> control-value parse-fresh first ; @@ -44,11 +44,8 @@ TUPLE: slot-editor < track ref close-hook update-hook text ; { +description+ "Parse the object being edited, and store the result back into the edited slot." } } define-command -: eval-1 ( string -- object ) - 1array [ eval ] with-datastack first ; - : com-eval ( slot-editor -- ) - [ [ text>> editor-string eval-1 ] [ ref>> ] bi set-ref ] + [ [ text>> editor-string eval( -- result ) ] [ ref>> ] bi set-ref ] [ close-and-update ] bi ; 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-tests.factor b/basis/ui/gadgets/tables/tables-tests.factor index 11f080af0a..3191753324 100644 --- a/basis/ui/gadgets/tables/tables-tests.factor +++ b/basis/ui/gadgets/tables/tables-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.tables.tests -USING: ui.gadgets.tables ui.gadgets.scrollers accessors -models namespaces tools.test kernel ; +USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors +models namespaces tools.test kernel combinators ; SINGLETON: test-renderer @@ -8,15 +8,40 @@ M: test-renderer row-columns drop ; M: test-renderer column-titles drop { "First" "Last" } ; -[ ] [ +: test-table ( -- table ) { { "Britney" "Spears" } { "Justin" "Timberlake" } { "Don" "Stewart" } - } test-renderer
- "table" set + } test-renderer
; + +[ ] [ + test-table "table" set ] unit-test [ ] [ "table" get "scroller" set +] unit-test + +[ { "Justin" "Timberlake" } { "Britney" "Spears" } ] [ + test-table t >>selection-required? dup [ + { + [ 1 select-row ] + [ + model>> { + { "Justin" "Timberlake" } + { "Britney" "Spears" } + { "Don" "Stewart" } + } swap set-model + ] + [ selected-row drop ] + [ + model>> { + { "Britney" "Spears" } + { "Don" "Stewart" } + } swap set-model + ] + [ selected-row drop ] + } cleave + ] with-grafted-gadget ] unit-test \ No newline at end of file diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 77249149ae..ba3b5a2f78 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -5,8 +5,8 @@ math.functions math.rectangles math.order math.vectors namespaces opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support -math.rectangles models math.ranges sequences combinators fonts locals -strings ; +math.rectangles models math.ranges sequences combinators +combinators.short-circuit fonts locals strings ; IN: ui.gadgets.tables ! Row rendererer protocol @@ -46,27 +46,34 @@ 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 ; > ] dip [ cell-width ] with map ; + [ font>> ] dip [ [ cell-width ] [ cell-padding ] bi + ] with map ; : compute-total-width ( gap widths -- total ) swap [ column-offsets drop ] keep - ; @@ -162,9 +169,10 @@ M: table layout* '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each ] bi ; -: column-loc ( font column width align -- loc ) - [ [ cell-width ] dip swap - ] dip - * >integer 0 2array ; +:: column-loc ( font column width align -- loc ) + font column cell-width width swap - align * column cell-padding 2 / 1 align - * + + font column cell-height \ line-height get swap - 2 / + [ >integer ] bi@ 2array ; : translate-column ( width gap -- ) + 0 2array gl-translate ; @@ -203,18 +211,21 @@ M: table draw-line ( row index table -- ) M: table draw-gadget* dup control-value empty? [ drop ] [ - { - [ draw-selected-row ] - [ draw-lines ] - [ draw-column-lines ] - [ draw-focused-row ] - [ draw-moused-row ] - } cleave + dup line-height \ line-height [ + { + [ draw-selected-row ] + [ draw-lines ] + [ draw-column-lines ] + [ draw-focused-row ] + [ draw-moused-row ] + } cleave + ] with-variable ] if ; M: table line-height ( table -- y ) [ font>> ] [ renderer>> prototype-row ] bi - [ cell-height ] with [ max ] map-reduce ; + [ [ cell-height ] [ cell-padding ] bi + ] with + [ max ] map-reduce ; M: table pref-dim* [ compute-column-widths drop ] keep @@ -237,9 +248,6 @@ PRIVATE> : update-selected-value ( table -- ) [ selected-row drop ] [ selected-value>> ] bi set-model ; -: initial-selected-index ( model table -- n/f ) - [ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ; - : show-row-summary ( table n -- ) over nth-row [ swap [ renderer>> row-value ] keep show-summary ] @@ -249,8 +257,28 @@ PRIVATE> : hide-mouse-help ( table -- ) f >>mouse-index [ hide-status ] [ relayout-1 ] bi ; +: find-row-index ( value table -- n/f ) + [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ; + +: initial-selected-index ( table -- n/f ) + { + [ model>> value>> empty? not ] + [ selection-required?>> ] + [ drop 0 ] + } 1&& ; + +: (update-selected-index) ( table -- n/f ) + [ selected-value>> value>> ] keep over + [ find-row-index ] [ 2drop f ] if ; + +: update-selected-index ( table -- n/f ) + { + [ (update-selected-index) ] + [ initial-selected-index ] + } 1|| ; + M: table model-changed - [ nip ] [ initial-selected-index ] 2bi { + nip dup update-selected-index { [ >>selected-index f >>mouse-index drop ] [ show-row-summary ] [ drop update-selected-value ] @@ -293,6 +321,8 @@ PRIVATE> : table-button-up ( table -- ) dup row-action? [ row-action ] [ update-selected-value ] if ; +PRIVATE> + : select-row ( table n -- ) over validate-line [ (select-row) ] @@ -300,6 +330,8 @@ PRIVATE> [ show-row-summary ] 2tri ; +> ] dip '[ _ + ] [ 0 ] if* select-row ; @@ -345,9 +377,9 @@ PRIVATE> show-operations-menu ] [ drop ] if-mouse-row ; -: focus-table ( table -- ) t >>focused? drop ; +: focus-table ( table -- ) t >>focused? relayout-1 ; -: unfocus-table ( table -- ) f >>focused? drop ; +: unfocus-table ( table -- ) f >>focused? relayout-1 ; table "sundry" f { { mouse-enter show-mouse-help } @@ -379,14 +411,16 @@ TUPLE: column-headers < gadget table ; column-title-background >>interior ; : draw-column-titles ( table -- ) - { - [ renderer>> column-titles ] - [ column-widths>> ] - [ table-column-alignment ] - [ font>> column-title-font ] - [ gap>> ] - } cleave - draw-columns ; + dup font>> font-metrics height>> \ line-height [ + { + [ renderer>> column-titles ] + [ column-widths>> ] + [ table-column-alignment ] + [ font>> column-title-font ] + [ gap>> ] + } cleave + draw-columns + ] with-variable ; M: column-headers draw-gadget* table>> draw-column-titles ; diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor index c14c7f01fb..b154ef2322 100644 --- a/basis/ui/gadgets/viewports/viewports.factor +++ b/basis/ui/gadgets/viewports/viewports.factor @@ -23,7 +23,7 @@ M: viewport layout* M: viewport focusable-child* gadget-child ; -: scroller-value ( scroller -- loc ) +: scroll-position ( scroller -- loc ) model>> range-value [ >integer ] map ; M: viewport model-changed @@ -31,7 +31,7 @@ M: viewport model-changed [ relayout-1 ] [ [ gadget-child ] - [ scroller-value vneg ] + [ scroll-position vneg ] [ constraint>> ] tri v* >>loc drop ] bi ; diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor old mode 100644 new mode 100755 index e3c1226f22..d4e9790d89 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -1,6 +1,6 @@ USING: ui.gadgets ui.render ui.text ui.text.private ui.gestures ui.backend help.markup help.syntax -models opengl strings ; +models opengl sequences strings ; IN: ui.gadgets.worlds HELP: user-input @@ -48,8 +48,8 @@ HELP: world } ; HELP: -{ $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 655c9ba49d..3568559eac --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -1,17 +1,32 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations kernel math models -namespaces opengl 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 ; +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.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? + layers + title status status-owner + text-handle handle images + window-loc + pixel-format-attributes ; + +TUPLE: world-attributes + { world-class initial: world } + 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 ; @@ -44,18 +59,23 @@ 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 ; + { 0 0 } >>window-loc ; -: ( gadget title status -- world ) - world new-world ; +: apply-world-attributes ( world attributes -- world ) + { + [ title>> >>title ] + [ status>> >>status ] + [ pixel-format-attributes>> >>pixel-format-attributes ] + [ 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 @@ -76,16 +96,36 @@ SYMBOL: flush-layout-cache-hook flush-layout-cache-hook [ [ ] ] initialize -: (draw-world) ( world -- ) - dup handle>> [ - { - [ 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. @@ -106,7 +146,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 @@ -147,3 +190,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-tests.factor b/basis/ui/gestures/gestures-tests.factor index 402015ee7c..3bcea27819 100644 --- a/basis/ui/gestures/gestures-tests.factor +++ b/basis/ui/gestures/gestures-tests.factor @@ -1,5 +1,2 @@ IN: ui.gestures.tests USING: tools.test ui.gestures ; - -\ handle-gesture must-infer -\ send-queued-gesture must-infer \ No newline at end of file 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/basis/ui/images/images.factor b/basis/ui/images/images.factor index 8e36f2a3b1..2b1caa8ab9 100755 --- a/basis/ui/images/images.factor +++ b/basis/ui/images/images.factor @@ -20,7 +20,7 @@ PRIVATE> : rendered-image ( path -- texture ) world get image-texture-cache - [ cached-image [ { 0 0 } ] keep dim>> ] cache ; + [ cached-image { 0 0 } ] cache ; : draw-image ( image-name -- ) rendered-image draw-texture ; diff --git a/basis/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor index cfec6613b1..4114a2c3b2 100644 --- a/basis/ui/operations/operations-docs.factor +++ b/basis/ui/operations/operations-docs.factor @@ -4,7 +4,7 @@ ui.gestures ; IN: ui.operations : $operations ( element -- ) - >quotation call + >quotation call( -- obj ) f operations>commands command-map. ; diff --git a/basis/ui/operations/operations-tests.factor b/basis/ui/operations/operations-tests.factor index 4612ea79b0..6e8339a539 100644 --- a/basis/ui/operations/operations-tests.factor +++ b/basis/ui/operations/operations-tests.factor @@ -26,5 +26,3 @@ io.streams.string math help help.markup accessors ; [ ] [ [ { $operations \ + } print-element ] with-string-writer drop ] unit-test - -\ object-operations must-infer \ No newline at end of file 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/render/render-tests.factor b/basis/ui/render/render-tests.factor index 3410560ba9..3ae0082be1 100644 --- a/basis/ui/render/render-tests.factor +++ b/basis/ui/render/render-tests.factor @@ -1,4 +1,2 @@ IN: ui.render.tests USING: ui.render tools.test ; - -\ draw-gadget must-infer \ No newline at end of file diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index 09c26fd271..c4e6f56886 100755 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math.rectangles math.vectors namespaces kernel accessors -assocs combinators sequences opengl opengl.gl opengl.glu colors +assocs combinators sequences opengl opengl.gl colors colors.constants ui.gadgets ui.pens ; IN: ui.render @@ -22,7 +22,7 @@ SYMBOL: viewport-translation dim>> [ { 0 1 } v* viewport-translation set ] [ [ { 0 0 } ] dip gl-viewport ] - [ [ 0 ] dip first2 0 gluOrtho2D ] tri + [ [ 0 ] dip first2 0 1 -1 glOrtho ] tri ] [ clip set ] bi do-clip ; diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor index 404624da95..0d720ac0b1 100755 --- a/basis/ui/text/core-text/core-text.factor +++ b/basis/ui/text/core-text/core-text.factor @@ -20,9 +20,7 @@ M: core-text-renderer flush-layout-cache : rendered-line ( font string -- texture ) world get world-text-handle [ - cached-line - [ image>> ] [ loc>> ] [ image>> dim>> ] tri - + cached-line [ image>> ] [ loc>> ] bi ] 2cache ; M: core-text-renderer draw-string ( font string -- ) diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor index 46328d11d5..92c4fe5c75 100755 --- a/basis/ui/text/pango/pango.factor +++ b/basis/ui/text/pango/pango.factor @@ -16,9 +16,7 @@ M: pango-renderer flush-layout-cache : rendered-layout ( font string -- texture ) world get world-text-handle [ - cached-layout - [ image>> ] [ text-position vneg ] [ image>> dim>> ] tri - + cached-layout [ image>> ] [ text-position vneg ] bi ] 2cache ; M: pango-renderer draw-string ( font string -- ) diff --git a/basis/ui/text/text-docs.factor b/basis/ui/text/text-docs.factor index 4ac2fbbaa8..c2732754f6 100644 --- a/basis/ui/text/text-docs.factor +++ b/basis/ui/text/text-docs.factor @@ -46,7 +46,7 @@ HELP: offset>x HELP: line-metrics { $values { "font" font } { "string" string } { "metrics" line-metrics } } -{ $contract "Outputs a " { $link line-metrics } " object with text measurements." } ; +{ $contract "Outputs a " { $link metrics } " object with text measurements." } ; ARTICLE: "text-rendering" "Rendering text" "The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11." diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor index d787fe8ea9..c1f05182e6 100755 --- a/basis/ui/text/text.factor +++ b/basis/ui/text/text.factor @@ -66,7 +66,7 @@ M: string draw-text draw-string ; M: selection draw-text draw-string ; M: array draw-text - GL_MODELVIEW [ + [ [ [ draw-string ] [ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi @@ -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/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor index dcec4ab17e..d56da86b86 100755 --- a/basis/ui/text/uniscribe/uniscribe.factor +++ b/basis/ui/text/uniscribe/uniscribe.factor @@ -16,7 +16,7 @@ M: uniscribe-renderer flush-layout-cache : rendered-script-string ( font string -- texture ) world get world-text-handle - [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi ] + [ cached-script-string image>> { 0 0 } ] 2cache ; M: uniscribe-renderer draw-string ( font string -- ) diff --git a/basis/ui/tools/browser/browser-tests.factor b/basis/ui/tools/browser/browser-tests.factor index 3757f392c4..8027babc3f 100644 --- a/basis/ui/tools/browser/browser-tests.factor +++ b/basis/ui/tools/browser/browser-tests.factor @@ -1,5 +1,4 @@ IN: ui.tools.browser.tests USING: tools.test ui.gadgets.debug ui.tools.browser math ; -\ must-infer [ ] [ \ + [ ] with-grafted-gadget ] unit-test diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index e242b743f8..1b8af1dd03 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -1,23 +1,36 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger help help.topics help.crossref help.home kernel -models compiler.units assocs words vocabs accessors fry -combinators.short-circuit namespaces sequences models -models.history help.apropos combinators ui.commands ui.gadgets -ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks -ui.gestures ui.gadgets.buttons ui.gadgets.packs -ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar -ui.gadgets.glass ui.gadgets.borders ui.tools.common -ui.tools.browser.popups ui ; +USING: debugger classes help help.topics help.crossref help.home kernel models +compiler.units assocs words vocabs accessors fry arrays +combinators.short-circuit namespaces sequences models help.apropos +combinators ui ui.commands ui.gadgets ui.gadgets.panes +ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons +ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels +ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports +ui.tools.common ui.tools.browser.popups ui.tools.browser.history ; IN: ui.tools.browser -TUPLE: browser-gadget < tool pane scroller search-field popup ; +TUPLE: browser-gadget < tool history pane scroller search-field popup ; { 650 400 } browser-gadget set-tool-dim +M: browser-gadget history-value + [ control-value ] [ scroller>> scroll-position ] + bi 2array ; + +M: browser-gadget set-history-value + [ first2 ] dip + [ set-control-value ] [ scroller>> set-scroll-position ] + bi-curry bi* ; + : show-help ( link browser-gadget -- ) - [ >link ] [ model>> ] bi* - [ [ add-recent ] [ add-history ] bi* ] [ set-model ] 2bi ; + [ >link ] dip + [ + 2dup model>> value>> = + [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if + ] + [ model>> set-model ] + 2bi ; : ( browser-gadget -- gadget ) model>> [ '[ _ print-topic ] try ] ; @@ -41,7 +54,8 @@ TUPLE: browser-gadget < tool pane scroller search-field popup ; : ( link -- gadget ) vertical browser-gadget new-track 1 >>fill - swap >link >>model + swap >link >>model + dup >>history dup >>search-field dup { 3 3 } { 1 0 } >>fill f track-add dup >>pane @@ -80,6 +94,10 @@ M: browser-gadget focusable-child* search-field>> ; : browser-window ( -- ) "help.home" (browser-window) ; +: error-help-window ( error -- ) + [ error-help ] + [ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ; + \ browser-window H{ { +nullary+ t } } define-command : com-browse ( link -- ) @@ -93,9 +111,9 @@ M: browser-gadget focusable-child* search-field>> ; \ show-browser H{ { +nullary+ t } } define-command -: com-back ( browser -- ) model>> go-back ; +: com-back ( browser -- ) history>> go-back ; -: com-forward ( browser -- ) model>> go-forward ; +: com-forward ( browser -- ) history>> go-forward ; : com-home ( browser -- ) "help.home" swap show-help ; diff --git a/basis/ui/tools/browser/history/authors.txt b/basis/ui/tools/browser/history/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/tools/browser/history/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/tools/browser/history/history-tests.factor b/basis/ui/tools/browser/history/history-tests.factor new file mode 100644 index 0000000000..454e4700a0 --- /dev/null +++ b/basis/ui/tools/browser/history/history-tests.factor @@ -0,0 +1,42 @@ +USING: namespaces ui.tools.browser.history sequences tools.test +accessors kernel ; +IN: ui.tools.browser.history.tests + +TUPLE: dummy obj ; + +M: dummy history-value obj>> ; +M: dummy set-history-value (>>obj) ; + +dummy new "history" set + +"history" get add-history + +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get add-history +3 "history" get owner>> set-history-value + +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get add-history +4 "history" get owner>> set-history-value + +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get go-back + +[ 3 ] [ "history" get owner>> history-value ] unit-test + +[ t ] [ "history" get back>> empty? ] unit-test +[ f ] [ "history" get forward>> empty? ] unit-test + +"history" get go-forward + +[ 4 ] [ "history" get owner>> history-value ] unit-test + +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + diff --git a/basis/ui/tools/browser/history/history.factor b/basis/ui/tools/browser/history/history.factor new file mode 100644 index 0000000000..f80189c783 --- /dev/null +++ b/basis/ui/tools/browser/history/history.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences locals ; +IN: ui.tools.browser.history + +TUPLE: history owner back forward ; + +: ( owner -- history ) + V{ } clone V{ } clone history boa ; + +GENERIC: history-value ( object -- value ) + +GENERIC: set-history-value ( value object -- ) + +: (add-history) ( history to -- ) + swap owner>> history-value dup [ swap push ] [ 2drop ] if ; + +:: go-back/forward ( history to from -- ) + from empty? [ + history to (add-history) + from pop history owner>> set-history-value + ] unless ; + +: go-back ( history -- ) + dup [ forward>> ] [ back>> ] bi go-back/forward ; + +: go-forward ( history -- ) + dup [ back>> ] [ forward>> ] bi go-back/forward ; + +: add-history ( history -- ) + dup forward>> delete-all + dup back>> (add-history) ; \ No newline at end of file diff --git a/basis/ui/tools/browser/popups/popups.factor b/basis/ui/tools/browser/popups/popups.factor index 05d7779305..2cd90ab335 100644 --- a/basis/ui/tools/browser/popups/popups.factor +++ b/basis/ui/tools/browser/popups/popups.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs definitions fry help.topics kernel colors.constants math.rectangles models.arrow namespaces sequences -sorting definitions.icons ui.gadgets ui.gadgets.glass +sorting definitions.icons tools.crossref ui.gadgets ui.gadgets.glass ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations ui.pens.solid ui.images ; @@ -46,7 +46,7 @@ SLOT: model : show-links-popup ( browser-gadget quot title -- ) [ dup model>> ] 2dip - [ hand-loc get { 0 0 } show-glass ] [ request-focus ] bi ; + [ hand-loc get { 0 0 } show-glass ] [ request-focus ] bi ; inline : com-show-outgoing-links ( browser-gadget -- ) [ uses ] "Outgoing links" show-links-popup ; 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/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index c3ead4e3f5..42666ab064 100644 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback -ui.tools.inspector ; +ui.tools.inspector ui.tools.browser ; IN: ui.tools.debugger TUPLE: debugger < track error restarts restart-hook restart-list continuation ; @@ -86,9 +86,7 @@ debugger "gestures" f { : com-traceback ( debugger -- ) continuation>> traceback-window ; -: com-help ( debugger -- ) error>> (:help) ; - -\ com-help H{ { +listener+ t } } define-command +: com-help ( debugger -- ) error>> error-help-window ; : com-edit ( debugger -- ) error>> (:edit) ; diff --git a/basis/ui/tools/error-list/authors.txt b/basis/ui/tools/error-list/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/tools/error-list/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/tools/error-list/error-list-docs.factor b/basis/ui/tools/error-list/error-list-docs.factor new file mode 100644 index 0000000000..5040a13be2 --- /dev/null +++ b/basis/ui/tools/error-list/error-list-docs.factor @@ -0,0 +1,19 @@ +IN: ui.tools.error-list +USING: help.markup help.syntax ui.tools.common ui.commands ; + +ARTICLE: "ui.tools.error-list" "UI error list tool" +"The error list tool displays messages generated by tools which process source files and definitions. To display the error list, press " { $command tool "common" show-error-list } " in any UI tool window." +$nl +"The " { $vocab-link "source-files.errors" } " vocabulary contains backend code used by this tool." +{ $heading "Message icons" } +{ $table + { "Icon" "Message type" "Reference" } + ! { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } } + ! { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } } + { { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } } + { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } + { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } } + { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } } +} ; + +ABOUT: "ui.tools.error-list" diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor new file mode 100644 index 0000000000..704ae112e5 --- /dev/null +++ b/basis/ui/tools/error-list/error-list.factor @@ -0,0 +1,191 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays sequences sorting assocs colors.constants fry +combinators combinators.smart combinators.short-circuit editors make +memoize compiler.units fonts kernel io.pathnames prettyprint +source-files.errors math.parser init math.order models models.arrow +models.arrow.smart models.search models.mapping debugger +namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes +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 +compiler.errors tools.errors tools.errors.model ; +IN: ui.tools.error-list + +CONSTANT: source-file-icon + T{ image-name f "vocab:ui/tools/error-list/icons/source-file.tiff" } + +MEMO: error-icon ( type -- image-name ) + error-icon-path ; + +: ( alist -- gadget ) + [ { 15 0 } >>gap ] dip + [ swap add-gadget ] assoc-each ; + +: ( -- model gadget ) + #! Linkage errors are not shown by default. + error-types get [ fatal?>> ] assoc-map + [ [ [ error-icon ] dip ] assoc-map ] + [ ] bi ; + +TUPLE: error-list-gadget < tool +visible-errors source-file error +error-toggle source-file-table error-table error-display ; + +SINGLETON: source-file-renderer + +M: source-file-renderer row-columns + drop first2 [ + [ source-file-icon ] + [ +listener-input+ or ] + [ length number>string ] tri* + ] output>array ; + +M: source-file-renderer prototype-row + drop source-file-icon "" "" 3array ; + +M: source-file-renderer row-value + drop dup [ first [ ] [ f ] if* ] when ; + +M: source-file-renderer column-titles + drop { "" "File" "Errors" } ; + +M: source-file-renderer column-alignment drop { 0 0 1 } ; + +M: source-file-renderer filled-column drop 1 ; + +: ( model -- model' ) + [ group-by-source-file >alist sort-keys ] ; + +:: ( error-list -- table ) + error-list model>> + source-file-renderer +
+ [ invoke-primary-operation ] >>action + COLOR: dark-gray >>column-line-color + 6 >>gap + 5 >>min-rows + 5 >>max-rows + 60 >>min-cols + 60 >>max-cols + t >>selection-required? + error-list source-file>> >>selected-value ; + +SINGLETON: error-renderer + +M: error-renderer row-columns + drop [ + { + [ error-type error-icon ] + [ line#>> [ number>string ] [ "" ] if* ] + [ asset>> [ unparse-short ] [ "" ] if* ] + [ error>> summary ] + } cleave + ] output>array ; + +M: error-renderer prototype-row + drop [ +compiler-error+ error-icon "" "" "" ] output>array ; + +M: error-renderer row-value + drop ; + +M: error-renderer column-titles + drop { "" "Line" "Asset" "Error" } ; + +M: error-renderer column-alignment drop { 0 1 0 0 } ; + +: sort-errors ( seq -- seq' ) + [ [ [ line#>> ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc + sort-keys values ; + +: file-matches? ( error pathname/f -- ? ) + [ file>> ] [ dup [ string>> ] when ] bi* = ; + +: ( error-list -- model ) + [ model>> ] [ source-file>> ] bi + [ file-matches? ] + [ sort-errors ] ; + +:: ( error-list -- table ) + error-list + error-renderer +
+ [ invoke-primary-operation ] >>action + COLOR: dark-gray >>column-line-color + 6 >>gap + 5 >>min-rows + 5 >>max-rows + 60 >>min-cols + 60 >>max-cols + t >>selection-required? + error-list error>> >>selected-value ; + +TUPLE: error-display < track ; + +: ( error-list -- gadget ) + vertical error-display new-track + add-toolbar + swap error>> >>model + dup model>> [ [ print-error ] when* ] 1 track-add ; + +: com-inspect ( error-display -- ) + model>> value>> [ inspector ] when* ; + +: com-help ( error-display -- ) + model>> value>> [ error>> error-help-window ] when* ; + +: com-edit ( error-display -- ) + model>> value>> [ edit-error ] when* ; + +error-display "toolbar" f { + { f com-inspect } + { f com-help } + { f com-edit } +} define-command-map + +: ( error-list -- toolbar ) + [ ] [ error-toggle>> "Show errors:" label-on-left add-gadget ] bi ; + +: ( visible-errors model -- model' ) + [ swap '[ error-type _ at ] filter ] ; + +:: ( model -- gadget ) + vertical error-list-gadget new-track + [ >>error-toggle ] [ >>visible-errors ] bi* + dup visible-errors>> model >>model + f >>source-file + f >>error + dup >>source-file-table + dup >>error-table + dup >>error-display + :> error-list + error-list vertical + { 5 5 } >>gap + error-list f track-add + error-list source-file-table>> "Source files" 1/4 track-add + error-list error-table>> "Errors" 1/2 track-add + error-list error-display>> "Details" 1/4 track-add + { 5 5 } 1 track-add ; + +M: error-list-gadget focusable-child* + source-file-table>> ; + +: error-list-help ( -- ) "ui.tools.error-list" com-browse ; + +\ error-list-help H{ { +nullary+ t } } define-command + +error-list-gadget "toolbar" f { + { T{ key-down f f "F1" } error-list-help } +} define-command-map + +: error-list-window ( -- ) + error-list-model get [ drop all-errors ] + "Errors" open-status-window ; + +: show-error-list ( -- ) + [ error-list-gadget? ] find-window + [ raise-window ] [ error-list-window ] if* ; + +\ show-error-list H{ { +nullary+ t } } define-command diff --git a/basis/ui/tools/error-list/icons/compiler-error.tiff b/basis/ui/tools/error-list/icons/compiler-error.tiff new file mode 100644 index 0000000000..7a53d578fa Binary files /dev/null and b/basis/ui/tools/error-list/icons/compiler-error.tiff differ diff --git a/basis/ui/tools/error-list/icons/help-lint-error.tiff b/basis/ui/tools/error-list/icons/help-lint-error.tiff new file mode 100644 index 0000000000..464728a70c Binary files /dev/null and b/basis/ui/tools/error-list/icons/help-lint-error.tiff differ diff --git a/basis/ui/tools/error-list/icons/linkage-error.tiff b/basis/ui/tools/error-list/icons/linkage-error.tiff new file mode 100644 index 0000000000..78644fd819 Binary files /dev/null and b/basis/ui/tools/error-list/icons/linkage-error.tiff differ diff --git a/basis/ui/tools/error-list/icons/note.tiff b/basis/ui/tools/error-list/icons/note.tiff new file mode 100644 index 0000000000..834dea6b82 Binary files /dev/null and b/basis/ui/tools/error-list/icons/note.tiff differ diff --git a/basis/ui/tools/error-list/icons/source-file.tiff b/basis/ui/tools/error-list/icons/source-file.tiff new file mode 100644 index 0000000000..5fb3375520 Binary files /dev/null and b/basis/ui/tools/error-list/icons/source-file.tiff differ diff --git a/basis/ui/tools/error-list/icons/syntax-error.tiff b/basis/ui/tools/error-list/icons/syntax-error.tiff new file mode 100644 index 0000000000..5446c80e15 Binary files /dev/null and b/basis/ui/tools/error-list/icons/syntax-error.tiff differ diff --git a/basis/ui/tools/error-list/icons/unit-test-error.tiff b/basis/ui/tools/error-list/icons/unit-test-error.tiff new file mode 100644 index 0000000000..b6ea439f5a Binary files /dev/null and b/basis/ui/tools/error-list/icons/unit-test-error.tiff differ diff --git a/basis/ui/tools/inspector/inspector-docs.factor b/basis/ui/tools/inspector/inspector-docs.factor index c329f037e1..72f4e1fe66 100644 --- a/basis/ui/tools/inspector/inspector-docs.factor +++ b/basis/ui/tools/inspector/inspector-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax ui.commands ui.gadgets.slots -ui.gadgets.editors ; +ui.gadgets.editors kernel ; IN: ui.tools.inspector ARTICLE: "ui-inspector-edit" "Editing slot values in the inspector" @@ -21,4 +21,8 @@ $nl "The UI inspector is an instance of " { $link inspector-gadget } "." { $subsection "ui-inspector-edit" } ; +HELP: inspector +{ $values { "obj" object } } +{ $description "Opens a new inspector window displaying the slots of " { $snippet "obj" } "." } ; + ABOUT: "ui-inspector" \ No newline at end of file diff --git a/basis/ui/tools/inspector/inspector-tests.factor b/basis/ui/tools/inspector/inspector-tests.factor index 44e20fb0fd..2971b1e8cb 100644 --- a/basis/ui/tools/inspector/inspector-tests.factor +++ b/basis/ui/tools/inspector/inspector-tests.factor @@ -1,6 +1,4 @@ IN: ui.tools.inspector.tests USING: tools.test ui.tools.inspector math models ; -\ must-infer - [ ] [ \ + com-edit-slot ] unit-test \ No newline at end of file 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 afe890b9c5..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 @@ -27,6 +27,8 @@ ARTICLE: "ui-listener" "UI listener" { $command-map interactor "quotation" } { $heading "Editing commands" } "The text editing commands are standard; see " { $link "gadgets-editors-commands" } "." +$nl +"The listener displays a summary with any outstanding error conditions before every prompt. See " { $link "ui.tools.error-list" } " for details." { $heading "Implementation" } "Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ; diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 986e1270eb..e06e17374f 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -6,8 +6,6 @@ threads arrays generic threads accessors listener math calendar concurrency.promises io ui.tools.common ; IN: ui.tools.listener.tests -\ must-infer - [ [ ] [ >>output "interactor" set ] unit-test @@ -77,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 @@ -152,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 7cb3c70cbc..6ed3577a06 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -1,19 +1,21 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs calendar combinators locals -colors.constants combinators.short-circuit 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 +source-files.errors colors.constants combinators.short-circuit +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.tools.listener.history ui.images ui.tools.error-list +tools.errors.model ; +FROM: source-files.errors => all-errors ; IN: ui.tools.listener ! If waiting is t, we're waiting for user input, and invoking @@ -31,9 +33,10 @@ output history flag mailbox thread waiting token-model word-model popup ; : interactor-busy? ( interactor -- ? ) #! We're busy if there's no thread to resume. - [ waiting>> ] - [ thread>> dup [ thread-registered? ] when ] - bi and not ; + { + [ waiting>> ] + [ thread>> dup [ thread-registered? ] when ] + } 1&& not ; SLOT: vocabs @@ -170,7 +173,7 @@ M: interactor dispose drop ; over set-caret mark>caret ; -TUPLE: listener-gadget < tool input output scroller ; +TUPLE: listener-gadget < tool error-summary output scroller input ; { 600 700 } listener-gadget set-tool-dim @@ -180,17 +183,35 @@ TUPLE: listener-gadget < tool input output scroller ; : listener-streams ( listener -- input output ) [ input>> ] [ output>> ] bi ; -: init-listener ( listener -- listener ) +: init-input/output ( listener -- listener ) [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi dup listener-streams >>output drop ; -: ( -- gadget ) +: error-summary. ( -- ) + error-counts keys [ + H{ { table-gap { 3 3 } } } [ + [ [ [ icon>> write-image ] with-cell ] each ] with-row + ] tabular-output + { "Press " { $command tool "common" show-error-list } " to view errors." } + print-element + ] unless-empty ; + +: ( -- gadget ) + error-list-model get [ drop error-summary. ] + COLOR: light-yellow >>interior ; + +: init-error-summary ( listener -- listener ) + >>error-summary + dup error-summary>> f track-add ; + +: ( -- listener ) vertical listener-gadget new-track add-toolbar - init-listener + init-input/output dup output>> >>scroller - dup scroller>> 1 track-add ; + dup scroller>> 1 track-add + init-error-summary ; M: listener-gadget focusable-child* input>> dup popup>> or ; @@ -360,6 +381,7 @@ interactor "completion" f { dup listener-streams [ [ com-browse ] help-hook set '[ [ _ input>> ] 2dip debugger-popup ] error-hook set + error-summary? off tip-of-the-day. nl listener ] with-streams* ; diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index c6371ac8aa..650d751ee2 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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.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 ui.gestures ui.operations -ui.tools.deploy models help.tips ; +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 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 +ui.gestures ui.operations ui.tools.deploy models help.tips +source-files.errors ; IN: ui.tools.operations ! Objects @@ -86,6 +86,21 @@ IN: ui.tools.operations { +listener+ t } } define-operation +! Source file error +[ source-file-error? ] \ edit-error H{ + { +primary+ t } + { +secondary+ t } + { +listener+ t } +} define-operation + +: com-reload ( error -- ) + file>> run-file ; + +[ compiler-error? ] \ com-reload H{ + { +listener+ t } +} define-operation + +! Definitions : com-forget ( defspec -- ) [ forget ] with-compilation-unit ; @@ -173,4 +188,4 @@ interactor "These commands operate on the entire contents of the input area." [ ] [ quot-action ] -define-operation-map +define-operation-map \ No newline at end of file diff --git a/basis/ui/tools/profiler/profiler-docs.factor b/basis/ui/tools/profiler/profiler-docs.factor index e2a0ef5f4e..fad2b3614f 100644 --- a/basis/ui/tools/profiler/profiler-docs.factor +++ b/basis/ui/tools/profiler/profiler-docs.factor @@ -1,10 +1,14 @@ IN: ui.tools.profiler -USING: help.markup help.syntax ui.operations help.tips ; +USING: help.markup help.syntax ui.operations ui.commands help.tips ; -ARTICLE: "ui.tools.profiler" "UI profiler tool" +ARTICLE: "ui.tools.profiler" "UI profiler tool" "The " { $vocab-link "ui.tools.profiler" } " vocabulary implements a graphical tool for viewing profiling results (see " { $link "profiling" } ")." $nl -"To use the profiler, enter a piece of code in the listener's input area and press " { $operation com-profile } "." ; +"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "." +$nl +"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring." +$nl +"Consult " { $link "profiling" } " for details about the profiler itself." ; TIP: "Press " { $operation com-profile } " to run the code in the input field with profiling enabled (" { $link "ui.tools.profiler" } ")." ; diff --git a/basis/ui/tools/profiler/profiler-tests.factor b/basis/ui/tools/profiler/profiler-tests.factor new file mode 100644 index 0000000000..c1c8fdbff9 --- /dev/null +++ b/basis/ui/tools/profiler/profiler-tests.factor @@ -0,0 +1,3 @@ +USING: ui.tools.profiler tools.test ; + + diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index 1c2318a35e..5fef64ea88 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -11,6 +11,7 @@ ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders ui.tools.browser ui.tools.common ui.baseline-alignment ui.operations ui.images ; FROM: models.arrow => ; +FROM: models.arrow.smart => ; FROM: models.product => ; IN: ui.tools.profiler @@ -112,8 +113,8 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ; : ( profiler -- model ) [ [ method-counters ] dip - [ generic>> ] [ class>> ] bi 3array - [ first3 '[ _ _ method-matches? ] filter ] + [ generic>> ] [ class>> ] bi + [ '[ _ _ method-matches? ] filter ] ] keep ; : sort-by-name ( obj1 obj2 -- <=> ) @@ -208,6 +209,6 @@ profiler-gadget "toolbar" f { : profiler-window ( -- ) "Profiling results" open-status-window ; -: com-profile ( quot -- ) profile profiler-window ; +: com-profile ( quot -- ) profile profiler-window ; inline MAIN: profiler-window diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index 93f45591a5..7be008f296 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -31,17 +31,6 @@ $nl $nl "For more about presentation gadgets, see " { $link "ui.gadgets.presentations" } "." ; -ARTICLE: "ui-profiler" "UI profiler" -"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results." -$nl -"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "." -$nl -"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring." -$nl -"Consult " { $link "profiling" } " for details about the profiler itself." -{ $command-map profiler-gadget "toolbar" } -"The profiler is an instance of " { $link profiler-gadget } "." ; - ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X" "On Mac OS X, the Factor UI offers additional features which integrate with this operating system." $nl @@ -55,7 +44,7 @@ $nl ARTICLE: "ui-tools" "UI developer tools" "The " { $vocab-link "ui.tools" } " vocabulary hierarchy implements a collection of simple developer tools." -$nl +{ $subsection "starting-ui-tools" } "To take full advantage of the UI tools, you should be using a supported text editor. See " { $link "editor" } "." $nl "Common functionality:" @@ -66,7 +55,8 @@ $nl { $subsection "ui-listener" } { $subsection "ui-browser" } { $subsection "ui-inspector" } -{ $subsection "ui-profiler" } +{ $subsection "ui.tools.error-list" } +{ $subsection "ui.tools.profiler" } { $subsection "ui-walker" } { $subsection "ui.tools.deploy" } "Platform-specific features:" diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index 203953db1a..7ea34e651f 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: memory system kernel tools.vocabs ui.tools.operations -ui.tools.listener ui.tools.browser ui.tools.common +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 @@ -30,4 +30,5 @@ tool "common" f { { T{ key-down f { A+ } "w" } close-window } { T{ key-down f { A+ } "q" } com-exit } { T{ key-down f f "F2" } refresh-all } + { T{ key-down f f "F3" } show-error-list } } define-command-map \ No newline at end of file diff --git a/basis/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor index 011e3b4866..9e73a31282 100644 --- a/basis/ui/tools/walker/walker-docs.factor +++ b/basis/ui/tools/walker/walker-docs.factor @@ -1,6 +1,6 @@ IN: ui.tools.walker USING: help.markup help.syntax ui.commands ui.operations -ui.render tools.walker sequences ; +ui.render tools.walker sequences tools.continuations ; ARTICLE: "ui-walker-step" "Stepping through code" "If the current position points to a word, the various stepping commands behave as follows:" diff --git a/basis/ui/tools/walker/walker-tests.factor b/basis/ui/tools/walker/walker-tests.factor index fefb188239..fe0b57b980 100644 --- a/basis/ui/tools/walker/walker-tests.factor +++ b/basis/ui/tools/walker/walker-tests.factor @@ -1,4 +1,3 @@ USING: ui.tools.walker tools.test ; IN: ui.tools.walker.tests -\ must-infer diff --git a/basis/ui/traverse/traverse-docs.factor b/basis/ui/traverse/traverse-docs.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/basis/ui/traverse/traverse-tests.factor b/basis/ui/traverse/traverse-tests.factor index e18637a652..4d2072db1c 100644 --- a/basis/ui/traverse/traverse-tests.factor +++ b/basis/ui/traverse/traverse-tests.factor @@ -62,4 +62,4 @@ M: object (flatten-tree) , ; { 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range ] unit-test -[ { array children>> } forget ] with-compilation-unit +[ M\ array children>> forget ] with-compilation-unit 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-tests.factor b/basis/ui/ui-tests.factor index 4b4bf9d9ee..06de4eb9c2 100644 --- a/basis/ui/ui-tests.factor +++ b/basis/ui/ui-tests.factor @@ -1,5 +1,2 @@ IN: ui.tests USING: ui ui.private tools.test ; - -\ open-window must-infer -\ update-ui must-infer \ No newline at end of file diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index bf17e455f8..d07403836a 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -2,9 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words continuations init -combinators 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 ; +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 +strings ; IN: ui >focused? focus-path f swap focus-gestures ; +: 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 +79,7 @@ M: world graft* [ images>> [ dispose ] when* ] [ hand-clicked close-global ] [ hand-gadget close-global ] + [ end-world ] } cleave ; M: world ungraft* @@ -117,12 +131,10 @@ M: world ungraft* gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ; : update-ui ( -- ) - [ - notify-queued - layout-queued - redraw-worlds - send-queued-gestures - ] [ ui-error ] recover ; + notify-queued + layout-queued + redraw-worlds + send-queued-gestures ; SYMBOL: ui-thread @@ -133,8 +145,7 @@ SYMBOL: ui-thread PRIVATE> : find-window ( quot -- world ) - windows get values - [ gadget-child swap call ] with find-last nip ; inline + [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline : ui-running? ( -- ? ) \ ui-running get-global ; @@ -142,9 +153,15 @@ 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* ; @@ -193,4 +214,4 @@ M: object close-window : with-ui ( quot -- ) ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ; -HOOK: beep ui-backend ( -- ) \ No newline at end of file +HOOK: beep ui-backend ( -- ) diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor index 3a26b01213..6d6d4233f5 100644 --- a/basis/unicode/breaks/breaks-tests.factor +++ b/basis/unicode/breaks/breaks-tests.factor @@ -32,7 +32,7 @@ IN: unicode.breaks.tests [ concat [ quot call [ "" like ] map ] curry ] bi unit-test ] each ; -: grapheme-test ( tests quot -- ) +: grapheme-test ( tests -- ) [ [ 1quotation ] [ concat [ >graphemes [ "" like ] map ] curry ] bi unit-test diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index a76f5e78c4..9344d1102e 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -4,10 +4,6 @@ USING: unicode.case tools.test namespaces strings unicode.normalize unicode.case.private ; IN: unicode.case.tests -\ >upper must-infer -\ >lower must-infer -\ >title must-infer - [ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test [ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test [ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor index f53a1382ae..fdeb721e65 100644 --- a/basis/unicode/collation/collation-tests.factor +++ b/basis/unicode/collation/collation-tests.factor @@ -11,9 +11,10 @@ IN: unicode.collation.tests : test-two ( str1 str2 -- ) [ +lt+ ] -rot [ string<=> ] 2curry unit-test ; -: test-equality ( str1 str2 -- ) +: test-equality ( str1 str2 -- ? ? ? ? ) { primary= secondary= tertiary= quaternary= } - [ execute ] with with each ; + [ execute( a b -- ? ) ] with with map + first4 ; [ f f f f ] [ "hello" "hi" test-equality ] unit-test [ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor index f774016272..cea880c0b0 100644 --- a/basis/unicode/normalize/normalize-tests.factor +++ b/basis/unicode/normalize/normalize-tests.factor @@ -3,8 +3,6 @@ simple-flat-file io.encodings.utf8 io.files splitting math.parser locals math quotations assocs combinators unicode.normalize.private ; IN: unicode.normalize.tests -{ nfc nfkc nfd nfkd } [ must-infer ] each - [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test [ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test diff --git a/basis/unicode/unicode-docs.factor b/basis/unicode/unicode-docs.factor index 9450b49f0b..56432585c0 100644 --- a/basis/unicode/unicode-docs.factor +++ b/basis/unicode/unicode-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax strings ; IN: unicode -ARTICLE: "unicode" "Unicode" +ARTICLE: "unicode" "Unicode support" "The " { $vocab-link "unicode" } " vocabulary and its sub-vocabularies implement support for the Unicode 5.1 character set." $nl "The Unicode character set contains most of the world's writing systems. Unicode is intended as a replacement for, and is a superset of, such legacy character sets as ASCII, Latin1, MacRoman, and so on. Unicode characters are called " { $emphasis "code points" } "; Factor's " { $link "strings" } " are sequences of code points." diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 2e989b32c0..eae2020077 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -5,8 +5,6 @@ IN: unix.groups.tests [ ] [ all-groups drop ] unit-test -\ all-groups must-infer - [ t ] [ real-group-name string? ] unit-test [ t ] [ effective-group-name string? ] unit-test 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/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor index f2a4b7bc27..cf3747b346 100644 --- a/basis/unix/users/users-tests.factor +++ b/basis/unix/users/users-tests.factor @@ -3,11 +3,8 @@ USING: tools.test unix.users kernel strings math ; IN: unix.users.tests - [ ] [ all-users drop ] unit-test -\ all-users must-infer - [ t ] [ real-user-name string? ] unit-test [ t ] [ effective-user-name string? ] unit-test diff --git a/basis/urls/encoding/encoding-docs.factor b/basis/urls/encoding/encoding-docs.factor index f8b435441f..82ab3d1f69 100644 --- a/basis/urls/encoding/encoding-docs.factor +++ b/basis/urls/encoding/encoding-docs.factor @@ -7,7 +7,11 @@ HELP: url-decode HELP: url-encode { $values { "str" string } { "encoded" string } } -{ $description "URL-encodes a string." } ; +{ $description "URL-encodes a string, excluding certain characters, such as \"/\"." } ; + +HELP: url-encode-full +{ $values { "str" string } { "encoded" string } } +{ $description "URL-encodes a string, including all reserved characters, such as \"/\"." } ; HELP: url-quotable? { $values { "ch" "a character" } { "?" "a boolean" } } diff --git a/basis/urls/encoding/encoding-tests.factor b/basis/urls/encoding/encoding-tests.factor index 87b1812ef8..78e31a764d 100644 --- a/basis/urls/encoding/encoding-tests.factor +++ b/basis/urls/encoding/encoding-tests.factor @@ -26,3 +26,7 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ; [ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test [ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test + +[ "a" ] [ { { "a" f } } assoc>query ] unit-test + +[ H{ { "a" f } } ] [ "a" query>assoc ] unit-test \ No newline at end of file diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index 7fed4b5f58..a5f5d62bfc 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -14,6 +14,25 @@ IN: urls.encoding [ "/_-.:" member? ] } 1|| ; foldable +! see http://tools.ietf.org/html/rfc3986#section-2.2 +: gen-delim? ( ch -- ? ) + ":/?#[]@" member? ; foldable + +: sub-delim? ( ch -- ? ) + "!$&'()*+,;=" member? ; foldable + +: reserved? ( ch -- ? ) + [ gen-delim? ] [ sub-delim? ] bi or ; foldable + +! see http://tools.ietf.org/html/rfc3986#section-2.3 +: unreserved? ( ch -- ? ) + { + [ letter? ] + [ LETTER? ] + [ digit? ] + [ "-._~" member? ] + } 1|| ; foldable + [ dup url-quotable? [ , ] [ push-utf8 ] if ] each ] "" make ; +: url-encode-full ( str -- encoded ) + [ + [ dup unreserved? [ , ] [ push-utf8 ] if ] each + ] "" make ; + ] when* ] 2keep set-at ; +: assoc-strings ( assoc -- assoc' ) + [ + { + { [ dup not ] [ ] } + { [ dup array? ] [ [ present ] map ] } + [ present 1array ] + } cond + ] assoc-map ; + PRIVATE> : query>assoc ( query -- assoc ) @@ -86,11 +119,8 @@ PRIVATE> : assoc>query ( assoc -- str ) [ - dup array? [ [ present ] map ] [ present 1array ] if - ] assoc-map - [ - [ + assoc-strings [ [ url-encode ] dip - [ url-encode "=" glue , ] with each + [ [ url-encode "=" glue , ] with each ] [ , ] if* ] assoc-each ] { } make "&" join ; diff --git a/basis/urls/prettyprint/prettyprint.factor b/basis/urls/prettyprint/prettyprint.factor index 59fb79e8d3..35e428c8fa 100644 --- a/basis/urls/prettyprint/prettyprint.factor +++ b/basis/urls/prettyprint/prettyprint.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel present prettyprint.custom prettyprint.backend urls ; +USING: kernel present prettyprint.custom prettyprint.sections +prettyprint.backend urls ; IN: urls.prettyprint -M: url pprint* dup present "URL\" " "\"" pprint-string ; +M: url pprint* + \ URL" record-vocab + dup present "URL\" " "\"" pprint-string ; diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor index 74eea9506c..f2ecd6ec69 100644 --- a/basis/urls/urls-tests.factor +++ b/basis/urls/urls-tests.factor @@ -1,5 +1,5 @@ IN: urls.tests -USING: urls urls.private tools.test +USING: urls urls.private tools.test prettyprint arrays kernel assocs present accessors ; CONSTANT: urls @@ -80,6 +80,15 @@ CONSTANT: urls } "ftp://slava:secret@ftp.kernel.org/" } + { + T{ url + { protocol "http" } + { host "foo.com" } + { path "/" } + { query H{ { "a" f } } } + } + "http://foo.com/?a" + } } urls [ @@ -227,3 +236,5 @@ urls [ [ "http://localhost/?foo=bar" >url ] unit-test [ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test + +[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test \ No newline at end of file diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor index df38869fbf..7c96f19ac9 100644 --- a/basis/values/values-docs.factor +++ b/basis/values/values-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax ; IN: values ARTICLE: "values" "Global values" -"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:" +"Usually, dynamically-scoped variables subsume global variables and are sufficient for holding global data. But occasionally, for global information that's calculated just once and must be accessed more rapidly than a dynamic variable lookup can provide, it's useful to use the word mechanism instead, and set a word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:" { $subsection POSTPONE: VALUE: } "To get the value, just call the word. The following words manipulate values:" { $subsection get-value } 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/extra/benchmark/typecheck4/authors.txt b/basis/vocabs/refresh/monitor/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/benchmark/typecheck4/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 f76e389dce..fd037cb2a0 100644 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,5 +1,6 @@ USING: alien.syntax kernel math windows.types math.bitwise ; IN: windows.advapi32 + LIBRARY: advapi32 CONSTANT: PROV_RSA_FULL 1 @@ -122,6 +123,34 @@ C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE +C-STRUCT: SECURITY_DESCRIPTOR + { "UCHAR" "Revision" } + { "UCHAR" "Sbz1" } + { "WORD" "Control" } + { "PVOID" "Owner" } + { "PVOID" "Group" } + { "PACL" "Sacl" } + { "PACL" "Dacl" } ; + +TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR + +CONSTANT: SE_OWNER_DEFAULTED 1 +CONSTANT: SE_GROUP_DEFAULTED 2 +CONSTANT: SE_DACL_PRESENT 4 +CONSTANT: SE_DACL_DEFAULTED 8 +CONSTANT: SE_SACL_PRESENT 16 +CONSTANT: SE_SACL_DEFAULTED 32 +CONSTANT: SE_DACL_AUTO_INHERIT_REQ 256 +CONSTANT: SE_SACL_AUTO_INHERIT_REQ 512 +CONSTANT: SE_DACL_AUTO_INHERITED 1024 +CONSTANT: SE_SACL_AUTO_INHERITED 2048 +CONSTANT: SE_DACL_PROTECTED 4096 +CONSTANT: SE_SACL_PROTECTED 8192 +CONSTANT: SE_SELF_RELATIVE 32768 + +TYPEDEF: DWORD SECURITY_DESCRIPTOR_CONTROL +TYPEDEF: SECURITY_DESCRIPTOR_CONTROL* PSECURITY_DESCRIPTOR_CONTROL + ! typedef enum _TOKEN_INFORMATION_CLASS { CONSTANT: TokenUser 1 @@ -141,6 +170,140 @@ CONSTANT: TokenSessionReference 14 CONSTANT: TokenSandBoxInert 15 ! } TOKEN_INFORMATION_CLASS; +TYPEDEF: DWORD ACCESS_MODE +C-ENUM: + NOT_USED_ACCESS + GRANT_ACCESS + SET_ACCESS + DENY_ACCESS + REVOKE_ACCESS + SET_AUDIT_SUCCESS + SET_AUDIT_FAILURE ; + +TYPEDEF: DWORD MULTIPLE_TRUSTEE_OPERATION +C-ENUM: + NO_MULTIPLE_TRUSTEE + TRUSTEE_IS_IMPERSONATE ; + +TYPEDEF: DWORD TRUSTEE_FORM +C-ENUM: + TRUSTEE_IS_SID + TRUSTEE_IS_NAME + TRUSTEE_BAD_FORM + TRUSTEE_IS_OBJECTS_AND_SID + TRUSTEE_IS_OBJECTS_AND_NAME ; + +TYPEDEF: DWORD TRUSTEE_TYPE +C-ENUM: + TRUSTEE_IS_UNKNOWN + TRUSTEE_IS_USER + TRUSTEE_IS_GROUP + TRUSTEE_IS_DOMAIN + TRUSTEE_IS_ALIAS + TRUSTEE_IS_WELL_KNOWN_GROUP + TRUSTEE_IS_DELETED + TRUSTEE_IS_INVALID + TRUSTEE_IS_COMPUTER ; + +TYPEDEF: DWORD SE_OBJECT_TYPE +C-ENUM: + SE_UNKNOWN_OBJECT_TYPE + SE_FILE_OBJECT + SE_SERVICE + SE_PRINTER + SE_REGISTRY_KEY + SE_LMSHARE + SE_KERNEL_OBJECT + SE_WINDOW_OBJECT + SE_DS_OBJECT + SE_DS_OBJECT_ALL + SE_PROVIDER_DEFINED_OBJECT + SE_WMIGUID_OBJECT + SE_REGISTRY_WOW64_32KEY ; + +TYPEDEF: TRUSTEE* PTRUSTEE + +C-STRUCT: TRUSTEE + { "PTRUSTEE" "pMultipleTrustee" } + { "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" } + { "TRUSTEE_FORM" "TrusteeForm" } + { "TRUSTEE_TYPE" "TrusteeType" } + { "LPTSTR" "ptstrName" } ; + +C-STRUCT: EXPLICIT_ACCESS + { "DWORD" "grfAccessPermissions" } + { "ACCESS_MODE" "grfAccessMode" } + { "DWORD" "grfInheritance" } + { "TRUSTEE" "Trustee" } ; + +C-STRUCT: SID_IDENTIFIER_AUTHORITY + { { "BYTE" 6 } "Value" } ; + +TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY + +CONSTANT: SECURITY_NULL_SID_AUTHORITY 0 +CONSTANT: SECURITY_WORLD_SID_AUTHORITY 1 +CONSTANT: SECURITY_LOCAL_SID_AUTHORITY 2 +CONSTANT: SECURITY_CREATOR_SID_AUTHORITY 3 +CONSTANT: SECURITY_NON_UNIQUE_AUTHORITY 4 +CONSTANT: SECURITY_NT_AUTHORITY 5 +CONSTANT: SECURITY_RESOURCE_MANAGER_AUTHORITY 6 + +CONSTANT: SECURITY_NULL_RID 0 +CONSTANT: SECURITY_WORLD_RID 0 +CONSTANT: SECURITY_LOCAL_RID 0 +CONSTANT: SECURITY_CREATOR_OWNER_RID 0 +CONSTANT: SECURITY_CREATOR_GROUP_RID 1 +CONSTANT: SECURITY_CREATOR_OWNER_SERVER_RID 2 +CONSTANT: SECURITY_CREATOR_GROUP_SERVER_RID 3 +CONSTANT: SECURITY_DIALUP_RID 1 +CONSTANT: SECURITY_NETWORK_RID 2 +CONSTANT: SECURITY_BATCH_RID 3 +CONSTANT: SECURITY_INTERACTIVE_RID 4 +CONSTANT: SECURITY_SERVICE_RID 6 +CONSTANT: SECURITY_ANONYMOUS_LOGON_RID 7 +CONSTANT: SECURITY_PROXY_RID 8 +CONSTANT: SECURITY_SERVER_LOGON_RID 9 +CONSTANT: SECURITY_PRINCIPAL_SELF_RID 10 +CONSTANT: SECURITY_AUTHENTICATED_USER_RID 11 +CONSTANT: SECURITY_LOGON_IDS_RID 5 +CONSTANT: SECURITY_LOGON_IDS_RID_COUNT 3 +CONSTANT: SECURITY_LOCAL_SYSTEM_RID 18 +CONSTANT: SECURITY_NT_NON_UNIQUE 21 +CONSTANT: SECURITY_BUILTIN_DOMAIN_RID 32 +CONSTANT: DOMAIN_USER_RID_ADMIN 500 +CONSTANT: DOMAIN_USER_RID_GUEST 501 +CONSTANT: DOMAIN_GROUP_RID_ADMINS 512 +CONSTANT: DOMAIN_GROUP_RID_USERS 513 +CONSTANT: DOMAIN_GROUP_RID_GUESTS 514 +CONSTANT: DOMAIN_ALIAS_RID_ADMINS 544 +CONSTANT: DOMAIN_ALIAS_RID_USERS 545 +CONSTANT: DOMAIN_ALIAS_RID_GUESTS 546 +CONSTANT: DOMAIN_ALIAS_RID_POWER_USERS 547 +CONSTANT: DOMAIN_ALIAS_RID_ACCOUNT_OPS 548 +CONSTANT: DOMAIN_ALIAS_RID_SYSTEM_OPS 549 +CONSTANT: DOMAIN_ALIAS_RID_PRINT_OPS 550 +CONSTANT: DOMAIN_ALIAS_RID_BACKUP_OPS 551 +CONSTANT: DOMAIN_ALIAS_RID_REPLICATOR 552 +CONSTANT: SE_GROUP_MANDATORY 1 +CONSTANT: SE_GROUP_ENABLED_BY_DEFAULT 2 +CONSTANT: SE_GROUP_ENABLED 4 +CONSTANT: SE_GROUP_OWNER 8 +CONSTANT: SE_GROUP_LOGON_ID -1073741824 + +! SID is a variable length structure +TYPEDEF: void* PSID + +TYPEDEF: EXPLICIT_ACCESS* PEXPLICIT_ACCESS + +TYPEDEF: DWORD SECURITY_INFORMATION +TYPEDEF: SECURITY_INFORMATION* PSECURITY_INFORMATION + +CONSTANT: OWNER_SECURITY_INFORMATION 1 +CONSTANT: GROUP_SECURITY_INFORMATION 2 +CONSTANT: DACL_SECURITY_INFORMATION 4 +CONSTANT: SACL_SECURITY_INFORMATION 8 + CONSTANT: DELETE HEX: 00010000 CONSTANT: READ_CONTROL HEX: 00020000 CONSTANT: WRITE_DAC HEX: 00040000 @@ -187,6 +350,45 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080 TOKEN_ADJUST_DEFAULT } flags ; foldable +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_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_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_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 ; @@ -224,7 +426,19 @@ FUNCTION: BOOL AdjustTokenPrivileges ( HANDLE TokenHandle, PTOKEN_PRIVILEGES PreviousState, PDWORD ReturnLength ) ; -! : AllocateAndInitializeSid ; +FUNCTION: BOOL AllocateAndInitializeSid ( + PSID_IDENTIFIER_AUTHORITY pIdentifierAuthority, + BYTE nSubAuthorityCount, + DWORD dwSubAuthority0, + DWORD dwSubAuthority1, + DWORD dwSubAuthority2, + DWORD dwSubAuthority3, + DWORD dwSubAuthority4, + DWORD dwSubAuthority5, + DWORD dwSubAuthority6, + DWORD dwSubAuthority7, + PSID* pSid ) ; + ! : AllocateLocallyUniqueId ; ! : AreAllAccessesGranted ; ! : AreAnyAccessesGranted ; @@ -442,7 +656,8 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ; ! : GetExplicitEntriesFromAclA ; ! : GetExplicitEntriesFromAclW ; ! : GetFileSecurityA ; -! : GetFileSecurityW ; +FUNCTION: BOOL GetFileSecurityW ( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded ) ; +ALIAS: GetFileSecurity GetFileSecurityW ! : GetInformationCodeAuthzLevelW ; ! : GetInformationCodeAuthzPolicyW ; ! : GetInheritanceSourceA ; @@ -459,19 +674,20 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ; ! : GetMultipleTrusteeW ; ! : GetNamedSecurityInfoA ; ! : GetNamedSecurityInfoExA ; -! : GetNamedSecurityInfoExW ; -! : GetNamedSecurityInfoW ; +! FUNCTION: DWORD GetNamedSecurityInfoExW +FUNCTION: DWORD GetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID* ppsidOwner, PSID* ppsidGroup, PACL* ppDacl, PACL* ppSacl, PSECURITY_DESCRIPTOR* ppSecurityDescriptor ) ; +ALIAS: GetNamedSecurityInfo GetNamedSecurityInfoW ! : GetNumberOfEventLogRecords ; ! : GetOldestEventLogRecord ; ! : GetOverlappedAccessResults ; ! : GetPrivateObjectSecurity ; -! : GetSecurityDescriptorControl ; -! : GetSecurityDescriptorDacl ; -! : GetSecurityDescriptorGroup ; -! : GetSecurityDescriptorLength ; -! : GetSecurityDescriptorOwner ; -! : GetSecurityDescriptorRMControl ; -! : GetSecurityDescriptorSacl ; +FUNCTION: BOOL GetSecurityDescriptorControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSECURITY_DESCRIPTOR_CONTROL pControl, LPDWORD lpdwRevision ) ; +FUNCTION: BOOL GetSecurityDescriptorDacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbDaclPresent, PACL* pDacl, LPBOOL lpDaclDefaulted ) ; +FUNCTION: BOOL GetSecurityDescriptorGroup ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pGroup, LPBOOL lpGroupDefaulted ) ; +FUNCTION: BOOL GetSecurityDescriptorLength ( PSECURITY_DESCRIPTOR pSecurityDescriptor ) ; +FUNCTION: BOOL GetSecurityDescriptorOwner ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pOwner, LPBOOL lpOwnerDefaulted ) ; +FUNCTION: BOOL GetSecurityDescriptorRMControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PUCHAR RMControl ) ; +FUNCTION: BOOL GetSecurityDescriptorSacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbSaclPresent, PACL* pSacl, LPBOOL lpSaclDefaulted ) ; ! : GetSecurityInfo ; ! : GetSecurityInfoExA ; ! : GetSecurityInfoExW ; @@ -510,7 +726,7 @@ ALIAS: GetUserName GetUserNameW ! : ImpersonateNamedPipeClient ; ! : ImpersonateSelf ; FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ; -! : InitializeSecurityDescriptor ; +FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ; ! : InitializeSid ; ! : InitiateSystemShutdownA ; ! : InitiateSystemShutdownExA ; @@ -669,43 +885,96 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : ReadEncryptedFileRaw ; ! : ReadEventLogA ; ! : ReadEventLogW ; -! : RegCloseKey ; +FUNCTION: LONG RegCloseKey ( HKEY hKey ) ; ! : RegConnectRegistryA ; ! : RegConnectRegistryW ; ! : RegCreateKeyA ; ! : RegCreateKeyExA ; -! : RegCreateKeyExW ; -! : RegCreateKeyW ; +FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ; +! : 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 ; ! : RegLoadKeyW ; ! : RegNotifyChangeKeyValue ; -! : RegOpenCurrentUser ; +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 ; -! : RegQueryValueExW ; +FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPDWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ; +ALIAS: RegQueryValueEx RegQueryValueExW ! : RegQueryValueW ; ! : RegReplaceKeyA ; ! : RegReplaceKeyW ; @@ -756,7 +1025,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : SetEntriesInAccessListA ; ! : SetEntriesInAccessListW ; ! : SetEntriesInAclA ; -! : SetEntriesInAclW ; +FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ; +ALIAS: SetEntriesInAcl SetEntriesInAclW ! : SetEntriesInAuditListA ; ! : SetEntriesInAuditListW ; ! : SetFileSecurityA ; @@ -767,7 +1037,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : SetNamedSecurityInfoA ; ! : SetNamedSecurityInfoExA ; ! : SetNamedSecurityInfoExW ; -! : SetNamedSecurityInfoW ; +FUNCTION: DWORD SetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID psidOwner, PSID psidGroup, PACL pDacl, PACL pSacl ) ; +ALIAS: SetNamedSecurityInfo SetNamedSecurityInfoW ! : SetPrivateObjectSecurity ; ! : SetPrivateObjectSecurityEx ; ! : SetSecurityDescriptorControl ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index a014a56ea0..e78c987cd4 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -132,7 +132,7 @@ unless [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] void*-array{ } map-as malloc-byte-array ; + [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/basis/windows/dinput/constants/constants-tests.factor b/basis/windows/dinput/constants/constants-tests.factor new file mode 100644 index 0000000000..67785844fa --- /dev/null +++ b/basis/windows/dinput/constants/constants-tests.factor @@ -0,0 +1,5 @@ +IN: windows.dinput.constants.tests +USING: tools.test windows.dinput.constants.private ; + +[ ] [ define-constants ] unit-test +[ ] [ free-dinput-constants ] unit-test \ No newline at end of file diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index cd1033d418..74238abed2 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -27,12 +27,12 @@ SYMBOLS: : (flag) ( thing -- integer ) { - { [ dup word? ] [ execute ] } - { [ dup callable? ] [ call ] } + { [ dup word? ] [ execute( -- value ) ] } + { [ dup callable? ] [ call( -- value ) ] } [ ] } cond ; -: (flags) ( array -- ) +: (flags) ( array -- n ) 0 [ (flag) bitor ] reduce ; : (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien ) @@ -63,14 +63,16 @@ SYMBOLS: ] ; : (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien ) - [ { - [ set-DIDATAFORMAT-rgodf ] - [ set-DIDATAFORMAT-dwNumObjs ] - [ set-DIDATAFORMAT-dwDataSize ] - [ set-DIDATAFORMAT-dwFlags ] - [ set-DIDATAFORMAT-dwObjSize ] - [ set-DIDATAFORMAT-dwSize ] - } cleave ] keep ; + [ + { + [ set-DIDATAFORMAT-rgodf ] + [ set-DIDATAFORMAT-dwNumObjs ] + [ set-DIDATAFORMAT-dwDataSize ] + [ set-DIDATAFORMAT-dwFlags ] + [ set-DIDATAFORMAT-dwObjSize ] + [ set-DIDATAFORMAT-dwSize ] + } cleave + ] keep ; : ( dwFlags dwDataSize struct rgodf-array -- alien ) [ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip @@ -78,9 +80,10 @@ SYMBOLS: "DIDATAFORMAT" (DIDATAFORMAT) ; : (malloc-guid-symbol) ( symbol guid -- ) - global swap '[ [ - _ execute [ byte-length malloc ] [ over byte-array>memory ] bi - ] unless* ] change-at ; + '[ + _ execute( -- value ) + [ byte-length malloc ] [ over byte-array>memory ] bi + ] initialize ; : define-guid-constants ( -- ) { @@ -105,7 +108,7 @@ SYMBOLS: } [ first2 (malloc-guid-symbol) ] each ; : define-joystick-format-constant ( -- ) - c_dfDIJoystick2 global [ [ + c_dfDIJoystick2 [ DIDF_ABSAXIS "DIJOYSTATE2" heap-size "DIJOYSTATE2" { @@ -274,10 +277,10 @@ SYMBOLS: { GUID_Slider_malloced "rglFSlider" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE } { GUID_Slider_malloced "rglFSlider" 1 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE } } - ] unless* ] change-at ; + ] initialize ; : define-mouse-format-constant ( -- ) - c_dfDIMouse2 global [ [ + c_dfDIMouse2 [ DIDF_RELAXIS "DIMOUSESTATE2" heap-size "DIMOUSESTATE2" { @@ -293,13 +296,13 @@ SYMBOLS: { GUID_Button_malloced "rgbButtons" 6 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 } { GUID_Button_malloced "rgbButtons" 7 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 } } - ] unless* ] change-at ; + ] initialize ; ! Not a standard DirectInput format. Included for cross-platform niceness. ! This format returns the keyboard keys in USB HID order rather than Windows ! order : define-hid-keyboard-format-constant ( -- ) - c_dfDIKeyboard_HID global [ [ + c_dfDIKeyboard_HID [ DIDF_RELAXIS 256 f { @@ -560,10 +563,10 @@ SYMBOLS: { GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 } { GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 } } - ] unless* ] change-at ; + ] initialize ; : define-keyboard-format-constant ( -- ) - c_dfDIKeyboard global [ [ + c_dfDIKeyboard [ DIDF_RELAXIS 256 f { @@ -824,7 +827,7 @@ SYMBOLS: { GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 254 DIDFT_MAKEINSTANCE ] } 0 } { GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 255 DIDFT_MAKEINSTANCE ] } 0 } } - ] unless* ] change-at ; + ] initialize ; : define-format-constants ( -- ) define-joystick-format-constant @@ -837,7 +840,9 @@ SYMBOLS: define-format-constants ; [ define-constants ] "windows.dinput.constants" add-init-hook -define-constants + +: uninitialize ( variable quot -- ) + '[ _ when* f ] change-global ; inline : free-dinput-constants ( -- ) { @@ -846,10 +851,11 @@ define-constants GUID_Slider_malloced GUID_Button_malloced GUID_Key_malloced GUID_POV_malloced GUID_Unknown_malloced GUID_SysMouse_malloced GUID_SysKeyboard_malloced GUID_Joystick_malloced GUID_SysMouseEm_malloced GUID_SysMouseEm2_malloced GUID_SysKeyboardEm_malloced GUID_SysKeyboardEm2_malloced - } [ global [ [ free ] when* f ] change-at ] each + } [ [ free ] uninitialize ] each + { c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2 - } [ global [ [ DIDATAFORMAT-rgodf free ] when* f ] change-at ] each ; + } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ; PRIVATE> 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 794aa0e32e..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 @@ -1501,7 +1501,6 @@ DESTRUCTOR: DeleteObject FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ; ALIAS: ExtTextOut ExtTextOutW ! FUNCTION: FillPath -FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ; ! FUNCTION: FillRgn ! FUNCTION: FixBrushOrgEx ! FUNCTION: FlattenPath diff --git a/basis/windows/gdi32/tags.txt b/basis/windows/gdi32/tags.txt index 6bf68304bb..2320bdd648 100644 --- a/basis/windows/gdi32/tags.txt +++ b/basis/windows/gdi32/tags.txt @@ -1 +1,2 @@ unportable +bindings diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 36acc5e346..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 ) ; @@ -1139,7 +1151,8 @@ FUNCTION: BOOL GetCommState ( HANDLE hFile, LPDCB lpDCB ) ; ! FUNCTION: GetCommTimeouts ! FUNCTION: GetComPlusPackageInstallStatus ! FUNCTION: GetCompressedFileSizeA -! FUNCTION: GetCompressedFileSizeW +FUNCTION: DWORD GetCompressedFileSizeW ( LPCTSTR lpFileName, LPDWORD lpFileSizeHigh ) ; +ALIAS: GetCompressedFileSize GetCompressedFileSizeW FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ; ALIAS: GetComputerName GetComputerNameW FUNCTION: BOOL GetComputerNameExW ( COMPUTER_NAME_FORMAT NameType, LPTSTR lpBuffer, LPDWORD lpnSize ) ; @@ -1477,7 +1490,7 @@ ALIAS: LoadLibraryEx LoadLibraryExW ! FUNCTION: LoadLibraryW ! FUNCTION: LoadModule ! FUNCTION: LoadResource -! FUNCTION: LocalAlloc +FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ; ! FUNCTION: LocalCompact ! FUNCTION: LocalFileTimeToFileTime ! FUNCTION: LocalFlags 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 53d2d9918f..feb0bef7a8 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2009 Slava Pestov. ! 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 locals -cache namespaces init images.normalization fonts alien.c-types -windows windows.usp10 windows.offscreen windows.gdi32 -windows.ole32 windows.types windows.fonts opengl.textures ; +io.encodings.utf16n accessors arrays combinators destructors +cache namespaces init fonts alien.c-types windows.usp10 +windows.offscreen windows.gdi32 windows.ole32 windows.types +windows.fonts opengl.textures locals windows.errors ; IN: windows.uniscribe TUPLE: script-string font string metrics ssa size image disposed ; @@ -59,10 +59,10 @@ TUPLE: script-string font string metrics ssa size image disposed ; ssa>> ! ssa 0 ! iX 0 ! iY - 0 ! uOptions - f ! prc + ETO_OPAQUE ! uOptions ] - [ selection-start/end ] bi + [ [ { 0 0 } ] dip size>> ] + [ selection-start/end ] tri ! iMinSel ! iMaxSel FALSE ! fDisabled @@ -71,11 +71,8 @@ TUPLE: script-string font string metrics ssa size image disposed ; : draw-script-string ( dc script-string -- ) [ font>> set-dc-colors ] keep (draw-script-string) ; -: script-string-bitmap-size ( script-string -- dim ) - size>> dup small-texture? [ [ next-power-of-2 ] map ] when ; - :: make-script-string-image ( dc script-string -- image ) - script-string script-string-bitmap-size dc + script-string size>> dc [ dc script-string draw-script-string ] make-bitmap-image ; : set-dc-font ( dc font -- ) @@ -111,8 +108,8 @@ M: script-string dispose* SYMBOL: cached-script-strings -: cached-script-string ( string font -- script-string ) +: cached-script-string ( font string -- script-string ) cached-script-strings get-global [ ] 2cache ; [ cached-script-strings set-global ] -"windows.uniscribe" add-init-hook \ No newline at end of file +"windows.uniscribe" add-init-hook diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 9daac21697..1e694bcbe4 100644 --- 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 @@ -807,7 +841,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ; ! FUNCTION: EqualRect ! FUNCTION: ExcludeUpdateRgn ! FUNCTION: ExitWindowsEx -! FUNCTION: FillRect +FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ; FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ; FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ; ! FUNCTION: FindWindowExW @@ -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 diff --git a/basis/windows/usp10/tags.txt b/basis/windows/usp10/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/windows/usp10/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings 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/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor index e66572dc1b..07f42caae3 100644 --- a/basis/wrap/strings/strings-tests.factor +++ b/basis/wrap/strings/strings-tests.factor @@ -38,6 +38,4 @@ word wrap."> [ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test [ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test -\ wrap-string must-infer - [ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test diff --git a/basis/wrap/words/words-tests.factor b/basis/wrap/words/words-tests.factor index 7598b382ba..6df69a65d6 100644 --- a/basis/wrap/words/words-tests.factor +++ b/basis/wrap/words/words-tests.factor @@ -79,4 +79,3 @@ IN: wrap.words.tests } 35 35 wrap-words [ { } like ] map ] unit-test -\ wrap-words must-infer diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 58957ba8e7..482d50ab5f 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -30,7 +30,7 @@ SYMBOL: line-ideal { [ lines>> car 1list? ] [ top-fits? ] } 1|| ; :: min-by ( seq quot -- elt ) - f 1.0/0.0 seq [| key value new | + f 1/0. seq [| key value new | new quot call :> newvalue newvalue value < [ new newvalue ] [ key value ] if ] each drop ; inline diff --git a/basis/x11/authors.txt b/basis/x11/authors.txt new file mode 100644 index 0000000000..db8d84451d --- /dev/null +++ b/basis/x11/authors.txt @@ -0,0 +1,2 @@ +Eduardo Cavazos +Slava Pestov diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index 87b91624af..20bf66c704 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax arrays kernel math namespaces sequences io.encodings.string -io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants +io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants specialized-arrays.int accessors ; IN: x11.clipboard diff --git a/basis/x11/events/events.factor b/basis/x11/events/events.factor index 07650a9da7..5673dd7f76 100644 --- a/basis/x11/events/events.factor +++ b/basis/x11/events/events.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays hashtables io kernel math math.order namespaces prettyprint sequences strings combinators -x11.xlib ; +x11 x11.xlib ; IN: x11.events GENERIC: expose-event ( event window -- ) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index e6001d3e59..67ac0e8cc1 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! based on glx.h from xfree86, and some of glxtokens.h -USING: alien alien.c-types alien.syntax x11.xlib namespaces make -kernel sequences parser words specialized-arrays.int accessors ; +USING: alien alien.c-types alien.syntax x11 x11.xlib x11.syntax +namespaces make kernel sequences parser words specialized-arrays.int +accessors ; IN: x11.glx LIBRARY: glx @@ -36,67 +37,64 @@ TYPEDEF: XID GLXFBConfigID TYPEDEF: void* GLXContext ! typedef struct __GLXcontextRec *GLXContext; TYPEDEF: void* GLXFBConfig ! typedef struct __GLXFBConfigRec *GLXFBConfig; -FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ; -FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ; -FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ; -FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ; -FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ; -FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ; -FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ; -FUNCTION: GLXContext glXGetCurrentContext ( ) ; -FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ; -FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ; -FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ; -FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ; -FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ; -FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ; -FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ; -FUNCTION: void glXWaitGL ( ) ; -FUNCTION: void glXWaitX ( ) ; -FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ; -FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ; -FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ; +X-FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ; +X-FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ; +X-FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ; +X-FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ; +X-FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ; +X-FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ; +X-FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ; +X-FUNCTION: GLXContext glXGetCurrentContext ( ) ; +X-FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ; +X-FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ; +X-FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ; +X-FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ; +X-FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ; +X-FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ; +X-FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ; +X-FUNCTION: void glXWaitGL ( ) ; +X-FUNCTION: void glXWaitX ( ) ; +X-FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ; +X-FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ; +X-FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ; ! New for GLX 1.3 -FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ; -FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ; -FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ; -FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ; -FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ; -FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ; -FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ; -FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ; -FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ; -FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ; -FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ; -FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ; -FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ; -FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ; -FUNCTION: Display* glXGetCurrentDisplay ( ) ; -FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ; -FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ; -FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ; +X-FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ; +X-FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ; +X-FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ; +X-FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ; +X-FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ; +X-FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ; +X-FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ; +X-FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ; +X-FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ; +X-FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ; +X-FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ; +X-FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ; +X-FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ; +X-FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ; +X-FUNCTION: Display* glXGetCurrentDisplay ( ) ; +X-FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ; +X-FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ; +X-FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ; ! GLX 1.4 and later -FUNCTION: void* glXGetProcAddress ( char* procname ) ; +X-FUNCTION: void* glXGetProcAddress ( char* procname ) ; ! GLX_ARB_get_proc_address extension -FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; +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/io/authors.txt b/basis/x11/io/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/x11/io/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/x11/io/io.factor b/basis/x11/io/io.factor new file mode 100644 index 0000000000..0e618cd323 --- /dev/null +++ b/basis/x11/io/io.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend calendar threads kernel ; +IN: x11.io + +HOOK: init-x-io io-backend ( -- ) + +M: object init-x-io ; + +HOOK: wait-for-display io-backend ( -- ) + +M: object wait-for-display 10 milliseconds sleep ; + +HOOK: awaken-event-loop io-backend ( -- ) + +M: object awaken-event-loop ; \ No newline at end of file diff --git a/basis/x11/io/unix/authors.txt b/basis/x11/io/unix/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/x11/io/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/x11/io/unix/tags.txt b/basis/x11/io/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/x11/io/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/x11/io/unix/unix.factor b/basis/x11/io/unix/unix.factor new file mode 100644 index 0000000000..821beb91a5 --- /dev/null +++ b/basis/x11/io/unix/unix.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend.unix io.backend.unix.multiplexers +namespaces system x11 x11.xlib x11.io +accessors threads sequences kernel ; +IN: x11.io.unix + +SYMBOL: dpy-fd + +M: unix init-x-io dpy get XConnectionNumber dpy-fd set-global ; + +M: unix wait-for-display dpy-fd get +input+ wait-for-fd ; + +M: unix awaken-event-loop + dpy-fd get [ fd>> mx get remove-input-callbacks [ resume ] each ] when* ; \ No newline at end of file diff --git a/basis/x11/syntax/authors.txt b/basis/x11/syntax/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/x11/syntax/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/x11/syntax/syntax.factor b/basis/x11/syntax/syntax.factor new file mode 100644 index 0000000000..db2adab5dc --- /dev/null +++ b/basis/x11/syntax/syntax.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax alien.parser words x11.io sequences kernel ; +IN: x11.syntax + +SYNTAX: X-FUNCTION: + (FUNCTION:) + [ \ awaken-event-loop suffix ] dip + define-declared ; \ No newline at end of file diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 9619ae0bee..54cf205c14 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types hashtables kernel math math.vectors -math.bitwise namespaces sequences x11.xlib x11.constants x11.glx +math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx arrays fry ; IN: x11.windows @@ -9,7 +9,7 @@ IN: x11.windows { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ; : create-colormap ( visinfo -- colormap ) - dpy get root get rot XVisualInfo-visual AllocNone + [ dpy get root get ] dip XVisualInfo-visual AllocNone XCreateColormap ; : event-mask ( -- n ) @@ -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/x11/x11.factor b/basis/x11/x11.factor new file mode 100644 index 0000000000..09328c6f6e --- /dev/null +++ b/basis/x11/x11.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2005, 2009 Eduardo Cavazos, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.strings continuations io +io.encodings.ascii kernel namespaces x11.xlib x11.io +vocabs vocabs.loader ; +IN: x11 + +SYMBOL: dpy +SYMBOL: scr +SYMBOL: root + +: init-locale ( -- ) + LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless + XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ; + +: flush-dpy ( -- ) dpy get XFlush drop ; + +: x-atom ( string -- atom ) [ dpy get ] dip 0 XInternAtom ; + +: check-display ( alien -- alien' ) + [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ; + +: init-x ( display-string -- ) + init-locale + dup [ ascii string>alien ] when + XOpenDisplay check-display dpy set-global + dpy get XDefaultScreen scr set-global + dpy get scr get XRootWindow root set-global + init-x-io ; + +: close-x ( -- ) dpy get XCloseDisplay drop ; + +: with-x ( display-string quot -- ) + [ init-x ] dip [ close-x ] [ ] cleanup ; inline + +"io.backend.unix" vocab [ "x11.io.unix" require ] when \ No newline at end of file diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index e06872fa83..54f20a28dd 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings arrays byte-arrays hashtables io io.encodings.string kernel math namespaces -sequences strings continuations x11.xlib specialized-arrays.uint +sequences strings continuations x11 x11.xlib specialized-arrays.uint accessors io.encodings.utf16n ; IN: x11.xim @@ -22,7 +22,7 @@ SYMBOL: xim xim get-global XCloseIM drop f xim set-global ; : with-xim ( quot -- ) - [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ; + [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ; inline : create-xic ( window classname -- xic ) [ diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 3394de87b2..638f5c8d56 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -13,7 +13,7 @@ USING: kernel arrays alien alien.c-types alien.strings alien.syntax math math.bitwise words sequences namespaces -continuations io io.encodings.ascii ; +continuations io io.encodings.ascii x11.syntax ; IN: x11.xlib LIBRARY: xlib @@ -71,26 +71,26 @@ C-STRUCT: Display { "void*" "free_funcs" } { "int" "fd" } ; -FUNCTION: Display* XOpenDisplay ( void* display_name ) ; +X-FUNCTION: Display* XOpenDisplay ( void* display_name ) ; ! 2.2 Obtaining Information about the Display, Image Formats, or Screens -FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ; -FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ; -FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ; -FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ; -FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ; -FUNCTION: int XDefaultScreen ( Display* display ) ; -FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ; -FUNCTION: Window XDefaultRootWindow ( Display* display ) ; -FUNCTION: int XProtocolVersion ( Display* display ) ; -FUNCTION: int XProtocolRevision ( Display* display ) ; -FUNCTION: int XQLength ( Display* display ) ; -FUNCTION: int XScreenCount ( Display* display ) ; -FUNCTION: int XConnectionNumber ( Display* display ) ; +X-FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ; +X-FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ; +X-FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ; +X-FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ; +X-FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ; +X-FUNCTION: int XDefaultScreen ( Display* display ) ; +X-FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ; +X-FUNCTION: Window XDefaultRootWindow ( Display* display ) ; +X-FUNCTION: int XProtocolVersion ( Display* display ) ; +X-FUNCTION: int XProtocolRevision ( Display* display ) ; +X-FUNCTION: int XQLength ( Display* display ) ; +X-FUNCTION: int XScreenCount ( Display* display ) ; +X-FUNCTION: int XConnectionNumber ( Display* display ) ; ! 2.5 Closing the Display -FUNCTION: int XCloseDisplay ( Display* display ) ; +X-FUNCTION: int XCloseDisplay ( Display* display ) ; ! ! 3 - Window Functions @@ -147,17 +147,17 @@ CONSTANT: StaticGravity 10 ! 3.3 - Creating Windows -FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ; -FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ; -FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ; -FUNCTION: Status XMapWindow ( Display* display, Window window ) ; -FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ; -FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ; -FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ; +X-FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ; +X-FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ; +X-FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XMapWindow ( Display* display, Window window ) ; +X-FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ; +X-FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ; ! 3.5 Mapping Windows -FUNCTION: int XMapRaised ( Display* display, Window w ) ; +X-FUNCTION: int XMapRaised ( Display* display, Window w ) ; ! 3.7 - Configuring Windows @@ -178,25 +178,25 @@ C-STRUCT: XWindowChanges { "Window" "sibling" } { "int" "stack_mode" } ; -FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ; -FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ; -FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ; -FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ; +X-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ; +X-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ; +X-FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ; +X-FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ; ! 3.8 Changing Window Stacking Order -FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ; -FUNCTION: Status XLowerWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XLowerWindow ( Display* display, Window w ) ; ! 3.9 - Changing Window Attributes -FUNCTION: Status XChangeWindowAttributes ( +X-FUNCTION: Status XChangeWindowAttributes ( Display* display, Window w, ulong valuemask, XSetWindowAttributes* attr ) ; -FUNCTION: Status XSetWindowBackground ( +X-FUNCTION: Status XSetWindowBackground ( Display* display, Window w, ulong background_pixel ) ; -FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ; -FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; +X-FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ; +X-FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 4 - Window Information Functions @@ -204,7 +204,7 @@ FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; ! 4.1 - Obtaining Window Information -FUNCTION: Status XQueryTree ( +X-FUNCTION: Status XQueryTree ( Display* display, Window w, Window* root_return, @@ -236,13 +236,13 @@ C-STRUCT: XWindowAttributes { "Bool" "override_redirect" } { "Screen*" "screen" } ; -FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ; +X-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ; CONSTANT: IsUnmapped 0 CONSTANT: IsUnviewable 1 CONSTANT: IsViewable 2 -FUNCTION: Status XGetGeometry ( +X-FUNCTION: Status XGetGeometry ( Display* display, Drawable d, Window* root_return, @@ -255,27 +255,27 @@ FUNCTION: Status XGetGeometry ( ! 4.2 - Translating Screen Coordinates -FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ; +X-FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ; ! 4.3 - Properties and Atoms -FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ; +X-FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ; -FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ; +X-FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ; ! 4.4 - Obtaining and Changing Window Properties -FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ; +X-FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ; -FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ; +X-FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ; ! 4.5 Selections -FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ; +X-FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ; -FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ; +X-FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ; -FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ; +X-FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -284,8 +284,8 @@ FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, ! 5.1 - Creating and Freeing Pixmaps -FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ; -FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ; +X-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ; +X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -300,13 +300,13 @@ C-STRUCT: XColor { "char" "flags" } { "char" "pad" } ; -FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ; -FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ; -FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ; +X-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ; +X-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ; +X-FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ; ! 6.4 Creating, Copying, and Destroying Colormaps -FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ; +X-FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 7 - Graphics Context Functions @@ -378,27 +378,27 @@ C-STRUCT: XGCValues { "int" "dash_offset" } { "char" "dashes" } ; -FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ; -FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ; -FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ; -FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ; -FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ; -FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ; -FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ; +X-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ; +X-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ; +X-FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ; +X-FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ; +X-FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ; +X-FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ; +X-FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ; -FUNCTION: GContext XGContextFromGC ( GC gc ) ; +X-FUNCTION: GContext XGContextFromGC ( GC gc ) ; -FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ; +X-FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 8 - Graphics Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: Status XClearWindow ( Display* display, Window w ) ; -FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ; -FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ; -FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; -FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; +X-FUNCTION: Status XClearWindow ( Display* display, Window w ) ; +X-FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ; +X-FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ; +X-FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; +X-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; ! 8.5 - Font Metrics @@ -410,9 +410,9 @@ C-STRUCT: XCharStruct { "short" "descent" } { "ushort" "attributes" } ; -FUNCTION: Font XLoadFont ( Display* display, char* name ) ; -FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; -FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; +X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ; +X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; +X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; C-STRUCT: XFontStruct { "XExtData*" "ext_data" } @@ -432,11 +432,11 @@ C-STRUCT: XFontStruct { "int" "ascent" } { "int" "descent" } ; -FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; +X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; ! 8.6 - Drawing Text -FUNCTION: Status XDrawString ( +X-FUNCTION: Status XDrawString ( Display* display, Drawable d, GC gc, @@ -479,8 +479,8 @@ C-STRUCT: XImage { "XPointer" "obdata" } { "XImage-funcs" "f" } ; -FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ; -FUNCTION: int XDestroyImage ( XImage *ximage ) ; +X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ; +X-FUNCTION: int XDestroyImage ( XImage *ximage ) ; : XImage-size ( ximage -- size ) [ XImage-height ] [ XImage-bytes_per_line ] bi * ; @@ -492,12 +492,12 @@ FUNCTION: int XDestroyImage ( XImage *ximage ) ; ! 9 - Window and Session Manager Functions ! -FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ; -FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ; -FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ; -FUNCTION: Status XGrabServer ( Display* display ) ; -FUNCTION: Status XUngrabServer ( Display* display ) ; -FUNCTION: Status XKillClient ( Display* display, XID resource ) ; +X-FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ; +X-FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ; +X-FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ; +X-FUNCTION: Status XGrabServer ( Display* display ) ; +X-FUNCTION: Status XUngrabServer ( Display* display ) ; +X-FUNCTION: Status XKillClient ( Display* display, XID resource ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 10 - Events @@ -1066,11 +1066,11 @@ C-UNION: XEvent ! 11 - Event Handling Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ; -FUNCTION: Status XFlush ( Display* display ) ; -FUNCTION: Status XSync ( Display* display, int discard ) ; -FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ; -FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ; +X-FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ; +X-FUNCTION: Status XFlush ( Display* display ) ; +X-FUNCTION: Status XSync ( Display* display, int discard ) ; +X-FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ; +X-FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ; ! 11.3 - Event Queue Management @@ -1078,16 +1078,16 @@ CONSTANT: QueuedAlready 0 CONSTANT: QueuedAfterReading 1 CONSTANT: QueuedAfterFlush 2 -FUNCTION: int XEventsQueued ( Display* display, int mode ) ; -FUNCTION: int XPending ( Display* display ) ; +X-FUNCTION: int XEventsQueued ( Display* display, int mode ) ; +X-FUNCTION: int XPending ( Display* display ) ; ! 11.6 - Sending Events to Other Applications -FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ; +X-FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ; ! 11.8 - Handling Protocol Errors -FUNCTION: int XSetErrorHandler ( void* handler ) ; +X-FUNCTION: int XSetErrorHandler ( void* handler ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 12 - Input Device Functions @@ -1095,7 +1095,7 @@ FUNCTION: int XSetErrorHandler ( void* handler ) ; CONSTANT: None 0 -FUNCTION: int XGrabPointer ( +X-FUNCTION: int XGrabPointer ( Display* display, Window grab_window, Bool owner_events, @@ -1106,16 +1106,16 @@ FUNCTION: int XGrabPointer ( Cursor cursor, Time time ) ; -FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ; -FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ; -FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ; -FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ; +X-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ; +X-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ; +X-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ; +X-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ; -FUNCTION: Status XGetInputFocus ( Display* display, +X-FUNCTION: Status XGetInputFocus ( Display* display, Window* focus_return, int* revert_to_return ) ; -FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ; +X-FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 14 - Inter-Client Communication Functions @@ -1123,15 +1123,15 @@ FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, i ! 14.1 Client to Window Manager Communication -FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ; -FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ; +X-FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ; +X-FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ; ! 14.1.1. Manipulating Top-Level Windows -FUNCTION: Status XIconifyWindow ( +X-FUNCTION: Status XIconifyWindow ( Display* display, Window w, int screen_number ) ; -FUNCTION: Status XWithdrawWindow ( +X-FUNCTION: Status XWithdrawWindow ( Display* display, Window w, int screen_number ) ; ! 14.1.6 - Setting and Reading the WM_HINTS Property @@ -1173,10 +1173,10 @@ C-STRUCT: XSizeHints ! 14.1.10. Setting and Reading the WM_PROTOCOLS Property -FUNCTION: Status XSetWMProtocols ( +X-FUNCTION: Status XSetWMProtocols ( Display* display, Window w, Atom* protocols, int count ) ; -FUNCTION: Status XGetWMProtocols ( +X-FUNCTION: Status XGetWMProtocols ( Display* display, Window w, Atom** protocols_return, @@ -1188,9 +1188,9 @@ FUNCTION: Status XGetWMProtocols ( ! 16.1 Keyboard Utility Functions -FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ; +X-FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ; -FUNCTION: int XLookupString ( +X-FUNCTION: int XLookupString ( XKeyEvent* event_struct, void* buffer_return, int bytes_buffer, @@ -1227,7 +1227,7 @@ C-STRUCT: XVisualInfo ! Appendix D - Compatibility Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: Status XSetStandardProperties ( +X-FUNCTION: Status XSetStandardProperties ( Display* display, Window w, char* window_name, @@ -1314,10 +1314,10 @@ CONSTANT: XA_LAST_PREDEFINED 68 ! The rest of the stuff is not from the book. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -FUNCTION: void XFree ( void* data ) ; -FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ; -FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ; -FUNCTION: int XBell ( Display* display, int percent ) ; +X-FUNCTION: void XFree ( void* data ) ; +X-FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ; +X-FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ; +X-FUNCTION: int XBell ( Display* display, int percent ) ; ! !!! INPUT METHODS @@ -1381,23 +1381,23 @@ CONSTANT: XLookupChars 2 CONSTANT: XLookupKeySym 3 CONSTANT: XLookupBoth 4 -FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ; +X-FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ; -FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ; +X-FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ; -FUNCTION: Status XCloseIM ( XIM im ) ; +X-FUNCTION: Status XCloseIM ( XIM im ) ; -FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ; +X-FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ; -FUNCTION: void XDestroyIC ( XIC ic ) ; +X-FUNCTION: void XDestroyIC ( XIC ic ) ; -FUNCTION: void XSetICFocus ( XIC ic ) ; +X-FUNCTION: void XSetICFocus ( XIC ic ) ; -FUNCTION: void XUnsetICFocus ( XIC ic ) ; +X-FUNCTION: void XUnsetICFocus ( XIC ic ) ; -FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; +X-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; -FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; +X-FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ; ! !!! category of setlocale CONSTANT: LC_ALL 0 @@ -1407,37 +1407,8 @@ CONSTANT: LC_MONETARY 3 CONSTANT: LC_NUMERIC 4 CONSTANT: LC_TIME 5 -FUNCTION: char* setlocale ( int category, char* name ) ; +X-FUNCTION: char* setlocale ( int category, char* name ) ; -FUNCTION: Bool XSupportsLocale ( ) ; +X-FUNCTION: Bool XSupportsLocale ( ) ; -FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ; - -SYMBOL: dpy -SYMBOL: scr -SYMBOL: root - -: init-locale ( -- ) - LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless - XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ; - -: flush-dpy ( -- ) dpy get XFlush drop ; - -: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ; - -: check-display ( alien -- alien' ) - [ - "Cannot connect to X server - check $DISPLAY" throw - ] unless* ; - -: initialize-x ( display-string -- ) - init-locale - dup [ ascii string>alien ] when - XOpenDisplay check-display dpy set-global - dpy get XDefaultScreen scr set-global - dpy get scr get XRootWindow root set-global ; - -: close-x ( -- ) dpy get XCloseDisplay drop ; - -: with-x ( display-string quot -- ) - [ initialize-x ] dip [ close-x ] [ ] cleanup ; +X-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ; diff --git a/basis/xml/syntax/syntax-tests.factor b/basis/xml/syntax/syntax-tests.factor index 10ab961ec0..6fcaf780cc 100644 --- a/basis/xml/syntax/syntax-tests.factor +++ b/basis/xml/syntax/syntax-tests.factor @@ -33,8 +33,6 @@ TAG: neg calculate calc-arith ] unit-test -\ calc-arith must-infer - XML-NS: foo http://blah.com [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test @@ -90,7 +88,6 @@ XML-NS: foo http://blah.com [ "3" ] [ 3 [XML <-> XML] xml>string ] unit-test [ "" ] [ f [XML <-> XML] xml>string ] unit-test -\ XML] ] must-infer [ [XML <-> /> XML] ] must-infer diff --git a/basis/xml/syntax/tags.txt b/basis/xml/syntax/tags.txt index 71c0ff7282..4f4a20b1cb 100644 --- a/basis/xml/syntax/tags.txt +++ b/basis/xml/syntax/tags.txt @@ -1 +1,2 @@ +extensions syntax diff --git a/basis/xml/tests/state-parser-tests.factor b/basis/xml/tests/state-parser-tests.factor index 7616efaf1d..5e214dc4a3 100644 --- a/basis/xml/tests/state-parser-tests.factor +++ b/basis/xml/tests/state-parser-tests.factor @@ -2,7 +2,7 @@ USING: tools.test xml.tokenize xml.state io.streams.string kernel io strings asc IN: xml.test.state : string-parse ( str quot -- ) - [ ] dip with-state ; + [ ] dip with-state ; inline : take-rest ( -- string ) [ f ] take-until ; diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index 1d07aa9406..74ba931c79 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -7,9 +7,7 @@ xml.traversal continuations assocs io.encodings.binary sequences.deep accessors io.streams.string ; ! This is insufficient -\ read-xml must-infer [ [ drop ] each-element ] must-infer -\ string>xml must-infer SYMBOL: xml-file [ ] [ diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index c41b05eb85..55b5147abb 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -43,7 +43,7 @@ MACRO: drop-input ( quot -- newquot ) xml-tests [ unit-test ] assoc-each ; : works? ( result quot -- ? ) - [ first ] [ call ] bi* = ; + [ first ] [ call( -- result ) ] bi* = ; : partition-xml-tests ( -- successes failures ) xml-tests [ first2 works? ] partition ; diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index f19e845ab9..ee09668a53 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -1,13 +1,10 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml.data xml.writer tools.test fry xml kernel multiline +USING: xml.data xml.writer tools.test fry xml xml.syntax kernel multiline xml.writer.private io.streams.string xml.traversal sequences -io.encodings.utf8 io.files accessors io.directories ; +io.encodings.utf8 io.files accessors io.directories math math.parser ; IN: xml.writer.tests -\ write-xml must-infer -\ xml>string must-infer -\ pprint-xml must-infer ! Add a test for pprint-xml with sensitive-tags [ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test @@ -66,3 +63,11 @@ CONSTANT: test-file "resource:basis/xml/writer/test.xml" [ ] [ "" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test [ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test [ ] [ test-file delete-file ] unit-test + +[ ] [ + { 1 2 3 4 } [ + [ number>string ] [ sq number>string ] bi + [XML XML] + ] map [XML

Timings

<-><->
<->
XML] + pprint-xml +] unit-test \ No newline at end of file diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 4f5bad1aa5..ab957ebc75 100755 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -19,7 +19,7 @@ SYMBOL: indentation : indent-string ( -- string ) xml-pprint? get - [ indentation get indenter get concat ] + [ indentation get indenter get "" join ] [ "" ] if ; : ?indent ( -- ) diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor index 8d5db4a6e9..d57b8ce28d 100644 --- a/basis/xmode/code2html/code2html-tests.factor +++ b/basis/xmode/code2html/code2html-tests.factor @@ -3,8 +3,6 @@ USING: xmode.code2html xmode.catalog tools.test multiline splitting memoize kernel io.streams.string xml.writer ; -\ htmlize-file must-infer - [ ] [ \ (load-mode) reset-memoized ] unit-test [ ] [ diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor index 3fb5a532c9..b5141f6cc4 100644 --- a/basis/xmode/code2html/code2html.factor +++ b/basis/xmode/code2html/code2html.factor @@ -24,7 +24,7 @@ IN: xmode.code2html [XML 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 ad64c541fe..ba5815cfc1 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -22,6 +22,13 @@ test_program_installed() { return 1; } +exit_script() { + if [[ $FIND_MAKE_TARGET -eq true ]] ; then + echo $MAKE_TARGET; + fi + exit $1 +} + ensure_program_installed() { installed=0; for i in $* ; @@ -43,7 +50,7 @@ ensure_program_installed() { $ECHO -n "any of [ $* ]" fi $ECHO " and try again." - exit 1 + exit_script 1; fi } @@ -51,7 +58,7 @@ check_ret() { RET=$? if [[ $RET -ne 0 ]] ; then $ECHO $1 failed - exit 2 + exit_script 2 fi } @@ -62,7 +69,7 @@ check_gcc_version() { if [[ $GCC_VERSION == *3.3.* ]] ; then $ECHO "You have a known buggy version of gcc (3.3)" $ECHO "Install gcc 3.4 or higher and try again." - exit 3 + exit_script 3 elif [[ $GCC_VERSION == *4.3.* ]] ; then MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate" fi @@ -139,7 +146,6 @@ check_library_exists() { } check_X11_libraries() { - check_library_exists GLU check_library_exists GL check_library_exists X11 check_library_exists pango-1.0 @@ -155,7 +161,7 @@ check_factor_exists() { if [[ -d "factor" ]] ; then $ECHO "A directory called 'factor' already exists." $ECHO "Rename or delete it and try again." - exit 4 + exit_script 4 fi } @@ -199,7 +205,7 @@ find_architecture() { write_test_program() { echo "#include " > $C_WORD.c - echo "int main(){printf(\"%d\", 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() { @@ -280,7 +286,7 @@ check_os_arch_word() { $ECHO "OS, ARCH, or WORD is empty. Please report this." echo $MAKE_TARGET - exit 5 + exit_script 5 fi } @@ -386,7 +392,7 @@ check_makefile_exists() { echo "You are likely in the wrong directory." echo "Run this script from your factor directory:" echo " ./build-support/factor.sh" - exit 6 + exit_script 6 fi } @@ -491,7 +497,7 @@ make_boot_image() { } install_build_system_apt() { - sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make check_ret sudo } @@ -537,6 +543,6 @@ case "$1" in bootstrap) get_config_info; bootstrap ;; report) find_build_info ;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;; - make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;; + make-target) FIND_MAKE_TARGET=true; ECHO=false; find_build_info; exit_script ;; *) usage ;; esac diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 6bd1d2f53a..66e67ab322 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -145,12 +145,6 @@ ARTICLE: "reading-writing-memory" "Reading and writing memory directly" { $subsection set-alien-float } { $subsection set-alien-double } ; -ARTICLE: "loading-libs" "Loading native libraries" -"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:" -{ $subsection add-library } -"Once a library has been defined, you can try loading it to see if the path name is correct:" -{ $subsection load-library } ; - ARTICLE: "alien-invoke" "Calling C from Factor" "The easiest way to call into a C library is to define bindings using a pair of parsing words:" { $subsection POSTPONE: LIBRARY: } diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 57dc298c00..d3265f31bb 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,6 +1,6 @@ USING: accessors alien alien.accessors alien.syntax byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math -system prettyprint layouts alien.libraries ; +system prettyprint layouts alien.libraries sets ; IN: alien.tests [ t ] [ -1 alien-address 0 > ] unit-test @@ -86,3 +86,5 @@ f initialize-test set-global [ ] [ initialize-test get BAD-ALIEN >>alien drop ] unit-test [ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test + +[ V{ BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test \ No newline at end of file diff --git a/core/alien/alien.factor b/core/alien/alien.factor index ea0cb9208e..ec38e3be5b 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -49,6 +49,8 @@ M: alien equal? 2drop f ] if ; +M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ; + ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) 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..943530d4f2 --- /dev/null +++ b/core/alien/strings/strings.factor @@ -0,0 +1,61 @@ +! 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 ) + +HOOK: native-string>alien os ( string -- alien ) + +M: windows alien>native-string utf16n alien>string ; + +M: wince native-string>alien utf16n string>alien ; + +M: winnt native-string>alien utf8 string>alien ; + +M: unix alien>native-string utf8 alien>string ; + +M: unix native-string>alien utf8 string>alien ; + +: dll-path ( dll -- string ) + path>> alien>native-string ; + +: string>symbol ( str -- alien ) + dup string? + [ native-string>alien ] + [ [ native-string>alien ] map ] if ; + +[ + 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-docs.factor b/core/assocs/assocs-docs.factor index 9576a41b7b..d4046a4dcf 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -361,8 +361,7 @@ HELP: inc-at HELP: >alist { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } } -{ $contract "Converts an associative structure into an association list." } -{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which constructs the association list by iterating over the assoc with " { $link assoc-find } "." } ; +{ $contract "Converts an associative structure into an association list." } ; HELP: assoc-clone-like { $values 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 4466bd9bfe..e5a6bbe5fa 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 @@ -12,8 +12,6 @@ IN: bootstrap.primitives "Creating primitives and basic runtime structures..." print flush -crossref off - H{ } clone sub-primitives set "vocab:bootstrap/syntax.factor" parse-file @@ -71,6 +69,8 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" + "generic.single" + "generic.single.private" "growable" "hashtables" "hashtables.private" @@ -82,8 +82,10 @@ bootstrapping? on "kernel" "kernel.private" "math" + "math.parser.private" "math.private" "memory" + "memory.private" "quotations" "quotations.private" "sbufs" @@ -99,7 +101,6 @@ bootstrapping? on "threads.private" "tools.profiler.private" "words" - "words.private" "vectors" "vectors.private" } [ create-vocab drop ] each @@ -127,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 @@ -148,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 , @@ -212,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 @@ -260,7 +231,7 @@ bi "vocabulary" { "def" { "quotation" "quotations" } initial: [ ] } "props" - { "optimized" read-only } + { "direct-entry-def" } { "counter" { "fixnum" "math" } } { "sub-primitive" read-only } } define-builtin @@ -340,7 +311,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 )) } @@ -380,6 +351,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 @@ -396,14 +368,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 )) } @@ -446,8 +416,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 )) } @@ -459,38 +429,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 )) } @@ -504,7 +474,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 -- )) } @@ -528,13 +498,21 @@ tuple { "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 -- )) } + { "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-docs.factor b/core/bootstrap/syntax-docs.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 6e6812e25c..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/basis/byte-vectors/tags.txt b/core/byte-vectors/tags.txt similarity index 100% rename from basis/byte-vectors/tags.txt rename to core/byte-vectors/tags.txt diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor index 1ec675b0cf..8ba09d8e91 100644 --- a/core/checksums/checksums-tests.factor +++ b/core/checksums/checksums-tests.factor @@ -1,7 +1,3 @@ IN: checksums.tests USING: checksums tools.test ; -\ checksum-bytes must-infer -\ checksum-stream must-infer -\ checksum-lines must-infer -\ checksum-file must-infer 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..7655ec8482 100644 --- a/core/checksums/crc32/crc32.factor +++ b/core/checksums/crc32/crc32.factor @@ -9,7 +9,7 @@ CONSTANT: crc32-polynomial HEX: edb88320 CONSTANT: crc32-table V{ } -256 [ +256 iota [ 8 [ [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless ] times >bignum diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index a3610ff7c5..3069c4b555 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -7,12 +7,6 @@ random stack-checker effects kernel.private sbufs math.order classes.tuple accessors ; IN: classes.algebra.tests -\ class< must-infer -\ class-and must-infer -\ class-or must-infer -\ flatten-class must-infer -\ flatten-builtin-class must-infer - : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; @@ -311,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 0e4a3b56fd..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 ; @@ -55,7 +55,7 @@ M: anonymous-intersection (flatten-class) [ builtins get sift [ (flatten-class) ] each ] [ - unclip [ assoc-intersect ] reduce [ swap set ] assoc-each + [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each ] if-empty ; M: anonymous-complement (flatten-class) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 673c108b27..61d153f064 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ io.streams.string kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files compiler.units -kernel.private sorting vocabs memory eval accessors ; +kernel.private sorting vocabs memory eval accessors sets ; IN: classes.tests [ t ] [ 3 object instance? ] unit-test @@ -22,17 +22,18 @@ M: method-forget-class method-forget-test ; [ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test [ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test -[ t ] [ +[ { } { } ] [ all-words [ class? ] filter implementors-map get keys - [ natural-sort ] bi@ = + [ natural-sort ] bi@ + [ diff ] [ swap diff ] 2bi ] unit-test ! Minor leak -[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test +[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval( -- ) ] unit-test [ ] [ f \ word set-global ] unit-test -[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test -[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test +[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval( -- ) ] unit-test +[ ] [ "IN: classes.tests FORGET: forget-me" eval( -- ) ] unit-test [ 0 ] [ [ word? ] instances [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count diff --git a/core/classes/classes.factor b/core/classes/classes.factor index eded33beed..dfaec95f76 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -135,7 +135,7 @@ M: sequence implementors [ implementors ] gather ; [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ] [ reset-class ] [ ?define-symbol ] - [ redefined ] + [ changed-definition ] [ ] } cleave ] dip [ assoc-union ] curry change-props @@ -174,8 +174,7 @@ GENERIC: update-methods ( class seq -- ) [ forget ] [ drop ] if ] [ 2drop ] if ; -: forget-methods ( class -- ) - [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ; +GENERIC: forget-methods ( class -- ) GENERIC: class-forgotten ( use class -- ) diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index 376eace4ed..f44642fdd5 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -42,7 +42,7 @@ INSTANCE: integer mx1 [ t ] [ mx1 integer class<= ] unit-test [ t ] [ mx1 number class<= ] unit-test -"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval +"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- ) [ t ] [ array mx1 class<= ] unit-test [ f ] [ mx1 number class<= ] unit-test @@ -118,4 +118,14 @@ 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 \ No newline at end of file +[ { 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-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 22b5784269..b95507c78b 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -50,20 +50,20 @@ TUPLE: test-8 { b integer read-only } ; DEFER: foo -[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ] +[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval( -- ) ] [ error>> invalid-slot-name? ] must-fail-with -[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ] +[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval( -- ) ] [ error>> invalid-slot-name? ] must-fail-with -[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ] +[ "IN: classes.tuple.parser.tests TUPLE: foo" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with 2 [ - [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] + [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval( -- ) ] [ error>> no-initial-value? ] must-fail-with @@ -71,14 +71,14 @@ must-fail-with ] times 2 [ - [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ] + [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval( -- ) ] [ error>> bad-initial-value? ] must-fail-with [ f ] [ \ foo tuple-class? ] unit-test ] times -[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ] +[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval( -- ) ] [ error>> duplicate-slot-names? ] must-fail-with @@ -107,7 +107,7 @@ TUPLE: parsing-corner-case x ; " f" " 3" "}" - } "\n" join eval + } "\n" join eval( -- tuple ) ] unit-test [ T{ parsing-corner-case f 3 } ] [ @@ -116,7 +116,7 @@ TUPLE: parsing-corner-case x ; "T{ parsing-corner-case" " { x 3 }" "}" - } "\n" join eval + } "\n" join eval( -- tuple ) ] unit-test [ T{ parsing-corner-case f 3 } ] [ @@ -125,7 +125,7 @@ TUPLE: parsing-corner-case x ; "T{ parsing-corner-case {" " x 3 }" "}" - } "\n" join eval + } "\n" join eval( -- tuple ) ] unit-test @@ -133,12 +133,12 @@ TUPLE: parsing-corner-case x ; { "USE: classes.tuple.parser.tests T{ parsing-corner-case" " { x 3 }" - } "\n" join eval + } "\n" join eval( -- tuple ) ] [ error>> unexpected-eof? ] must-fail-with [ { "USE: classes.tuple.parser.tests T{ parsing-corner-case {" " x 3 }" - } "\n" join eval + } "\n" join eval( -- tuple ) ] [ error>> unexpected-eof? ] must-fail-with 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 32cab65904..4c55001aa1 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -92,7 +92,7 @@ ARTICLE: "tuple-constructors" "Tuple constructors" $nl "Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple with initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "." $nl -"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers." +"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construct a different class, without breaking callers." $nl "Examples of constructors:" { $code @@ -220,13 +220,13 @@ ARTICLE: "tuple-examples" "Tuple examples" " \"project manager\" >>position ;" } "An alternative strategy is to define the most general BOA constructor first:" { $code - ": ( name position -- person )" + ": ( name position -- employee )" " 40000 employee boa ;" } "Now we can define more specific constructors:" { $code - ": ( name -- person )" - " \"manager\" ;" } + ": ( name -- employee )" + " \"manager\" ;" } "An example using reader words:" { $code "TUPLE: check to amount number ;" @@ -254,9 +254,9 @@ ARTICLE: "tuple-examples" "Tuple examples" " } ;" "" ": next-position ( role -- newrole )" - " positions [ index 1+ ] keep nth ;" + " positions [ index 1 + ] keep nth ;" "" - ": promote ( person -- person )" + ": promote ( employee -- employee )" " [ 1.2 * ] change-salary" " [ next-position ] change-position ;" } diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index fa2df4e312..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 ; +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 ; @@ -27,19 +27,17 @@ C: redefinition-test [ t ] [ "redefinition-test" get redefinition-test? ] unit-test -"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval +"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- ) [ t ] [ "redefinition-test" get redefinition-test? ] unit-test ! Make sure we handle changing shapes! TUPLE: point x y ; -C: point - -[ ] [ 100 200 "p" set ] unit-test +[ ] [ 100 200 point boa "p" set ] unit-test ! Use eval to sequence parsing explicitly -[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test [ 100 ] [ "p" get x>> ] unit-test [ 200 ] [ "p" get y>> ] unit-test @@ -51,7 +49,7 @@ C: point [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test [ 2 ] [ "p" get tuple-size ] unit-test @@ -89,7 +87,7 @@ C: empty [ t length ] [ object>> t eq? ] must-fail-with [ "" ] -[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval word name>> ] unit-test +[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval( -- ) word name>> ] unit-test TUPLE: size-test a b c d ; @@ -102,7 +100,7 @@ GENERIC: ( a -- b ) TUPLE: yo-momma ; -[ ] [ "IN: classes.tuple.tests C: yo-momma" eval ] unit-test +[ ] [ "IN: classes.tuple.tests C: yo-momma" eval( -- ) ] unit-test [ f ] [ \ generic? ] unit-test @@ -112,8 +110,6 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ ] [ \ forget ] unit-test [ f ] [ \ yo-momma update-map get values memq? ] unit-test - - [ f ] [ \ yo-momma crossref get at ] unit-test ] with-compilation-unit TUPLE: loc-recording ; @@ -133,7 +129,7 @@ M: integer forget-robustness-generic ; [ [ ] [ \ forget-robustness-generic forget ] unit-test [ ] [ \ forget-robustness forget ] unit-test - [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test + [ ] [ M\ forget-robustness forget-robustness-generic forget ] unit-test ] with-compilation-unit ! rapido found this one @@ -199,17 +195,6 @@ TUPLE: erg's-reshape-problem a b c d ; C: erg's-reshape-problem -! We want to make sure constructors are recompiled when -! tuples are reshaped -: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ; -: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ; - -[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test - -[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test - -[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test - ! Inheritance TUPLE: computer cpu ram ; C: computer @@ -281,13 +266,13 @@ test-server-slot-values ] unit-test [ - "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval + "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval( -- ) ] must-fail ! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test [ f ] [ electronic-device laptop class<= ] unit-test [ t ] [ server electronic-device class<= ] unit-test @@ -303,17 +288,17 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -326,7 +311,7 @@ TUPLE: make-me-some-accessors voltage grounded? ; [ ] [ "laptop" get 220 >>voltage drop ] unit-test [ ] [ "server" get 110 >>voltage drop ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: computer" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -334,7 +319,7 @@ test-server-slot-values [ 220 ] [ "laptop" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -343,7 +328,7 @@ test-server-slot-values [ 110 ] [ "server" get voltage>> ] unit-test ! Reshaping superclass and subclass simultaneously -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ; C: computer C: laptop C: server" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -354,9 +339,7 @@ test-server-slot-values ! Reshape crash TUPLE: test1 a ; TUPLE: test2 < test1 b ; -C: test2 - -"a" "b" "test" set +"a" "b" test2 boa "test" set : test-a/b ( -- ) [ "a" ] [ "test" get a>> ] unit-test @@ -364,11 +347,11 @@ C: test2 test-a/b -[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test test-a/b -[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test test-a/b @@ -393,34 +376,36 @@ T{ move-up-2 f "a" "b" "c" } "move-up" set test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test ! Constructors must be recompiled when changing superclass TUPLE: constructor-update-1 xxx ; TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ; -C: constructor-update-2 +: ( a b c -- tuple ) constructor-update-2 boa ; { 3 1 } [ ] must-infer-as -[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test -{ 5 1 } [ ] must-infer-as +{ 3 1 } [ ] must-infer-as -[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 tuple-slots ] unit-test +[ 1 2 3 4 5 ] [ not-compiled? ] must-fail-with + +[ ] [ [ \ forget ] with-compilation-unit ] unit-test ! Redefinition problem TUPLE: redefinition-problem ; @@ -431,7 +416,7 @@ UNION: redefinition-problem' redefinition-problem integer ; TUPLE: redefinition-problem-2 ; -"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval +"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval( -- ) [ t ] [ 3 redefinition-problem'? ] unit-test @@ -472,7 +457,7 @@ USE: vocabs ] with-compilation-unit ] unit-test -[ "USE: words T{ word }" eval ] +[ "USE: words T{ word }" eval( -- ) ] [ error>> T{ no-method f word new } = ] must-fail-with @@ -485,7 +470,7 @@ must-fail-with [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test -: accessor-exists? ( class name -- ? ) +: accessor-exists? ( name -- ? ) [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip ">>" append "accessors" lookup method >boolean ; @@ -520,13 +505,13 @@ TUPLE: another-forget-accessors-test ; [ f ] [ t parser-notes? [ [ - "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval + "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval( -- ) ] with-string-writer empty? ] with-variable ] unit-test ! Missing error check -[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail +[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail ! Class forget messyness TUPLE: subclass-forget-test ; @@ -535,7 +520,7 @@ TUPLE: subclass-forget-test-1 < subclass-forget-test ; TUPLE: subclass-forget-test-2 < subclass-forget-test ; TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ; -[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test +[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval( -- ) ] unit-test [ { subclass-forget-test-2 } ] [ subclass-forget-test-2 class-usages ] @@ -549,7 +534,7 @@ unit-test [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test [ subclass-forget-test-3 new ] must-fail -[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail +[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval( -- ) ] must-fail ! More DEFER: subclass-reset-test @@ -559,14 +544,14 @@ DEFER: subclass-reset-test-3 GENERIC: break-me ( obj -- ) -[ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test +[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" "subclass-reset-test" parse-stream drop ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval( -- ) ] unit-test -[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval( -- ) ] unit-test [ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" "subclass-reset-test" parse-stream drop ] unit-test @@ -576,7 +561,7 @@ GENERIC: break-me ( obj -- ) [ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test -[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval( -- ) ] unit-test [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test @@ -599,7 +584,7 @@ must-fail-with : foo ( a b -- c ) declared-types boa ; -\ foo must-infer +\ foo def>> must-infer [ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test @@ -623,7 +608,7 @@ must-fail-with : blah ( -- vec ) vector new ; -\ blah must-infer +[ vector new ] must-infer [ V{ } ] [ blah ] unit-test @@ -632,7 +617,7 @@ TUPLE: reshape-test x ; T{ reshape-test f "hi" } "tuple" set -[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test [ f ] [ \ reshape-test \ (>>x) method ] unit-test @@ -640,11 +625,11 @@ T{ reshape-test f "hi" } "tuple" set [ "hi" ] [ "tuple" get x>> ] unit-test -[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test -[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test @@ -660,20 +645,20 @@ ERROR: error-class-test a b c ; [ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test [ f ] [ \ error-class-test "inline" word-prop ] unit-test -[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ] +[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ] [ error>> error>> redefine-error? ] must-fail-with DEFER: error-y [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test -[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test +[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test [ f ] [ \ error-y tuple-class? ] unit-test [ t ] [ \ error-y generic? ] unit-test -[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test [ t ] [ \ error-y tuple-class? ] unit-test @@ -694,7 +679,7 @@ DEFER: error-y ] unit-test [ ] [ - "IN: sequences TUPLE: reversed { seq read-only } ;" eval + "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- ) ] unit-test TUPLE: bogus-hashcode-1 x ; @@ -735,14 +720,14 @@ SLOT: kex DEFER: redefine-tuple-twice -[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test -[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test +[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test [ t ] [ \ redefine-tuple-twice deferred? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test -[ t ] [ \ redefine-tuple-twice symbol? ] unit-test \ No newline at end of file +[ t ] [ \ redefine-tuple-twice symbol? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index fb7a073205..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 ; @@ -243,7 +243,7 @@ M: tuple-class update-class 2drop [ [ update-tuples-after ] - [ redefined ] + [ changed-definition ] bi ] each-subclass ] @@ -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/classes/union/union-tests.factor b/core/classes/union/union-tests.factor index 57b742595f..52550b2356 100644 --- a/core/classes/union/union-tests.factor +++ b/core/classes/union/union-tests.factor @@ -26,13 +26,13 @@ M: union-1 generic-update-test drop "union-1" ; [ t ] [ union-1 number class<= ] unit-test [ "union-1" ] [ 1.0 generic-update-test ] unit-test -"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval +"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval( -- ) [ t ] [ bignum union-1 class<= ] unit-test [ f ] [ union-1 number class<= ] unit-test [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test -"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval +"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval( -- ) [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test @@ -58,7 +58,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; [ t ] [ fixnum redefine-bug-2 class<= ] unit-test [ t ] [ quotation redefine-bug-2 class<= ] unit-test -[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test +[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval( -- ) ] unit-test [ t ] [ bignum redefine-bug-1 class<= ] unit-test [ f ] [ fixnum redefine-bug-2 class<= ] unit-test diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor old mode 100644 new mode 100755 index cc502140ad..8b301affbd --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -4,46 +4,309 @@ math assocs sequences sequences.private combinators.private effects words ; IN: combinators +ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" +"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." +$nl +"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" +{ $code + ": keep [ ] bi ;" + ": 2keep [ ] 2bi ;" + ": 3keep [ ] 3bi ;" + "" + ": dup [ ] [ ] bi ;" + ": 2dup [ ] [ ] 2bi ;" + ": 3dup [ ] [ ] 3bi ;" + "" + ": tuck [ nip ] [ ] 2bi ;" + ": swap [ nip ] [ drop ] 2bi ;" + "" + ": over [ ] [ drop ] 2bi ;" + ": pick [ ] [ 2drop ] 3bi ;" + ": 2over [ ] [ drop ] 3bi ;" +} ; + +ARTICLE: "cleave-combinators" "Cleave combinators" +"The cleave combinators apply multiple quotations to a single value." +$nl +"Two quotations:" +{ $subsection bi } +{ $subsection 2bi } +{ $subsection 3bi } +"Three quotations:" +{ $subsection tri } +{ $subsection 2tri } +{ $subsection 3tri } +"An array of quotations:" +{ $subsection cleave } +{ $subsection 2cleave } +{ $subsection 3cleave } +"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" +{ $code + "! First alternative; uses keep" + "[ 1 + ] keep" + "[ 1 - ] keep" + "2 *" + "! Second alternative: uses tri" + "[ 1 + ]" + "[ 1 - ]" + "[ 2 * ] tri" +} +"The latter is more aesthetically pleasing than the former." +{ $subsection "cleave-shuffle-equivalence" } ; + +ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" +"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "." +$nl +"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" +{ $code + ": dip [ ] bi* ;" + ": 2dip [ ] [ ] tri* ;" + "" + ": slip [ call ] [ ] bi* ;" + ": 2slip [ call ] [ ] [ ] tri* ;" + "" + ": nip [ drop ] [ ] bi* ;" + ": 2nip [ drop ] [ drop ] [ ] tri* ;" + "" + ": rot" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" + "" + ": -rot" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " 3tri ;" + "" + ": spin" + " [ [ drop ] [ drop ] [ ] tri* ]" + " [ [ drop ] [ ] [ drop ] tri* ]" + " [ [ ] [ drop ] [ drop ] tri* ]" + " 3tri ;" +} ; + +ARTICLE: "spread-combinators" "Spread combinators" +"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading." +$nl +"Two quotations:" +{ $subsection bi* } +{ $subsection 2bi* } +"Three quotations:" +{ $subsection tri* } +{ $subsection 2tri* } +"An array of quotations:" +{ $subsection spread } +"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" +{ $code + "! First alternative; uses dip" + "[ [ 1 + ] dip 1 - ] dip 2 *" + "! Second alternative: uses tri*" + "[ 1 + ] [ 1 - ] [ 2 * ] tri*" +} +"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." +{ $subsection "spread-shuffle-equivalence" } ; + +ARTICLE: "apply-combinators" "Apply combinators" +"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application." +$nl +"Two quotations:" +{ $subsection bi@ } +{ $subsection 2bi@ } +"Three quotations:" +{ $subsection tri@ } +{ $subsection 2tri@ } +"A pair of utility words built from " { $link bi@ } ":" +{ $subsection both? } +{ $subsection either? } ; + +ARTICLE: "slip-keep-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:" +{ $subsection dip } +{ $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 } +{ $subsection 3keep } ; + +ARTICLE: "curried-dataflow" "Curried dataflow combinators" +"Curried cleave combinators:" +{ $subsection bi-curry } +{ $subsection tri-curry } +"Curried spread combinators:" +{ $subsection bi-curry* } +{ $subsection tri-curry* } +"Curried apply combinators:" +{ $subsection bi-curry@ } +{ $subsection tri-curry@ } +{ $see-also "dataflow-combinators" } ; + +ARTICLE: "compositional-examples" "Examples of compositional combinator usage" +"Consider printing the same message ten times:" +{ $code ": print-10 ( -- ) 10 [ \"Hello, world.\" print ] times ;" } +"if we wanted to abstract out the message into a parameter, we could keep it on the stack between iterations:" +{ $code ": print-10 ( message -- ) 10 [ dup print ] times drop ;" } +"However, keeping loop-invariant values on the stack doesn't always work out nicely. For example, a word to subtract a value from each element of a sequence:" +{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" } +"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":" +{ $example + "USING: kernel math prettyprint sequences ;" + ": subtract-n ( seq n -- seq' ) [ - ] curry map ;" + "{ 10 20 30 } 5 subtract-n ." + "{ 5 15 25 }" +} +"Now consider the word that is dual to the one above; instead of subtracting " { $snippet "n" } " from each stack element, it subtracts each element from " { $snippet "n" } "." +$nl +"One way to write this is with a pair of " { $link swap } "s:" +{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" } +"Since this pattern comes up often, " { $link with } " encapsulates it:" +{ $example + "USING: kernel math prettyprint sequences ;" + ": n-subtract ( n seq -- seq' ) [ - ] with map ;" + "30 { 10 20 30 } n-subtract ." + "{ 20 10 0 }" +} +{ $see-also "fry.examples" } ; + +ARTICLE: "compositional-combinators" "Compositional combinators" +"Certain combinators transform quotations to produce a new quotation." +{ $subsection "compositional-examples" } +"Fundamental operations:" +{ $subsection curry } +{ $subsection compose } +"Derived operations:" +{ $subsection 2curry } +{ $subsection 3curry } +{ $subsection with } +{ $subsection prepose } +"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words." +$nl +"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways." +{ $subsection "curried-dataflow" } +"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ; + +ARTICLE: "booleans" "Booleans" +"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." +{ $subsection f } +{ $subsection t } +"A union class of the above:" +{ $subsection boolean } +"There are some logical operations on booleans:" +{ $subsection >boolean } +{ $subsection not } +{ $subsection and } +{ $subsection or } +{ $subsection xor } +"Boolean values are most frequently used for " { $link "conditionals" } "." +{ $heading "The f object and f class" } +"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing." +$nl +"Here is the " { $link f } " object:" +{ $example "f ." "f" } +"Here is the " { $link f } " class:" +{ $example "\\ f ." "POSTPONE: f" } +"They are not equal:" +{ $example "f \\ f = ." "f" } +"Here is an array containing the " { $link f } " object:" +{ $example "{ f } ." "{ f }" } +"Here is an array containing the " { $link f } " class:" +{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" } +"The " { $link f } " object is an instance of the " { $link f } " class:" +{ $example "USE: classes" "f class ." "POSTPONE: f" } +"The " { $link f } " class is an instance of " { $link word } ":" +{ $example "USE: classes" "\\ f class ." "word" } +"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of." +{ $example "t \\ t eq? ." "t" } +"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; + +ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic" +"Certain simple conditional forms can be expressed in a simpler manner using boolean logic." +$nl +"The following two lines are equivalent:" +{ $code "[ drop f ] unless" "swap and" } +"The following two lines are equivalent:" +{ $code "[ ] [ ] ?if" "swap or" } +"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" +{ $code "[ L ] unless*" "L or" } ; + +ARTICLE: "conditionals" "Conditional combinators" +"The basic conditionals:" +{ $subsection if } +{ $subsection when } +{ $subsection unless } +"Forms abstracting a common stack shuffle pattern:" +{ $subsection if* } +{ $subsection when* } +{ $subsection unless* } +"Another form abstracting a common stack shuffle pattern:" +{ $subsection ?if } +"Sometimes instead of branching, you just need to pick one of two values:" +{ $subsection ? } +"Two combinators which abstract out nested chains of " { $link if } ":" +{ $subsection cond } +{ $subsection case } +{ $subsection "conditionals-boolean-equivalence" } +{ $see-also "booleans" "bitwise-arithmetic" both? either? } ; + +ARTICLE: "dataflow-combinators" "Data flow combinators" +"Data flow combinators pass values between quotations:" +{ $subsection "slip-keep-combinators" } +{ $subsection "cleave-combinators" } +{ $subsection "spread-combinators" } +{ $subsection "apply-combinators" } +{ $see-also "curried-dataflow" } ; + ARTICLE: "combinators-quot" "Quotation construction utilities" "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:" { $subsection cond>quot } { $subsection case>quot } { $subsection alist>quot } ; -ARTICLE: "call" "Calling code with known stack effects" -"Arbitrary quotations and words can be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." -$nl -"Quotations:" -{ $subsection POSTPONE: call( } -{ $subsection call-effect } -"Words:" -{ $subsection POSTPONE: execute( } -{ $subsection execute-effect } -"Unsafe calls:" +ARTICLE: "call-unsafe" "Unsafe combinators" +"Unsafe calls declare an effect statically without any runtime checking:" { $subsection call-effect-unsafe } { $subsection execute-effect-unsafe } ; -ARTICLE: "combinators" "Additional combinators" -"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators." +ARTICLE: "call" "Fundamental combinators" +"The most basic combinators are those that take either a quotation or word, and invoke it immediately." $nl -"Generalization of " { $link bi } " and " { $link tri } ":" -{ $subsection cleave } -"Generalization of " { $link 2bi } " and " { $link 2tri } ":" -{ $subsection 2cleave } -"Generalization of " { $link 3bi } " and " { $link 3tri } ":" -{ $subsection 3cleave } -"Generalization of " { $link bi* } " and " { $link tri* } ":" -{ $subsection spread } -"Two combinators which abstract out nested chains of " { $link if } ":" -{ $subsection cond } -{ $subsection case } -"The " { $vocab-link "combinators" } " also provides some less frequently-used features." +"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared." $nl -"A combinator which can help with implementing methods on " { $link hashcode* } ":" -{ $subsection recursive-hashcode } +"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:" +{ $subsection call } +{ $subsection execute } +"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:" +{ $subsection POSTPONE: call( } +{ $subsection POSTPONE: execute( } +"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 } +"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" } ; + +ARTICLE: "combinators" "Combinators" +"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." { $subsection "call" } +{ $subsection "dataflow-combinators" } +{ $subsection "conditionals" } +{ $subsection "looping-combinators" } +{ $subsection "compositional-combinators" } +{ $subsection "combinators.short-circuit" } +{ $subsection "combinators.smart" } +"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." { $subsection "combinators-quot" } -{ $see-also "quotations" "dataflow" } ; +{ $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 76f9f63c49..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 @@ -42,7 +42,7 @@ IN: combinators.tests { [ dup 2 mod 1 = ] [ drop "odd" ] } } cond ; -\ cond-test-1 must-infer +\ cond-test-1 def>> must-infer [ "even" ] [ 2 cond-test-1 ] unit-test [ "odd" ] [ 3 cond-test-1 ] unit-test @@ -54,7 +54,7 @@ IN: combinators.tests [ drop "something else" ] } cond ; -\ cond-test-2 must-infer +\ cond-test-2 def>> must-infer [ "true" ] [ t cond-test-2 ] unit-test [ "false" ] [ f cond-test-2 ] unit-test @@ -67,7 +67,7 @@ IN: combinators.tests { [ dup f = ] [ drop "false" ] } } cond ; -\ cond-test-3 must-infer +\ cond-test-3 def>> must-infer [ "something else" ] [ t cond-test-3 ] unit-test [ "something else" ] [ f cond-test-3 ] unit-test @@ -77,7 +77,7 @@ IN: combinators.tests { } cond ; -\ cond-test-4 must-infer +\ cond-test-4 def>> must-infer [ cond-test-4 ] [ class \ no-cond = ] must-fail-with @@ -168,7 +168,7 @@ IN: combinators.tests { 4 [ "four" ] } } case ; -\ case-test-1 must-infer +\ case-test-1 def>> must-infer [ "two" ] [ 2 case-test-1 ] unit-test @@ -186,7 +186,7 @@ IN: combinators.tests [ sq ] } case ; -\ case-test-2 must-infer +\ case-test-2 def>> must-infer [ 25 ] [ 5 case-test-2 ] unit-test @@ -204,7 +204,7 @@ IN: combinators.tests [ sq ] } case ; -\ case-test-3 must-infer +\ case-test-3 def>> must-infer [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test @@ -222,7 +222,7 @@ CONSTANT: case-const-2 2 [ drop "demasiado" ] } case ; -\ case-test-4 must-infer +\ case-test-4 def>> must-infer [ "uno" ] [ 1 case-test-4 ] unit-test [ "dos" ] [ 2 case-test-4 ] unit-test @@ -239,7 +239,7 @@ CONSTANT: case-const-2 2 [ drop "demasiado" print ] } case ; -\ case-test-5 must-infer +\ case-test-5 def>> must-infer [ ] [ 1 case-test-5 ] unit-test @@ -296,7 +296,7 @@ CONSTANT: case-const-2 2 { 3 [ "three" ] } } case ; -\ test-case-6 must-infer +\ test-case-6 def>> must-infer [ "three" ] [ 3 test-case-6 ] unit-test [ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test @@ -343,7 +343,7 @@ CONSTANT: case-const-2 2 { \ ] [ "KFC" ] } } case ; -\ test-case-7 must-infer +\ test-case-7 def>> must-infer [ "plus" ] [ \ + test-case-7 ] unit-test @@ -352,12 +352,12 @@ 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 -: test-case-8 ( n -- ) +: test-case-8 ( n -- string ) { { 1 [ "foo" ] } } case ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 4c600e06ca..7bf76fea30 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -86,6 +86,8 @@ ERROR: no-case object ; ] [ callable? ] if ] find nip ; +\ case-find t "no-compile" set-word-prop + : case ( obj assoc -- ) case-find { { [ dup array? ] [ nip second call ] } @@ -121,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 ) @@ -160,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/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor deleted file mode 100644 index 8368afeb19..0000000000 --- a/core/compiler/errors/errors-docs.factor +++ /dev/null @@ -1,52 +0,0 @@ -IN: compiler.errors -USING: help.markup help.syntax vocabs.loader words io -quotations words.symbol ; - -ARTICLE: "compiler-errors" "Compiler warnings and errors" -"After loading a vocabulary, you might see messages like:" -{ $code - ":errors - print 2 compiler errors." - ":warnings - print 50 compiler warnings." -} -"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations." -$nl -"The precise warning and error conditions are documented in " { $link "inference-errors" } "." -$nl -"Words to view warnings and errors:" -{ $subsection :errors } -{ $subsection :warnings } -{ $subsection :linkage } -"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:" -{ $subsection with-compiler-errors } ; - -HELP: compiler-errors -{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ; - -ABOUT: "compiler-errors" - -HELP: compiler-error -{ $values { "error" "an error" } { "word" word } } -{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ; - -HELP: compiler-error. -{ $values { "error" "an error" } { "word" word } } -{ $description "Prints a compiler error to " { $link output-stream } "." } ; - -HELP: compiler-errors. -{ $values { "type" symbol } } -{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ; -HELP: :errors -{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; - -HELP: :warnings -{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; - -HELP: :linkage -{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; - -{ :errors :warnings } related-words - -HELP: with-compiler-errors -{ $values { "quot" quotation } } -{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." } -{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ; diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor deleted file mode 100644 index 1ea497c3fc..0000000000 --- a/core/compiler/errors/errors.factor +++ /dev/null @@ -1,67 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces make assocs io sequences -sorting continuations math math.parser ; -IN: compiler.errors - -SYMBOL: +error+ -SYMBOL: +warning+ -SYMBOL: +linkage+ - -GENERIC: compiler-error-type ( error -- ? ) - -M: object compiler-error-type drop +error+ ; - -GENERIC# compiler-error. 1 ( error word -- ) - -SYMBOL: compiler-errors - -SYMBOL: with-compiler-errors? - -: errors-of-type ( type -- assoc ) - compiler-errors get-global - swap [ [ nip compiler-error-type ] dip eq? ] curry - assoc-filter ; - -: compiler-errors. ( type -- ) - errors-of-type >alist sort-keys - [ swap compiler-error. ] assoc-each ; - -: (compiler-report) ( what type word -- ) - over errors-of-type assoc-empty? [ 3drop ] [ - [ - ":" % - % - " - print " % - errors-of-type assoc-size # - " " % - % - "." % - ] "" make print - ] if ; - -: compiler-report ( -- ) - "semantic errors" +error+ "errors" (compiler-report) - "semantic warnings" +warning+ "warnings" (compiler-report) - "linkage errors" +linkage+ "linkage" (compiler-report) ; - -: :errors ( -- ) +error+ compiler-errors. ; - -: :warnings ( -- ) +warning+ compiler-errors. ; - -: :linkage ( -- ) +linkage+ compiler-errors. ; - -: compiler-error ( error word -- ) - with-compiler-errors? get [ - compiler-errors get pick - [ set-at ] [ delete-at drop ] if - ] [ 2drop ] if ; - -: with-compiler-errors ( quot -- ) - with-compiler-errors? get "quiet" get or [ call ] [ - [ - with-compiler-errors? on - V{ } clone compiler-errors set-global - [ compiler-report ] [ ] cleanup - ] with-scope - ] if ; inline diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor index bf3b4a7171..94a95ac9c3 100644 --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -60,8 +60,8 @@ HELP: modify-code-heap ( alist -- ) { $values { "alist" "an alist" } } { $description "Stores compiled code definitions in the code heap. The alist maps words to the following:" { $list - { { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." } - { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." } + { "a quotation - in this case, the quotation is compiled with the non-optimizing compiler and the word will call the quotation when executed." } + { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data and the word will call the code block when executed." } } } { $notes "This word is called at the end of " { $link with-compilation-unit } "." } ; diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index d84b377f36..8dce12f411 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -1,6 +1,6 @@ +USING: compiler definitions compiler.units tools.test arrays sequences words kernel +accessors namespaces fry eval ; IN: compiler.units.tests -USING: definitions compiler.units tools.test arrays sequences words kernel -accessors namespaces fry ; [ [ [ ] define-temp ] with-compilation-unit ] must-infer [ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer @@ -14,11 +14,13 @@ accessors namespaces fry ; ! Non-optimizing compiler bugs [ 1 1 ] [ - "A" "B" [ [ 1 ] dip ] >>def dup f 2array 1array modify-code-heap + "A" "B" [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep 1 swap execute ] unit-test [ "A" "B" ] [ + disable-optimizer + gensym "a" set gensym "b" set [ @@ -30,4 +32,34 @@ accessors namespaces fry ; "a" get [ "B" ] define ] with-compilation-unit "b" get execute -] unit-test \ No newline at end of file + + enable-optimizer +] unit-test + +! Check that we notify observers +SINGLETON: observer + +observer add-definition-observer + +SYMBOL: counter + +0 counter set-global + +M: observer definitions-changed 2drop global [ counter inc ] bind ; + +[ gensym [ ] (( -- )) define-declared ] with-compilation-unit + +[ 1 ] [ counter get-global ] unit-test + +observer remove-definition-observer + +! Notify observers with nested compilation units +observer add-definition-observer + +0 counter set-global + +DEFER: nesting-test + +[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test + +observer remove-definition-observer diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index afa05f9442..f1f9131f08 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -3,7 +3,7 @@ USING: accessors arrays kernel continuations assocs namespaces sequences words vocabs definitions hashtables init sets math math.order classes classes.algebra classes.tuple -classes.tuple.private generic ; +classes.tuple.private generic source-files.errors ; IN: compiler.units SYMBOL: old-definitions @@ -41,7 +41,10 @@ SYMBOL: compiler-impl HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler -M: f recompile [ f ] { } map>assoc ; +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. @@ -58,11 +61,15 @@ 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 ; : remove-definition-observer ( obj -- ) - definition-observers get delete ; + definition-observers get delq ; : notify-definition-observers ( assoc -- ) definition-observers get @@ -132,17 +139,20 @@ GENERIC: definitions-changed ( assoc obj -- ) changed-generics get compiled-generic-usages append assoc-combine keys ; -: unxref-forgotten-definitions ( -- ) - forgotten-definitions get - keys [ word? ] filter - [ delete-compiled-xref ] each ; +: process-forgotten-definitions ( -- ) + forgotten-definitions get keys + [ [ word? ] filter [ delete-compiled-xref ] each ] + [ [ delete-definition-errors ] each ] + bi ; : finish-compilation-unit ( -- ) remake-generics to-recompile recompile update-tuples - unxref-forgotten-definitions - modify-code-heap ; + process-forgotten-definitions + modify-code-heap + updated-definitions dup assoc-empty? + [ drop ] [ notify-definition-observers notify-error-observers ] if ; : with-nested-compilation-unit ( quot -- ) [ @@ -166,9 +176,5 @@ GENERIC: definitions-changed ( assoc obj -- ) H{ } clone new-classes set new-definitions set old-definitions set - [ - finish-compilation-unit - updated-definitions - notify-definition-observers - ] [ ] cleanup + [ finish-compilation-unit ] [ ] cleanup ] with-scope ; inline diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 0627ed5265..2c91981f13 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -30,7 +30,7 @@ $nl { $heading "Anti-pattern #4: Logging and rethrowing" } "If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ; -ARTICLE: "errors" "Error handling" +ARTICLE: "errors" "Exception handling" "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" @@ -81,8 +81,6 @@ $nl { $subsection attempt-all } { $subsection retry } { $subsection with-return } -"Reflecting the datastack:" -{ $subsection with-datastack } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -211,7 +209,7 @@ $low-level-note ; HELP: with-datastack { $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } -{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } +{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $examples { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 34a4ed2879..6409fc588e 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -3,8 +3,8 @@ continuations debugger parser memory arrays words kernel.private accessors eval ; IN: continuations.tests -: (callcc1-test) ( -- ) - [ 1- dup ] dip ?push +: (callcc1-test) ( n obj -- n' obj ) + [ 1 - dup ] dip ?push over 0 = [ "test-cc" get continue-with ] when (callcc1-test) ; @@ -50,21 +50,19 @@ IN: continuations.tests gc ] unit-test -[ f ] [ { } kernel-error? ] unit-test -[ f ] [ { "A" "B" } kernel-error? ] unit-test - ! ! See how well callstack overflow is handled ! [ clear drop ] must-fail ! ! : callstack-overflow callstack-overflow f ; ! [ callstack-overflow ] must-fail -: don't-compile-me ( -- ) { } [ ] each ; - -: foo ( -- ) callstack "c" set 3 don't-compile-me ; +: don't-compile-me ( -- ) ; +: foo ( -- ) callstack "c" set don't-compile-me ; : bar ( -- a b ) 1 foo 2 ; -[ 1 3 2 ] [ bar ] unit-test +<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >> + +[ 1 2 ] [ bar ] unit-test [ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test @@ -107,4 +105,4 @@ SYMBOL: error-counter [ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test -\ with-datastack must-infer +[ with-datastack ] must-infer diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 051d28d8c2..56ac4a71e9 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces make math splitting sorting quotations assocs -combinators combinators.private accessors ; +combinators combinators.private accessors words ; IN: continuations SYMBOL: error @@ -74,12 +74,14 @@ C: continuation continuation< - set-catchstack - set-namestack - set-retainstack - [ set-datastack ] dip - set-callstack ; + [ + >continuation< + set-catchstack + set-namestack + set-retainstack + [ set-datastack ] dip + set-callstack + ] (( continuation -- * )) call-effect-unsafe ; PRIVATE> diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index b53ab28cbc..b1575cc1e4 100644 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -10,21 +10,11 @@ $nl { $subsection set-where } "Definitions can be removed:" { $subsection forget } -"Definitions can answer a sequence of definitions they directly depend on:" -{ $subsection uses } "Definitions must implement a few operations used for printing them in source form:" { $subsection definer } { $subsection definition } { $see-also "see" } ; -ARTICLE: "definition-crossref" "Definition cross referencing" -"A common cross-referencing system is used to track definition usages:" -{ $subsection crossref } -{ $subsection xref } -{ $subsection unxref } -{ $subsection delete-xref } -{ $subsection usage } ; - ARTICLE: "definition-checking" "Definition sanity checking" "When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions." $nl @@ -56,11 +46,23 @@ $nl { $subsection redefine-error } ; ARTICLE: "definitions" "Definitions" -"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, help articles, and path names (which represent the source file at that location). Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary." +"A " { $emphasis "definition" } " is an artifact read from a source file. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary." +$nl +"Definitions are defined using parsing words. Examples of definitions together with their defining parsing words are words (" { $link POSTPONE: : } "), methods (" { $link POSTPONE: M: } "), and vocabularies (" { $link POSTPONE: IN: } ")." +$nl +"All definitions share some common traits:" +{ $list + "There is a word to list all definitions of a given type" + "There is a parsing word for creating new definitions" + "There is an ordinary word which is the runtime equivalent of the parsing word, for introspection" + "Instances of the definition may be introspected and modified with the definition protocol" +} +"For every source file loaded into the system, a list of definitions is maintained. Pathname objects implement the definition protocol, acting over the definitions their source files contain. See " { $link "source-files" } " for details." { $subsection "definition-protocol" } -{ $subsection "definition-crossref" } { $subsection "definition-checking" } { $subsection "compilation-units" } +"A parsing word to remove definitions:" +{ $subsection POSTPONE: FORGET: } { $see-also "see" "parser" "source-files" "words" "generic" "help-impl" } ; ABOUT: "definitions" @@ -83,36 +85,3 @@ HELP: forget-all { $values { "definitions" "a sequence of definition specifiers" } } { $description "Forgets every definition in a sequence." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; - -HELP: uses -{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } -{ $description "Outputs a sequence of definitions directory called by the given definition." } -{ $notes "The sequence might include the definition itself, if it is a recursive word." } -{ $examples - "We can ask the " { $link sq } " word to produce a list of words it calls:" - { $unchecked-example "\ sq uses ." "{ dup * }" } -} ; - -HELP: crossref -{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } "." } ; - -HELP: xref -{ $values { "defspec" "a definition specifier" } } -{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." } -$low-level-note ; - -HELP: usage -{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } } -{ $description "Outputs a sequence of definitions that directly call the given definition." } -{ $notes "The sequence might include the definition itself, if it is a recursive word." } ; - -HELP: unxref -{ $values { "defspec" "a definition specifier" } } -{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." } -{ $notes "This word is called before a word is redefined." } ; - -HELP: delete-xref -{ $values { "defspec" "a definition specifier" } } -{ $description "Remove the vertex which represents the definition from the " { $link crossref } " graph." } -{ $notes "This word is called before a word is forgotten." } -{ $see-also forget } ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index b2d265a2e3..558b259103 100644 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -20,14 +20,11 @@ TUPLE: some-class ; M: some-class some-generic ; -TUPLE: another-class some-generic ; - [ ] [ [ - { - some-generic - some-class - { another-class some-generic } - } forget-all + \ some-generic + \ some-class + 2array + forget-all ] with-compilation-unit ] unit-test diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index c95c5816ac..6f9fdaecf5 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces assocs graphs math math.order ; +USING: kernel sequences namespaces assocs math accessors ; IN: definitions MIXIN: definition @@ -19,9 +19,6 @@ SYMBOL: changed-definitions SYMBOL: changed-effects -: changed-effect ( word -- ) - dup changed-effects get set-in-unit ; - SYMBOL: changed-generics SYMBOL: outdated-generics @@ -42,7 +39,9 @@ GENERIC: set-where ( loc defspec -- ) GENERIC: forget* ( defspec -- ) -M: object forget* drop ; +M: f forget* drop ; + +M: wrapper forget* wrapped>> forget* ; SYMBOL: forgotten-definitions @@ -53,34 +52,6 @@ SYMBOL: forgotten-definitions : forget-all ( definitions -- ) [ forget ] each ; -GENERIC: synopsis* ( defspec -- ) - GENERIC: definer ( defspec -- start end ) GENERIC: definition ( defspec -- seq ) - -SYMBOL: crossref - -GENERIC: uses ( defspec -- seq ) - -M: object uses drop f ; - -: xref ( defspec -- ) dup uses crossref get add-vertex ; - -: usage ( defspec -- seq ) crossref get at keys ; - -GENERIC: irrelevant? ( defspec -- ? ) - -M: object irrelevant? drop f ; - -GENERIC: smart-usage ( defspec -- seq ) - -M: f smart-usage drop \ f smart-usage ; - -M: object smart-usage usage [ irrelevant? not ] filter ; - -: unxref ( defspec -- ) - dup uses crossref get remove-vertex ; - -: delete-xref ( defspec -- ) - dup unxref crossref get delete-at ; diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index b209dcf259..38b8ab4dad 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -1,16 +1,20 @@ -USING: help.markup help.syntax math strings words kernel ; +USING: help.markup help.syntax math strings words kernel combinators ; IN: effects -ARTICLE: "effect-declaration" "Stack effect declaration" -"Stack effects of words must be declared, with the exception of words which only push literals on the stack." -$nl -"A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Here is an example:" -{ $synopsis sq } +ARTICLE: "effects" "Stack effect declarations" +"Word definition words such as " { $link POSTPONE: : } " and " { $link POSTPONE: GENERIC: } " have a " { $emphasis "stack effect declaration" } " as part of their syntax. A stack effect declaration takes the following form:" +{ $code "( input1 input2 ... -- output1 ... )" } +"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Here is an example:" +{ $synopsis + } "Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration:" { $synopsis while } -"Stack effect declarations are read in using a parsing word:" -{ $subsection POSTPONE: ( } -"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Each value can be named by a data type or description. The following are some examples of value names:" +"Only the number of inputs and outputs carries semantic meaning." +$nl +"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. See " { $link "inference-recursive-combinators" } "." +$nl +"In concatenative code, input and output names are for documentation purposes only and certain conventions have been established to make them more descriptive. For code written with " { $link "locals" } ", stack values are bound to local variables named by the stack effect's input parameters." +$nl +"Inputs and outputs are typically named after some pun on their data type, or a description of the value's purpose if the type is very general. The following are some examples of value names:" { $table { { { $snippet "?" } } "a boolean" } { { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } } @@ -26,25 +30,6 @@ $nl { { $snippet "dim" } "a screen dimension specified as a two-element array holding width and height values" } { { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" } } -"The stack effect inferencer verifies stack effect comments to ensure the correct number of inputs and outputs is listed. Value names are ignored; only their number matters. An error is thrown if a word's declared stack effect does not match its inferred stack effect. See " { $link "inference" } "." ; - -ARTICLE: "effects" "Stack effects" -"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output." -$nl -"Stack effects of words can be declared." -{ $subsection "effect-declaration" } -"Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary." -{ $subsection effect } -{ $subsection effect? } -"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "." -{ $subsection POSTPONE: (( } -"Getting a word's declared stack effect:" -{ $subsection stack-effect } -"Converting a stack effect to a string form:" -{ $subsection effect>string } -"Comparing effects:" -{ $subsection effect-height } -{ $subsection effect<= } { $see-also "inference" } ; ABOUT: "effects" @@ -57,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 06a8fa87a3..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" @@ -45,8 +46,8 @@ $nl { $subsection make-generic } "Low-level method constructor:" { $subsection } -"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":" -{ $subsection method-spec } +"Methods may be pushed on the stack with a literal syntax:" +{ $subsection POSTPONE: M\ } { $see-also "see" } ; ARTICLE: "method-combination" "Custom method combination" @@ -95,11 +96,11 @@ $nl { $subsection POSTPONE: MATH: } "Method definition:" { $subsection POSTPONE: M: } -"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "." +"Generic words must declare their stack effect in order to compile. See " { $link "effects" } "." { $subsection "method-order" } { $subsection "call-next-method" } -{ $subsection "generic-introspection" } { $subsection "method-combination" } +{ $subsection "generic-introspection" } "Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ; ABOUT: "generic" @@ -119,9 +120,10 @@ HELP: define-generic { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." } { $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ; -HELP: method-spec -{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." } -{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ; +HELP: M\ +{ $syntax "M\\ class generic" } +{ $class-description "Pushes a method on the stack." } +{ $examples { $code "M\\ fixnum + see" } { $code "USING: ui.gadgets ui.gadgets.editors ;" "M\\ editor draw-gadget* edit" } } ; HELP: method-body { $class-description "The class of method bodies, which are words with special word properties set." } ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index aadc44833f..a63cab1c5c 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -65,11 +65,11 @@ M: number union-containment drop 2 ; [ 2 ] [ 1.0 union-containment ] unit-test ! Testing recovery from bad method definitions -"IN: generic.tests GENERIC: unhappy ( x -- x )" eval +"IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) [ - "IN: generic.tests M: dictionary unhappy ;" eval + "IN: generic.tests M: dictionary unhappy ;" eval( -- ) ] must-fail -[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test +[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test GENERIC# complex-combination 1 ( a b -- c ) M: string complex-combination drop ; @@ -96,18 +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 - -[ t ] [ { hashtable equal? } method-spec? ] unit-test -[ f ] [ { word = } method-spec? ] unit-test - ! Regression TUPLE: first-one ; TUPLE: second-one ; @@ -136,69 +124,19 @@ M: f tag-and-f 4 ; [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test ! Issues with forget -GENERIC: generic-forget-test-1 ( a b -- c ) +GENERIC: generic-forget-test ( a -- b ) -M: integer generic-forget-test-1 / ; +M: f generic-forget-test ; -[ t ] [ - \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] any? -] unit-test - -[ ] [ - [ \ generic-forget-test-1 forget ] with-compilation-unit -] unit-test - -[ f ] [ - \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] any? -] unit-test - -GENERIC: generic-forget-test-2 ( a b -- c ) - -M: sequence generic-forget-test-2 = ; - -[ t ] [ - \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] any? -] unit-test - -[ ] [ - [ { sequence generic-forget-test-2 } forget ] with-compilation-unit -] unit-test - -[ f ] [ - \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] any? -] unit-test - -GENERIC: generic-forget-test-3 ( a -- b ) - -M: f generic-forget-test-3 ; - -[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test +[ ] [ \ f \ generic-forget-test method "m" set ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test +[ ] [ "IN: generic.tests M: f generic-forget-test ;" eval( -- ) ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ f ] [ f generic-forget-test-3 ] unit-test - -: a-word ( -- ) ; - -GENERIC: a-generic ( a -- b ) - -M: integer a-generic a-word ; - -[ ] [ \ integer \ a-generic method "m" set ] unit-test - -[ t ] [ "m" get \ a-word usage memq? ] unit-test - -[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test - -[ f ] [ "m" get \ a-word usage memq? ] unit-test +[ f ] [ f generic-forget-test ] unit-test ! erg's regression [ ] [ @@ -210,31 +148,31 @@ M: integer a-generic a-word ; M: boii jeah ; GENERIC: jeah* ( a -- b ) M: boii jeah* jeah ; - "> eval + "> eval( -- ) <" IN: compiler.tests FORGET: boii - "> eval + "> eval( -- ) <" IN: compiler.tests TUPLE: boii ; M: boii jeah ; - "> eval + "> eval( -- ) ] unit-test ! call-next-method cache test GENERIC: c-n-m-cache ( a -- b ) ! Force it to be unoptimized -M: fixnum c-n-m-cache { } [ ] like call call-next-method ; +M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ; M: integer c-n-m-cache 1 + ; M: number c-n-m-cache ; [ 3 ] [ 2 c-n-m-cache ] unit-test -[ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test +[ ] [ [ M\ integer c-n-m-cache forget ] with-compilation-unit ] unit-test [ 2 ] [ 2 c-n-m-cache ] unit-test @@ -247,4 +185,4 @@ GENERIC: move-method-generic ( a -- b ) [ ] [ "IN: generic.tests.a" "move-method-test-1" parse-stream drop ] unit-test -[ { string } ] [ \ move-method-generic order ] unit-test \ No newline at end of file +[ { string } ] [ \ move-method-generic order ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index c22641d439..4b398f6532 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -24,11 +24,6 @@ M: generic definition drop f ; : method ( class generic -- method/f ) "methods" word-prop at ; -PREDICATE: method-spec < pair - first2 generic? swap class? and ; - -INSTANCE: method-spec definition - : order ( generic -- seq ) "methods" word-prop keys sort-classes ; @@ -38,6 +33,8 @@ INSTANCE: method-spec definition GENERIC: effective-method ( generic -- method ) +\ effective-method t "no-compile" set-word-prop + : next-method-class ( class generic -- class/f ) order [ class<= ] with filter reverse dup length 1 = [ drop f ] [ second ] if ; @@ -90,9 +87,6 @@ TUPLE: check-method class generic ; PREDICATE: method-body < word "method-generic" word-prop >boolean ; -M: method-spec stack-effect - first2 method stack-effect ; - M: method-body stack-effect "method-generic" word-prop stack-effect ; @@ -129,8 +123,6 @@ M: method-body crossref? PREDICATE: default-method < word "default" word-prop ; -M: default-method irrelevant? drop t ; - : ( generic combination -- method ) [ drop object bootstrap-word swap ] [ make-default-method ] 2bi [ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ; @@ -139,24 +131,6 @@ M: default-method irrelevant? drop t ; dupd "default-method" set-word-prop ; ! Definition protocol -M: method-spec where - dup first2 method [ ] [ second ] ?if where ; - -M: method-spec set-where - first2 method set-where ; - -M: method-spec definer - first2 method definer ; - -M: method-spec definition - first2 method definition ; - -M: method-spec forget* - first2 method [ forgotten-definition ] [ forget* ] bi ; - -M: method-spec smart-usage - second smart-usage ; - M: method-body definer drop \ M: \ ; ; @@ -179,9 +153,6 @@ M: method-body forget* [ call-next-method ] bi ] if ; -M: method-body smart-usage - "method-generic" word-prop smart-usage ; - M: sequence update-methods ( class seq -- ) implementors [ [ changed-generic ] [ remake-generic drop ] 2bi @@ -193,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 ] } @@ -214,5 +185,5 @@ M: generic subwords M: generic forget* [ subwords forget-all ] [ call-next-method ] bi ; -: xref-generics ( -- ) - all-words [ subwords [ xref ] each ] each ; +M: class forget-methods + [ implementors ] [ [ swap method ] curry ] bi map forget-all ; 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..fe5b62f6c0 --- /dev/null +++ b/core/generic/hook/hook.factor @@ -0,0 +1,28 @@ +! 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 inline-cache-quot 2drop f ; + +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 4323f91bc3..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 @@ -15,7 +15,7 @@ HELP: no-math-method HELP: math-method { $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } } { $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." } -{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ { fixnum float } declare [ >float ] dip float=>+ ]" } } ; +{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ { fixnum float } declare [ >float ] dip M\\ float + ]" } } ; HELP: math-class { $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ; 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 82% rename from core/generic/standard/standard-tests.factor rename to core/generic/single/single-tests.factor index a6269135f4..c8cab970fd 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' ) @@ -66,7 +65,7 @@ M: circle area radius>> sq pi * ; GENERIC: perimiter ( shape -- n ) -: rectangle-perimiter ( n -- n ) + 2 * ; +: rectangle-perimiter ( l w -- n ) + 2 * ; M: rectangle perimiter [ width>> ] [ height>> ] bi @@ -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" ; @@ -280,31 +262,16 @@ M: growable call-next-hooker call-next-method "growable " prepend ; V{ } my-var [ call-next-hooker ] with-variable ] unit-test -! Cross-referencing with generic words -TUPLE: xref-tuple-1 ; -TUPLE: xref-tuple-2 < xref-tuple-1 ; - -: (xref-test) ( obj -- ) drop ; - -GENERIC: xref-test ( obj -- ) - -M: xref-tuple-1 xref-test (xref-test) ; -M: xref-tuple-2 xref-test (xref-test) ; - [ t ] [ - \ xref-test - \ xref-tuple-1 \ xref-test method [ usage unique ] closure key? -] unit-test - -[ t ] [ - \ xref-test - \ xref-tuple-2 \ xref-test method [ usage unique ] closure key? -] 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 direct-entry-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..d8fa04edd6 --- /dev/null +++ b/core/generic/single/single.factor @@ -0,0 +1,256 @@ +! 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 >array ] 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-quot combination ( word methods -- quot/f ) + +: define-inline-cache-quot ( word methods -- ) + [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def 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 c88bd9d97e..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 crossref? "forgotten" word-prop not ; - -M: engine-word irrelevant? drop t ; - -: 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..87611a76d0 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,180 +1,57 @@ -! 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 ; IN: generic.standard -GENERIC: dispatch# ( word -- n ) +TUPLE: standard-combination < single-combination # ; -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 # ; - -C: standard-combination +: ( n -- standard-combination ) + dup 0 2 between? [ "Bad dispatch position" throw ] unless + standard-combination boa ; 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 ; +M: standard-combination inline-cache-quot ( word methods -- ) + #! 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. + combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ; -C: hook-combination +: make-empty-cache ( -- array ) + mega-cache-size get f ; -PREDICATE: hook-generic < generic - "combination" word-prop hook-combination? ; - -: 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 ] 3curry [ ] like ; 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..0914134bb6 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) ; @@ -139,7 +139,7 @@ M: hashtable set-at ( value key hash -- ) PRIVATE> M: hashtable >alist - [ array>> [ length 2/ ] keep ] [ assoc-size ] bi [ + [ array>> [ length 2/ iota ] keep ] [ assoc-size ] bi [ [ [ [ 1 fixnum-shift-fast ] dip 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/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index 204441c19a..d0f968a791 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -80,12 +80,12 @@ ARTICLE: "encodings-descriptors" "Encoding descriptors" "An encoding descriptor is something which can be used with binary input or output streams to encode or decode bytes stored in a certain representation. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" { $subsection "io.encodings.binary" } { $subsection "io.encodings.utf8" } -{ $subsection "io.encodings.utf16" } +{ $vocab-subsection "UTF-16 encoding" "io.encodings.utf16" } { $vocab-subsection "UTF-32 encoding" "io.encodings.utf32" } { $vocab-subsection "Strict encodings" "io.encodings.strict" } "Legacy encodings:" { $vocab-subsection "8-bit encodings" "io.encodings.8-bit" } -{ $vocab-subsection "ASCII" "io.encodings.ascii" } +{ $vocab-subsection "ASCII encoding" "io.encodings.ascii" } { $see-also "encodings-introduction" } ; ARTICLE: "encodings-protocol" "Encoding protocol" diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 696de9af69..174816dd34 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -130,7 +130,9 @@ M: encoder stream-element-type M: encoder stream-write1 >encoder< encode-char ; -: encoder-write ( string stream encoding -- ) +GENERIC# encoder-write 2 ( string stream encoding -- ) + +M: string encoder-write [ encode-char ] 2curry each ; M: encoder stream-write 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/core/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor new file mode 100644 index 0000000000..e16c1f822e --- /dev/null +++ b/core/io/encodings/utf16/utf16-tests.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test io.encodings.utf16 arrays sbufs +io.streams.byte-array sequences io.encodings io strings +io.encodings.string alien.c-types alien.strings accessors classes ; +IN: io.encodings.utf16.tests + +[ { CHAR: x } ] [ B{ 0 CHAR: x } utf16be decode >array ] unit-test +[ { HEX: 1D11E } ] [ B{ HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test +[ { CHAR: replacement-character } ] [ B{ BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test + +[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } >string utf16be encode >array ] unit-test + +[ { CHAR: x } ] [ B{ CHAR: x 0 } utf16le decode >array ] unit-test +[ { 119070 } ] [ B{ HEX: 34 HEX: D8 HEX: 1E HEX: DD } >string utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } >string utf16le decode >array ] unit-test +[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } >string utf16le decode >array ] unit-test + +[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16le encode >array ] unit-test + +[ { CHAR: x } ] [ B{ HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test +[ { CHAR: x } ] [ B{ HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test + +[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16 encode >array ] unit-test 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/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor index 6cd3ee8033..088131acf9 100755 --- a/core/io/encodings/utf8/utf8-tests.factor +++ b/core/io/encodings/utf8/utf8-tests.factor @@ -6,7 +6,7 @@ IN: io.encodings.utf8.tests utf8 decode >array ; : encode-utf8-w/stream ( array -- newarray ) - utf8 encode >array ; + >string utf8 encode >array ; [ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index cf0aea787b..9989d889a8 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -2,7 +2,20 @@ USING: help.markup help.syntax io strings arrays io.backend io.files.private quotations sequences ; IN: io.files +ARTICLE: "io.files.examples" "Examples of reading and writing files" +"Sort the lines in a file and write them back to the same file:" +{ $code + "USING: io io.encodings.utf8 io.files sequences sorting ;" + "\"lines.txt\" utf8 [ file-lines natural-sort ] 2keep set-file-lines" +} +"Read 1024 bytes from a file:" +{ $code + "USING: io io.encodings.binary io.files ;" + "\"data.bin\" binary [ 1024 read ] with-file-reader" +} ; + ARTICLE: "io.files" "Reading and writing files" +{ $subsection "io.files.examples" } "File streams:" { $subsection } { $subsection } diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index ce15a69773..f57dafbdc6 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,12 +1,9 @@ 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 ; +make math sequences system threads tools.test generic.single ; IN: io.files.tests -\ exists? must-infer -\ (exists?) must-infer - [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test [ ] [ "append-test" temp-file ascii dispose ] unit-test @@ -144,3 +141,15 @@ USE: debugger.threads -10 seek-absolute seek-input ] with-file-reader ] must-fail + +[ + "non-string-error" unique-file ascii [ + { } write + ] with-file-writer +] [ no-method? ] must-fail-with + +[ + "non-byte-array-error" unique-file binary [ + "" write + ] with-file-writer +] [ no-method? ] must-fail-with \ No newline at end of file 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 ebc248bbbf..3469a81064 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -221,10 +221,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 +237,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: contents +HELP: stream-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 } "." } +{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." } +$io-error ; + +HELP: contents +{ $values { "seq" "a string, byte array or " { $link f } } } +{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." } $io-error ; ARTICLE: "stream-protocol" "Stream protocol" @@ -347,17 +356,37 @@ $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:" { $subsection stream-copy } ; +ARTICLE: "stream-examples" "Stream example" +"Ask the user for their age, and print it back:" +{ $code + "USING: io math.parser ;" + "" + ": ask-age ( -- ) \"How old are you?\" print ;" + "" + ": read-age ( -- n ) readln string>number ;" + "" + ": print-age ( n -- )" + " \"You are \" write" + " number>string write" + " \" years old.\" print ;" + ": example ( -- ) ask-age read-age print-age ;" + "" + "example" +} ; + ARTICLE: "streams" "Streams" "Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of " { $emphasis "elements" } "." -$nl +{ $subsection "stream-examples" } "A stream can either be passed around on the stack or bound to a dynamic variable and used as one of the two implicit " { $emphasis "default streams" } "." { $subsection "stream-protocol" } { $subsection "stdio" } diff --git a/core/io/io.factor b/core/io/io.factor index 74bba7769e..b43098bcd4 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -68,9 +68,12 @@ SYMBOL: error-stream : bl ( -- ) " " write ; -: lines ( stream -- seq ) +: stream-lines ( stream -- seq ) [ [ readln dup ] [ ] produce nip ] with-input-stream ; +: lines ( -- seq ) + input-stream get stream-lines ; + : each-line ( quot -- ) [ readln ] each-morsel ; inline -: contents ( stream -- seq ) +: stream-contents ( stream -- seq ) [ [ 65536 read-partial dup ] [ ] produce nip concat f like ] with-input-stream ; +: contents ( -- seq ) + input-stream get stream-contents ; + : 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 78% rename from basis/io/streams/byte-array/byte-array-tests.factor rename to core/io/streams/byte-array/byte-array-tests.factor index 44290bfb47..0cd35dfa21 100644 --- a/basis/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -1,12 +1,12 @@ USING: tools.test io.streams.byte-array io.encodings.binary io.encodings.utf8 io kernel arrays strings namespaces ; -[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] 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 } 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 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test +[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 stream-contents dup >array swap string? ] unit-test [ B{ 121 120 } 0 ] [ B{ 0 121 120 0 0 0 0 0 0 } binary @@ -26,4 +26,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 c178573a0a..e67e2bc0dd 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -129,6 +129,9 @@ HELP: ? { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; +HELP: boolean +{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ; + HELP: >boolean { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ; @@ -180,14 +183,30 @@ 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." } +{ $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." } { $examples "The following two lines are equivalent:" { $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" } } ; +{ call POSTPONE: call( } related-words + HELP: call-clear ( quot -- ) { $values { "quot" callable } } { $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." } @@ -841,260 +860,6 @@ $nl { $subsection roll } { $subsection -roll } ; -ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators" -"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "." -$nl -"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:" -{ $code - ": keep [ ] bi ;" - ": 2keep [ ] 2bi ;" - ": 3keep [ ] 3bi ;" - "" - ": dup [ ] [ ] bi ;" - ": 2dup [ ] [ ] 2bi ;" - ": 3dup [ ] [ ] 3bi ;" - "" - ": tuck [ nip ] [ ] 2bi ;" - ": swap [ nip ] [ drop ] 2bi ;" - "" - ": over [ ] [ drop ] 2bi ;" - ": pick [ ] [ 2drop ] 3bi ;" - ": 2over [ ] [ drop ] 3bi ;" -} ; - -ARTICLE: "cleave-combinators" "Cleave combinators" -"The cleave combinators apply multiple quotations to a single value." -$nl -"Two quotations:" -{ $subsection bi } -{ $subsection 2bi } -{ $subsection 3bi } -"Three quotations:" -{ $subsection tri } -{ $subsection 2tri } -{ $subsection 3tri } -"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:" -{ $code - "! First alternative; uses keep" - "[ 1 + ] keep" - "[ 1 - ] keep" - "2 *" - "! Second alternative: uses tri" - "[ 1 + ]" - "[ 1 - ]" - "[ 2 * ] tri" -} -"The latter is more aesthetically pleasing than the former." -$nl -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." -{ $subsection "cleave-shuffle-equivalence" } ; - -ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators" -"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "." -$nl -"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:" -{ $code - ": dip [ ] bi* ;" - ": 2dip [ ] [ ] tri* ;" - "" - ": slip [ call ] [ ] bi* ;" - ": 2slip [ call ] [ ] [ ] tri* ;" - "" - ": nip [ drop ] [ ] bi* ;" - ": 2nip [ drop ] [ drop ] [ ] tri* ;" - "" - ": rot" - " [ [ drop ] [ ] [ drop ] tri* ]" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " 3tri ;" - "" - ": -rot" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " [ [ drop ] [ ] [ drop ] tri* ]" - " 3tri ;" - "" - ": spin" - " [ [ drop ] [ drop ] [ ] tri* ]" - " [ [ drop ] [ ] [ drop ] tri* ]" - " [ [ ] [ drop ] [ drop ] tri* ]" - " 3tri ;" -} ; - -ARTICLE: "spread-combinators" "Spread combinators" -"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading." -$nl -"Two quotations:" -{ $subsection bi* } -{ $subsection 2bi* } -"Three quotations:" -{ $subsection tri* } -{ $subsection 2tri* } -"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:" -{ $code - "! First alternative; uses dip" - "[ [ 1 + ] dip 1 - ] dip 2 *" - "! Second alternative: uses tri*" - "[ 1 + ] [ 1 - ] [ 2 * ] tri*" -} -"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." -{ $subsection "spread-shuffle-equivalence" } ; - -ARTICLE: "apply-combinators" "Apply combinators" -"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application." -$nl -"Two quotations:" -{ $subsection bi@ } -{ $subsection 2bi@ } -"Three quotations:" -{ $subsection tri@ } -{ $subsection 2tri@ } -"A pair of utility words built from " { $link bi@ } ":" -{ $subsection both? } -{ $subsection either? } ; - -ARTICLE: "slip-keep-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:" -{ $subsection dip } -{ $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 } -{ $subsection 3keep } ; - -ARTICLE: "curried-dataflow" "Curried dataflow combinators" -"Curried cleave combinators:" -{ $subsection bi-curry } -{ $subsection tri-curry } -"Curried spread combinators:" -{ $subsection bi-curry* } -{ $subsection tri-curry* } -"Curried apply combinators:" -{ $subsection bi-curry@ } -{ $subsection tri-curry@ } -{ $see-also "dataflow-combinators" } ; - -ARTICLE: "compositional-examples" "Examples of compositional combinator usage" -"Consider printing the same message ten times:" -{ $code ": print-10 ( -- ) 10 [ \"Hello, world.\" print ] times ;" } -"if we wanted to abstract out the message into a parameter, we could keep it on the stack between iterations:" -{ $code ": print-10 ( message -- ) 10 [ dup print ] times drop ;" } -"However, keeping loop-invariant values on the stack doesn't always work out nicely. For example, a word to subtract a value from each element of a sequence:" -{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" } -"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":" -{ $example - "USING: kernel math prettyprint sequences ;" - ": subtract-n ( seq n -- seq' ) [ - ] curry map ;" - "{ 10 20 30 } 5 subtract-n ." - "{ 5 15 25 }" -} -"Now consider the word that is dual to the one above; instead of subtracting " { $snippet "n" } " from each stack element, it subtracts each element from " { $snippet "n" } "." -$nl -"One way to write this is with a pair of " { $link swap } "s:" -{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" } -"Since this pattern comes up often, " { $link with } " encapsulates it:" -{ $example - "USING: kernel math prettyprint sequences ;" - ": n-subtract ( n seq -- seq' ) [ - ] with map ;" - "30 { 10 20 30 } n-subtract ." - "{ 20 10 0 }" -} -{ $see-also "fry.examples" } ; - -ARTICLE: "compositional-combinators" "Compositional combinators" -"Certain combinators transform quotations to produce a new quotation." -{ $subsection "compositional-examples" } -"Fundamental operations:" -{ $subsection curry } -{ $subsection compose } -"Derived operations:" -{ $subsection 2curry } -{ $subsection 3curry } -{ $subsection with } -{ $subsection prepose } -"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words." -$nl -"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways." -{ $subsection "curried-dataflow" } -"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ; - -ARTICLE: "implementing-combinators" "Implementing combinators" -"The following pair of words invoke words and quotations reflectively:" -{ $subsection call } -{ $subsection execute } -"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:" -{ $code - ": keep ( x quot -- x )" - " over [ call ] dip ; inline" -} -"Word inlining is documented in " { $link "declarations" } "." ; - -ARTICLE: "booleans" "Booleans" -"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." -{ $subsection f } -{ $subsection t } -"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing." -$nl -"Here is the " { $link f } " object:" -{ $example "f ." "f" } -"Here is the " { $link f } " class:" -{ $example "\\ f ." "POSTPONE: f" } -"They are not equal:" -{ $example "f \\ f = ." "f" } -"Here is an array containing the " { $link f } " object:" -{ $example "{ f } ." "{ f }" } -"Here is an array containing the " { $link f } " class:" -{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" } -"The " { $link f } " object is an instance of the " { $link f } " class:" -{ $example "USE: classes" "f class ." "POSTPONE: f" } -"The " { $link f } " class is an instance of " { $link word } ":" -{ $example "USE: classes" "\\ f class ." "word" } -"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of." -{ $example "t \\ t eq? ." "t" } -"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; - -ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic" -"Certain simple conditional forms can be expressed in a simpler manner using boolean logic." -$nl -"The following two lines are equivalent:" -{ $code "[ drop f ] unless" "swap and" } -"The following two lines are equivalent:" -{ $code "[ ] [ ] ?if" "swap or" } -"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" -{ $code "[ L ] unless*" "L or" } ; - -ARTICLE: "conditionals" "Conditionals and logic" -"The basic conditionals:" -{ $subsection if } -{ $subsection when } -{ $subsection unless } -"Forms abstracting a common stack shuffle pattern:" -{ $subsection if* } -{ $subsection when* } -{ $subsection unless* } -"Another form abstracting a common stack shuffle pattern:" -{ $subsection ?if } -"Sometimes instead of branching, you just need to pick one of two values:" -{ $subsection ? } -"There are some logical operations on booleans:" -{ $subsection >boolean } -{ $subsection not } -{ $subsection and } -{ $subsection or } -{ $subsection xor } -{ $subsection "conditionals-boolean-equivalence" } -"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches." -{ $see-also "booleans" "bitwise-arithmetic" both? either? } ; - ARTICLE: "equality" "Equality" "There are two distinct notions of “sameness” when it comes to objects." $nl @@ -1116,34 +881,3 @@ ARTICLE: "assertions" "Assertions" { $subsection assert } { $subsection assert= } ; -ARTICLE: "dataflow-combinators" "Data flow combinators" -"Data flow combinators pass values between quotations:" -{ $subsection "slip-keep-combinators" } -{ $subsection "cleave-combinators" } -{ $subsection "spread-combinators" } -{ $subsection "apply-combinators" } -{ $see-also "curried-dataflow" } ; - -ARTICLE: "dataflow" "Data and control flow" -{ $subsection "evaluator" } -{ $subsection "words" } -{ $subsection "effects" } -{ $subsection "booleans" } -{ $subsection "shuffle-words" } -"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." -{ $subsection "dataflow-combinators" } -{ $subsection "conditionals" } -{ $subsection "looping-combinators" } -{ $subsection "compositional-combinators" } -{ $subsection "combinators" } -"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." -$nl -"Advanced topics:" -{ $subsection "assertions" } -{ $subsection "implementing-combinators" } -{ $subsection "macros" } -{ $subsection "errors" } -{ $subsection "continuations" } ; - -ABOUT: "dataflow" - diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 63346f4701..5a88db4f9e 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs -sequences.private accessors locals.backend grouping ; +sequences.private accessors locals.backend grouping words ; IN: kernel.tests [ 0 ] [ f size ] unit-test @@ -23,20 +23,25 @@ IN: kernel.tests : overflow-d ( -- ) 3 overflow-d ; +: (overflow-d-alt) ( -- n ) 3 ; + +: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; + +: overflow-r ( -- ) 3 load-local overflow-r ; + +<< +{ overflow-d (overflow-d-alt) overflow-d-alt overflow-r } +[ t "no-compile" set-word-prop ] each +>> + [ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ :c ] unit-test -: (overflow-d-alt) ( -- ) 3 ; - -: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; - [ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] with-string-writer drop ] unit-test -: overflow-r ( -- ) 3 load-local overflow-r ; - [ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -99,7 +104,9 @@ IN: kernel.tests [ ] [ :c ] unit-test ! Doesn't compile; important -: foo ( a -- b ) 5 + 0 [ ] each ; +: foo ( a -- b ) ; + +<< \ foo t "no-compile" set-word-prop >> [ drop foo ] must-fail [ ] [ :c ] unit-test @@ -107,15 +114,15 @@ IN: kernel.tests ! Regression : (loop) ( a b c d -- ) [ pick ] dip swap [ pick ] dip swap - < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline + < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive -: loop ( obj obj -- ) +: loop ( obj -- ) H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; [ loop ] must-fail ! Discovered on Windows -: total-failure-1 ( -- ) "" [ ] map unimplemented ; +: total-failure-1 ( -- a ) "" [ ] map unimplemented ; [ total-failure-1 ] must-fail @@ -168,4 +175,4 @@ IN: kernel.tests [ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test -[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test \ No newline at end of file +[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index baccf56059..6245080225 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -176,12 +176,14 @@ PRIVATE> : tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline ! Booleans +UNION: boolean POSTPONE: t POSTPONE: f ; + +: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline + : not ( obj -- ? ) [ f ] [ t ] if ; inline : and ( obj1 obj2 -- ? ) over ? ; inline -: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline - : or ( obj1 obj2 -- ? ) dupd ? ; inline : xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; 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 27cc510ea2..097e2c14aa 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -50,14 +50,12 @@ 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 -! [ f ] [ 0.0/0.0 0.0/0.0 number= ] unit-test - [ 0 ] [ 1/0. >bignum ] unit-test [ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] 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 e88caa7703..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 @@ -122,11 +122,11 @@ M: bignum (log2) bignum-log2 ; 2drop 0.0 ] [ dup zero? [ - 2drop 1.0/0.0 + 2drop 1/0. ] [ 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 f79dcb5481..c28bf062c1 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -355,8 +355,9 @@ ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic" { $subsection 2/ } { $subsection 2^ } { $subsection bit? } -"The " { $vocab-link "math.bitwise" } " vocabulary implements additional bitwise integer operations." -{ $see-also "conditionals" } ; +{ $subsection "math.bitwise" } +{ $subsection "math.bits" } +{ $see-also "booleans" } ; ARTICLE: "arithmetic" "Arithmetic" "Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers." diff --git a/core/math/math.factor b/core/math/math.factor index 42786ffc9d..8e0000326f 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,23 +63,22 @@ 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 -- ? ) @@ -104,13 +103,13 @@ M: float fp-infinity? ( float -- ? ) ] if ; : 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 +160,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/order/order-docs.factor b/core/math/order/order-docs.factor index 1bdd1009e9..8b2200aa67 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -87,7 +87,14 @@ ARTICLE: "order-specifiers" "Ordering specifiers" { $subsection +lt+ } { $subsection +eq+ } { $subsection +gt+ } ; - + +ARTICLE: "math.order.example" "Linear order example" +"A tuple class which defines an ordering among instances by comparing the values of the " { $snippet "id" } " slot:" +{ $code + "TUPLE: sprite id name bitmap ;" + "M: sprite <=> [ id>> ] compare ;" +} ; + ARTICLE: "math.order" "Linear order protocol" "Some classes have an intrinsic order amongst instances:" { $subsection <=> } @@ -101,6 +108,8 @@ ARTICLE: "math.order" "Linear order protocol" { $subsection before? } { $subsection after=? } { $subsection before=? } +"Out of the above generic words, it suffices to implement " { $link <=> } " alone. The others may be provided as an optimization." +{ $subsection "math.order.example" } { $see-also "sequences-sorting" } ; ABOUT: "math.order" diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index bcc75a842a..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 @@ -25,7 +25,7 @@ $nl ABOUT: "number-strings" HELP: digits>integer -{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } } +{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n/f" { $maybe integer } } } { $description "Converts a sequence of digits (with most significant digit first) into an integer." } { $notes "This is one of the factors of " { $link string>number } "." } ; @@ -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-tests.factor b/core/math/parser/parser-tests.factor index 0fb2559854..c655965e35 100644 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -95,17 +95,17 @@ unit-test [ 1 0 >base ] must-fail [ 1 -1 >base ] must-fail -[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test +[ "0/0." ] [ 0.0 0.0 / number>string ] unit-test -[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test +[ "1/0." ] [ 1.0 0.0 / number>string ] unit-test -[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test +[ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test [ t ] [ "0/0." string>number fp-nan? ] unit-test -[ 1.0/0.0 ] [ "1/0." string>number ] unit-test +[ 1/0. ] [ "1/0." string>number ] unit-test -[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test +[ -1/0. ] [ "-1/0." string>number ] unit-test [ "-0.0" ] [ -0.0 number>string ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 0d8f0c0b08..437308d53f 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.private namespaces sequences strings -arrays combinators splitting math assocs make ; +USING: kernel math.private namespaces sequences sequences.private +strings arrays combinators splitting math assocs byte-arrays make ; IN: math.parser : digit> ( ch -- n ) @@ -28,13 +28,19 @@ IN: math.parser { CHAR: d 13 } { CHAR: e 14 } { CHAR: f 15 } - } at ; + } at 255 or ; inline : string>digits ( str -- digits ) - [ digit> ] { } map-as ; + [ digit> ] B{ } map-as ; inline -: digits>integer ( seq radix -- n ) - 0 swap [ swapd * + ] curry reduce ; +: (digits>integer) ( valid? accum digit radix -- valid? accum ) + 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline + +: each-digit ( seq radix quot -- n/f ) + [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline + +: digits>integer ( seq radix -- n/f ) + [ (digits>integer) ] each-digit ; inline DEFER: base> @@ -43,6 +49,11 @@ DEFER: base> SYMBOL: radix SYMBOL: negative? +: string>natural ( seq radix -- n/f ) + over empty? [ 2drop f ] [ + [ [ digit> ] dip (digits>integer) ] each-digit + ] if ; inline + : sign ( -- str ) negative? get "-" "+" ? ; : with-radix ( radix quot -- ) @@ -54,37 +65,33 @@ SYMBOL: negative? sign split1 [ (base>) ] dip dup [ (base>) ] [ drop 0 swap ] if ; -: string>ratio ( str -- a/b ) - "-" ?head dup negative? set swap - "/" split1 (base>) [ whole-part ] dip - 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ; +: string>ratio ( str radix -- a/b ) + [ + "-" ?head dup negative? set swap + "/" split1 (base>) [ whole-part ] dip + 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if + ] with-radix ; -: valid-digits? ( seq -- ? ) - { - { [ dup empty? ] [ drop f ] } - { [ f over memq? ] [ drop f ] } - [ radix get [ < ] curry all? ] - } cond ; +: string>integer ( str radix -- n/f ) + over first-unsafe CHAR: - = [ + [ rest-slice ] dip string>natural dup [ neg ] when + ] [ + string>natural + ] if ; inline -: string>integer ( str -- n/f ) - "-" ?head swap - string>digits dup valid-digits? - [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ; +: string>float ( str -- n/f ) + >byte-array 0 suffix (string>float) ; PRIVATE> : base> ( str radix -- n/f ) - [ - CHAR: / over member? [ - string>ratio - ] [ - CHAR: . over member? [ - string>float - ] [ - string>integer - ] if - ] if - ] with-radix ; + over empty? [ 2drop f ] [ + over [ "/." member? ] find nip { + { CHAR: / [ string>ratio ] } + { CHAR: . [ drop string>float ] } + [ drop string>integer ] + } case + ] if ; : string>number ( str -- n/f ) 10 base> ; : bin> ( str -- n/f ) 2 base> ; @@ -145,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/0.0" ] } - { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] } - { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] } + { [ 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-tests.factor b/core/memory/memory-tests.factor index 995c7e6064..a6ecdc005e 100644 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -3,6 +3,8 @@ sequences tools.test words namespaces layouts classes classes.builtin arrays quotations io.launcher system ; IN: memory.tests +[ ] [ { } { } become ] unit-test + ! LOL [ ] [ vm @@ -15,7 +17,7 @@ IN: memory.tests [ [ ] instances ] must-infer ! Code GC wasn't kicking in when needed -: leak-step ( -- ) 800000 f 1quotation call drop ; +: leak-step ( -- ) 800000 f 1quotation call( -- obj ) drop ; : leak-loop ( -- ) 100 [ leak-step ] times ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 4b873ef6ec..c748f71c8e 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) ; + : 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 ff0542a7b8..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 } @@ -32,7 +33,7 @@ ARTICLE: "namespaces.private" "Namespace implementation details" { $subsection >n } { $subsection ndrop } ; -ARTICLE: "namespaces" "Variables and namespaces" +ARTICLE: "namespaces" "Dynamic variables and namespaces" "The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables." $nl "A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "words.symbol" } ")." @@ -43,7 +44,6 @@ $nl "Various utility words abstract away common variable access patterns:" { $subsection "namespaces-change" } { $subsection "namespaces-combinators" } -{ $subsection "namespaces-global" } "Implementation details your code probably does not care about:" { $subsection "namespaces.private" } "An alternative to dynamic scope is lexical scope. Lexically-scoped values and closures are implemented in the " { $vocab-link "locals" } " vocabulary." ; @@ -74,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." } @@ -114,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 @@ -151,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-docs.factor b/core/parser/parser-docs.factor index 547f7c0490..98f41ae39a 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -92,15 +92,12 @@ ARTICLE: "parser" "The parser" "This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies." $nl "This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "." -{ $subsection "vocabulary-search" } { $subsection "parser-files" } -{ $subsection "top-level-forms" } "The parser can be extended." -{ $subsection "parsing-words" } { $subsection "parser-lexer" } "The parser can be invoked reflectively;" { $subsection parse-stream } -{ $see-also "definitions" "definition-checking" } ; +{ $see-also "parsing-words" "definitions" "definition-checking" } ; ABOUT: "parser" @@ -113,7 +110,7 @@ HELP: save-location { $description "Saves the location of a definition and associates this definition with the current source file." } ; HELP: parser-notes -{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ; +{ $var-description "A boolean controlling whether the parser will print various notes. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ; HELP: parser-notes? { $values { "?" "a boolean" } } @@ -263,7 +260,7 @@ HELP: forget-smudged HELP: finish-parsing { $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } } -{ $description "Records information to the current " { $link file } " and prints warnings about any removed definitions which are still in use." } +{ $description "Records information to the current " { $link file } "." } { $notes "This is one of the factors of " { $link parse-stream } "." } ; HELP: parse-stream diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 3ba414fe6b..e944ecc6f2 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -3,50 +3,49 @@ io.streams.string namespaces classes effects source-files assocs sequences strings io.files io.pathnames definitions continuations sorting classes.tuple compiler.units debugger vocabs vocabs.loader accessors eval combinators lexer -vocabs.parser words.symbol multiline ; +vocabs.parser words.symbol multiline source-files.errors +tools.crossref ; IN: parser.tests -\ run-file must-infer - [ [ 1 [ 2 [ 3 ] 4 ] 5 ] - [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ] + [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ] unit-test [ t t f f ] - [ "t t f f" eval ] + [ "t t f f" eval( -- ? ? ? ? ) ] unit-test [ "hello world" ] - [ "\"hello world\"" eval ] + [ "\"hello world\"" eval( -- string ) ] unit-test [ "\n\r\t\\" ] - [ "\"\\n\\r\\t\\\\\"" eval ] + [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ] unit-test [ "hello world" ] [ "IN: parser.tests : hello ( -- str ) \"hello world\" ;" - eval "USE: parser.tests hello" eval + eval( -- ) "USE: parser.tests hello" eval( -- string ) ] unit-test [ ] - [ "! This is a comment, people." eval ] + [ "! This is a comment, people." eval( -- ) ] unit-test ! Test escapes [ " " ] - [ "\"\\u000020\"" eval ] + [ "\"\\u000020\"" eval( -- string ) ] unit-test [ "'" ] - [ "\"\\u000027\"" eval ] + [ "\"\\u000027\"" eval( -- string ) ] unit-test ! Test EOL comments in multiline strings. - [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test + [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test [ word ] [ \ f class ] unit-test @@ -68,7 +67,7 @@ IN: parser.tests [ \ baz "declared-effect" word-prop terminated?>> ] unit-test - [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test + [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test [ t ] [ "effect-parsing-test" "parser.tests" lookup @@ -79,14 +78,14 @@ IN: parser.tests [ \ effect-parsing-test "declared-effect" word-prop ] unit-test ! Funny bug - [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test + [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test - [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail + [ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail ! These should throw errors - [ "HEX: zzz" eval ] must-fail - [ "OCT: 999" eval ] must-fail - [ "BIN: --0" eval ] must-fail + [ "HEX: zzz" eval( -- obj ) ] must-fail + [ "OCT: 999" eval( -- obj ) ] must-fail + [ "BIN: --0" eval( -- obj ) ] must-fail ! Another funny bug [ t ] [ @@ -102,14 +101,14 @@ IN: parser.tests ] unit-test DEFER: foo - "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval + "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- ) - [ ] [ "USE: parser.tests foo" eval ] unit-test + [ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test - "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval + "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- ) [ t ] [ - "USE: parser.tests \\ foo" eval + "USE: parser.tests \\ foo" eval( -- word ) "foo" "parser.tests" lookup eq? ] unit-test @@ -269,12 +268,12 @@ IN: parser.tests ] unit-test [ ] [ - "IN: parser.tests : ( -- ) ; : bogus ( -- ) ;" + "IN: parser.tests : ( -- ) ; : bogus ( -- error ) ;" "bogus-error" parse-stream drop ] unit-test [ ] [ - "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ( -- ) ;" + "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ( -- error ) ;" "bogus-error" parse-stream drop ] unit-test @@ -339,16 +338,16 @@ IN: parser.tests ] [ error>> error>> error>> redefine-error? ] must-fail-with [ ] [ - "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- ) ] unit-test [ - "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- ) ] must-fail ] with-file-vocabs [ ] [ - "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval + "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval( -- ) ] unit-test [ t ] [ @@ -422,31 +421,31 @@ IN: parser.tests ] unit-test [ - "USE: this-better-not-exist" eval + "USE: this-better-not-exist" eval( -- ) ] must-fail -[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with +[ ": foo ;" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with -[ 92 ] [ "CHAR: \\" eval ] unit-test -[ 92 ] [ "CHAR: \\\\" eval ] unit-test +[ 92 ] [ "CHAR: \\" eval( -- n ) ] unit-test +[ 92 ] [ "CHAR: \\\\" eval( -- n ) ] unit-test [ ] [ { "IN: parser.tests" - "USING: math arrays ;" - "GENERIC: change-combination ( a -- b )" - "M: integer change-combination 1 ;" - "M: array change-combination 2 ;" + "USING: math arrays kernel ;" + "GENERIC: change-combination ( obj a -- b )" + "M: integer change-combination 2drop 1 ;" + "M: array change-combination 2drop 2 ;" } "\n" join "change-combination-test" parse-stream drop ] unit-test [ ] [ { "IN: parser.tests" - "USING: math arrays ;" - "GENERIC# change-combination 1 ( a -- b )" - "M: integer change-combination 1 ;" - "M: array change-combination 2 ;" + "USING: math arrays kernel ;" + "GENERIC# change-combination 1 ( obj a -- b )" + "M: integer change-combination 2drop 1 ;" + "M: array change-combination 2drop 2 ;" } "\n" join "change-combination-test" parse-stream drop ] unit-test @@ -463,7 +462,7 @@ IN: parser.tests ] unit-test [ [ ] ] [ - "IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" + "IN: parser.tests : staging-problem-test-1 ( -- a ) 1 ; : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;" "staging-problem-test" parse-stream ] unit-test @@ -472,7 +471,7 @@ IN: parser.tests [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ [ ] ] [ - "IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" + "IN: parser.tests << : staging-problem-test-1 ( -- a ) 1 ; >> : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;" "staging-problem-test" parse-stream ] unit-test @@ -480,10 +479,10 @@ IN: parser.tests [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test -[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with +[ "DEFER: blahy" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with [ - "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval + "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval( -- ) ] [ error>> staging-violation? ] must-fail-with @@ -491,12 +490,12 @@ IN: parser.tests ! Bogus error message DEFER: blahy -[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ] +[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval( -- ) ] [ error>> error>> def>> \ blahy eq? ] must-fail-with [ ] [ f lexer set f file set "Hello world" note. ] unit-test -[ "CHAR: \\u9999999999999" eval ] must-fail +[ "CHAR: \\u9999999999999" eval( -- n ) ] must-fail SYMBOLS: a b c ; @@ -506,15 +505,15 @@ SYMBOLS: a b c ; DEFER: blah -[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test -[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test +[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval( -- ) ] unit-test +[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval( -- ) ] unit-test [ f ] [ \ blah generic? ] unit-test [ t ] [ \ blah symbol? ] unit-test DEFER: blah1 -[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ] +[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval( -- ) ] [ error>> error>> def>> \ blah1 eq? ] must-fail-with @@ -545,10 +544,10 @@ EXCLUDE: qualified.tests.bar => x ; [ 3 ] [ x ] unit-test [ 4 ] [ y ] unit-test -[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ] +[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval( -- ) ] [ error>> no-word-error? ] must-fail-with -[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ] +[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval( -- ) ] [ error>> no-word-error? ] must-fail-with ! Two similar bugs diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d613a8b24..01e0b18887 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces -sequences strings vectors words words.symbol quotations io combinators -sorting splitting math.parser effects continuations io.files vocabs -io.encodings.utf8 source-files classes hashtables compiler.errors -compiler.units accessors sets lexer vocabs.parser effects.parser slots ; +sequences strings vectors words words.symbol quotations io +combinators sorting splitting math.parser effects continuations +io.files vocabs io.encodings.utf8 source-files classes +hashtables compiler.units accessors sets lexer vocabs.parser +effects.parser slots ; IN: parser : location ( -- loc ) @@ -179,6 +180,7 @@ SYMBOL: interactive-vocabs "math.order" "memory" "namespaces" + "parser" "prettyprint" "see" "sequences" @@ -190,14 +192,16 @@ SYMBOL: interactive-vocabs "tools.annotations" "tools.crossref" "tools.disassembler" + "tools.errors" "tools.memory" "tools.profiler" "tools.test" "tools.threads" "tools.time" - "tools.vocabs" "vocabs" "vocabs.loader" + "vocabs.refresh" + "vocabs.hierarchy" "words" "scratchpad" } interactive-vocabs set-global @@ -261,7 +265,7 @@ print-use-hook [ [ ] ] initialize : finish-parsing ( lines quot -- ) file get - [ record-form ] + [ record-top-level-form ] [ record-definitions ] [ record-checksum ] tri ; @@ -269,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 @@ -280,11 +284,9 @@ print-use-hook [ [ ] ] initialize : parse-file ( file -- quot ) [ - [ - [ parsing-file ] keep - [ utf8 ] keep - parse-stream - ] with-compiler-errors + [ parsing-file ] keep + [ utf8 ] keep + parse-stream ] [ over parse-file-restarts rethrow-restarts drop parse-file diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 2a03b7c74f..364f186d52 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -24,7 +24,14 @@ ARTICLE: "wrappers" "Wrappers" "Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:" { $subsection wrapper } { $subsection literalize } -{ $see-also "dataflow" "combinators" } ; +"Wrapper literal syntax is documented in " { $link "syntax-words" } "." +{ $example + "IN: scratchpad" + "DEFER: my-word" + "\\ my-word name>> ." + "\"my-word\"" +} +{ $see-also "combinators" } ; ABOUT: "quotations" diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 2c3b41ca4e..3245ac1e20 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -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 c171555737..cfd96789b4 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 @@ -311,7 +311,7 @@ HELP: each-index HELP: map-index { $values - { "seq" sequence } { "quot" quotation } } + { "seq" sequence } { "quot" quotation } { "newseq" sequence } } { $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." } { $examples { $example "USING: sequences prettyprint math ;" "{ 10 20 30 } [ + ] map-index ." @@ -1354,14 +1354,16 @@ ARTICLE: "virtual-sequences" "Virtual sequences" "Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "virtual-sequences-protocol" } "." { $subsection "virtual-sequences-protocol" } ; -ARTICLE: "sequences-integers" "Integer sequences and counted loops" +ARTICLE: "sequences-integers" "Counted loops" "Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops." $nl "For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:" { $example "3 [ . ] each" "0\n1\n2" } "A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "." $nl -"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ; +"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." +$nl +"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ; ARTICLE: "sequences-access" "Accessing sequence elements" { $subsection ?nth } @@ -1464,8 +1466,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? } @@ -1593,7 +1595,6 @@ $nl "Sequences implement a protocol:" { $subsection "sequence-protocol" } { $subsection "sequences-f" } -{ $subsection "sequences-integers" } "Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "." { $subsection "sequences-access" } { $subsection "sequences-combinators" } @@ -1612,6 +1613,10 @@ $nl { $subsection "binary-search" } { $subsection "sets" } { $subsection "sequences-trimming" } +{ $subsection "sequences.deep" } +"Using sequences for looping:" +{ $subsection "sequences-integers" } +{ $subsection "math.ranges" } "For inner loops:" { $subsection "sequences-unsafe" } ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index da495f410f..85f9d56596 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -227,7 +227,7 @@ unit-test [ -3 10 nth ] must-fail [ 11 10 nth ] must-fail -[ -1./0. 0 delete-nth ] must-fail +[ -1/0. 0 delete-nth ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test [ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index f352705e85..d60602fc71 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 @@ -506,7 +506,7 @@ PRIVATE> [ [ 0 = ] 2dip if ] 2curry each-index ; inline -: map-index ( seq quot -- ) +: map-index ( seq quot -- newseq ) prepare-index 2map ; inline : reduce-index ( seq identity quot -- ) @@ -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 @@ -568,6 +568,11 @@ M: sequence <=> 2dup [ length ] bi@ = [ mismatch not ] [ 2drop f ] if ; inline +ERROR: assert-sequence got expected ; + +: assert-sequence= ( a b -- ) + 2dup sequence= [ 2drop ] [ assert-sequence ] if ; + : sequence-hashcode-step ( oldhash newpart -- newhash ) >fixnum swap [ [ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi @@ -590,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 @@ -607,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 ; @@ -636,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 ; @@ -662,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 @@ -674,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 ] @@ -687,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 ) [ @@ -794,7 +799,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-docs.factor b/core/slots/slots-docs.factor index 840fe628e0..1e5f9bf1dd 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -83,7 +83,7 @@ $nl "A word can be used to check if a class has an initial value or not:" { $subsection initial-value } ; -ARTICLE: "slots" "Slots" +ARTICLE: "slots" "Low-level slot operations" "The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object. A " { $emphasis "slot" } " is a component of an object which can store a value." $nl { $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data." @@ -104,6 +104,9 @@ $nl { $subsection define-changer } { $subsection define-slot-methods } { $subsection define-accessors } +"Unsafe slot access:" +{ $subsection slot } +{ $subsection set-slot } { $see-also "accessors" "mirrors" } ; ABOUT: "slots" diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 767cec4830..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 ; @@ -25,12 +25,12 @@ TUPLE: hello length ; [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test ! See if declarations are cleared on redefinition -[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test +[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test [ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test -[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test +[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test [ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test diff --git a/core/slots/slots.factor b/core/slots/slots.factor index a353f50947..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 ; @@ -222,7 +222,7 @@ M: slot-spec make-slot [ make-slot ] map ; : finalize-slots ( specs base -- specs ) - over length [ + ] with map [ >>offset ] 2map ; + over length iota [ + ] with map [ >>offset ] 2map ; : slot-named ( name specs -- spec/f ) [ name>> = ] with find nip ; 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/errors/authors.txt b/core/source-files/errors/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/source-files/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/source-files/errors/errors-tests.factor b/core/source-files/errors/errors-tests.factor new file mode 100644 index 0000000000..f13790f5bb --- /dev/null +++ b/core/source-files/errors/errors-tests.factor @@ -0,0 +1,10 @@ +USING: assocs compiler.errors compiler.units definitions +namespaces source-files.errors tools.test words ; +IN: source-files.errors.tests + +DEFER: forget-test + +[ ] [ [ \ forget-test [ 1 ] (( -- )) define-declared ] with-compilation-unit ] unit-test +[ t ] [ \ forget-test compiler-errors get key? ] unit-test +[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test +[ f ] [ \ forget-test compiler-errors get key? ] unit-test \ No newline at end of file diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor new file mode 100644 index 0000000000..f6f4f4825a --- /dev/null +++ b/core/source-files/errors/errors.factor @@ -0,0 +1,77 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel math.order sorting sequences definitions +namespaces arrays splitting io math.parser math init ; +IN: source-files.errors + +TUPLE: source-file-error error asset file line# ; + +: sort-errors ( errors -- alist ) + [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ; + +: group-by-source-file ( errors -- assoc ) + H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ; + +TUPLE: error-type type word plural icon quot forget-quot { fatal? initial: t } ; + +GENERIC: error-type ( error -- type ) + +: ( error definition class -- source-file-error ) + new + swap + [ >>asset ] + [ where [ first2 [ >>file ] [ >>line# ] bi* ] when* ] bi + swap >>error ; inline + +SYMBOL: error-types + +error-types [ V{ } clone ] initialize + +: define-error-type ( error-type -- ) + dup type>> error-types get set-at ; + +: error-icon-path ( type -- icon ) + error-types get at icon>> ; + +: error-counts ( -- alist ) + error-types get + [ nip dup quot>> call( -- seq ) length ] assoc-map + [ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ; + +: error-summary ( -- ) + error-counts [ + over + [ word>> write ] + [ " - show " write number>string write bl ] + [ plural>> print ] tri* + ] assoc-each ; + +: all-errors ( -- errors ) + error-types get values + [ quot>> call( -- seq ) ] map + concat ; + +GENERIC: errors-changed ( observer -- ) + +SYMBOL: error-observers + +[ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook + +: add-error-observer ( observer -- ) error-observers get push ; + +: remove-error-observer ( observer -- ) error-observers get delq ; + +: notify-error-observers ( -- ) error-observers get [ errors-changed ] each ; + +: delete-file-errors ( seq file type -- ) + [ + [ swap file>> = ] [ swap error-type = ] + bi-curry* bi and not + ] 2curry filter-here + notify-error-observers ; + +: delete-definition-errors ( definition -- ) + error-types get [ + second forget-quot>> dup + [ call( definition -- ) ] [ 2drop ] if + ] with each ; \ No newline at end of file diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 2c9e2172cc..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 } @@ -11,9 +11,7 @@ $nl { $subsection source-file } "Words intended for the parser:" { $subsection record-checksum } -{ $subsection record-form } -{ $subsection xref-source } -{ $subsection unxref-source } +{ $subsection record-definitions } "Removing a source file from the database:" { $subsection forget-source } "Updating the database:" @@ -42,27 +40,8 @@ HELP: record-checksum { $description "Records the CRC32 checksm of the source file's contents." } $low-level-note ; -HELP: xref-source -{ $values { "source-file" source-file } } -{ $description "Adds the source file to the " { $link crossref } " graph enabling words to find source files which reference them in their top level forms." } -$low-level-note ; - -HELP: unxref-source -{ $values { "source-file" source-file } } -{ $description "Removes the source file from the " { $link crossref } " graph." } -$low-level-note ; - -HELP: xref-sources -{ $description "Adds all loaded source files to the " { $link crossref } " graph. This is done during bootstrap." } -$low-level-note ; - -HELP: record-form -{ $values { "quot" quotation } { "source-file" source-file } } -{ $description "Records usage information for a source file's top level form." } -$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/source-files/source-files.factor b/core/source-files/source-files.factor index c8441ba3b0..558018a147 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -1,39 +1,26 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces sequences strings vectors words quotations io io.files io.pathnames combinators sorting splitting math.parser effects continuations checksums checksums.crc32 vocabs hashtables graphs -compiler.units io.encodings.utf8 accessors ; +compiler.units io.encodings.utf8 accessors source-files.errors ; IN: source-files SYMBOL: source-files TUPLE: source-file path +top-level-form checksum -uses definitions ; +definitions ; + +: record-top-level-form ( quot file -- ) + (>>top-level-form) H{ } notify-definition-observers ; : record-checksum ( lines source-file -- ) [ crc32 checksum-lines ] dip (>>checksum) ; -: (xref-source) ( source-file -- pathname uses ) - [ path>> ] - [ uses>> [ crossref? ] filter ] bi ; - -: xref-source ( source-file -- ) - (xref-source) crossref get add-vertex ; - -: unxref-source ( source-file -- ) - (xref-source) crossref get remove-vertex ; - -: xref-sources ( -- ) - source-files get [ nip xref-source ] assoc-each ; - -: record-form ( quot source-file -- ) - [ quot-uses keys ] dip - [ unxref-source ] [ (>>uses) ] [ xref-source ] tri ; - : record-definitions ( file -- ) new-definitions get >>definitions drop ; @@ -58,14 +45,8 @@ ERROR: invalid-source-file-path path ; M: pathname where string>> 1 2array ; : forget-source ( path -- ) - [ - source-file - [ unxref-source ] - [ definitions>> [ keys forget-all ] each ] - bi - ] - [ source-files get delete-at ] - bi ; + source-files get delete-at* + [ definitions>> [ keys forget-all ] each ] [ drop ] if ; M: pathname forget* string>> forget-source ; @@ -77,21 +58,20 @@ M: pathname forget* SYMBOL: file -TUPLE: source-file-error error file ; - -: ( msg -- error ) +: wrap-source-file-error ( error -- * ) + file get rollback-source-file \ source-file-error new - file get >>file - swap >>error ; + f >>line# + file get path>> >>file + swap >>error rethrow ; : with-source-file ( name quot -- ) #! Should be called from inside with-compilation-unit. [ - swap source-file - dup file set - definitions>> old-definitions set [ - file get rollback-source-file - rethrow - ] recover + source-file + [ file set ] + [ definitions>> old-definitions set ] bi + ] dip + [ wrap-source-file-error ] recover ] with-scope ; inline 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 df9eb568f6..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 ; +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" @@ -66,6 +66,12 @@ ARTICLE: "syntax-floats" "Float syntax" "7.e13" "1.0e-5" } +"There are three special float values:" +{ $table +{ "Positive infinity" { $snippet "1/0." } } +{ "Negative infinity" { $snippet "-1/0." } } +{ "Not-a-number" { $snippet "0/0." } } +} "More information on floats can be found in " { $link "floats" } "." ; ARTICLE: "syntax-complex-numbers" "Complex number syntax" @@ -146,6 +152,11 @@ ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } "Pathnames are documented in " { $link "io.pathnames" } "." ; +ARTICLE: "syntax-effects" "Stack effect syntax" +"Note that this is " { $emphasis "not" } " syntax to declare stack effects of words. This pushes an " { $link effect } " instance on the stack for reflection, for use with words such as " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "." +{ $subsection POSTPONE: (( } +{ $see-also "effects" "inference" "tools.inference" } ; + ARTICLE: "syntax-literals" "Literals" "Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words." $nl @@ -162,11 +173,14 @@ $nl { $subsection "syntax-sbufs" } { $subsection "syntax-hashtables" } { $subsection "syntax-tuples" } -{ $subsection "syntax-pathnames" } ; +{ $subsection "syntax-pathnames" } +{ $subsection "syntax-effects" } ; ARTICLE: "syntax" "Syntax" "Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "." { $subsection "parser-algorithm" } +{ $subsection "vocabulary-search" } +{ $subsection "top-level-forms" } { $subsection "syntax-comments" } { $subsection "syntax-literals" } { $subsection "syntax-immediate" } ; @@ -509,7 +523,7 @@ HELP: ( { $syntax "( inputs -- outputs )" } { $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } } { $description "A stack effect declaration. This is treated as a comment unless it appears inside a word definition." } -{ $see-also "effect-declaration" } ; +{ $see-also "effects" } ; HELP: (( { $syntax "(( inputs -- outputs ))" } @@ -517,11 +531,19 @@ HELP: (( { $description "Literal stack effect syntax." } { $notes "Useful for meta-programming with " { $link define-declared } "." } { $examples - { $code + { $example + "USING: compiler.units kernel math prettyprint random words ;" + "IN: scratchpad" + "" "SYMBOL: my-dynamic-word" - "USING: math random words ;" - "3 { [ + ] [ - ] [ * ] [ / ] } random curry" - "(( x -- y )) define-declared" + "" + "[" + " my-dynamic-word 2 { [ + ] [ * ] } random curry" + " (( x -- y )) define-declared" + "] with-compilation-unit" + "" + "2 my-dynamic-word ." + "4" } } ; @@ -727,7 +749,7 @@ HELP: " "" @@ -738,7 +760,7 @@ HELP: > { $description "Marks the end of a parse time code block." } ; HELP: call-next-method +{ $syntax "call-next-method" } { $description "Calls the next applicable method. Only valid inside a method definition. The values at the top of the stack are passed on to the next method, and they must be compatible with that method's class specializer." } +{ $notes "This word looks like an ordinary word but it is a parsing word. It cannot be factored out of a method definition, since the code expansion references the current method object directly." } { $errors "Throws a " { $link no-next-method } " error if this is the least specific method, and throws an " { $link inconsistent-next-method } " error if the values at the top of the stack are not compatible with the current method's specializer." } ; @@ -773,10 +797,17 @@ HELP: call-next-method HELP: call( { $syntax "call( stack -- effect )" } -{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; +{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } +{ $examples + { $code + "TUPLE: action name quot ;" + ": perform-action ( action -- )" + " [ name>> print ] [ quot>> call( -- ) ] bi ;" + } +} ; HELP: execute( { $syntax "execute( stack -- effect )" } { $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ; -{ POSTPONE: call( POSTPONE: execute( } related-words \ No newline at end of file +{ POSTPONE: call( POSTPONE: execute( } related-words diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index cb5cdfd5ac..7d710717aa 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien arrays byte-arrays definitions generic +USING: accessors alien arrays byte-arrays byte-vectors definitions generic hashtables kernel math namespaces parser lexer sequences strings strings.parser sbufs vectors words words.symbol words.constant words.alias quotations io assocs splitting classes.tuple -generic.standard generic.math generic.parser classes +generic.standard generic.hook generic.math generic.parser classes io.pathnames vocabs vocabs.parser classes.parser classes.union classes.intersection classes.mixin classes.predicate classes.singleton classes.tuple.parser compiler.units @@ -98,12 +98,14 @@ IN: bootstrap.syntax "{" [ \ } [ >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 "POSTPONE:" [ scan-word parsed ] define-core-syntax "\\" [ scan-word parsed ] define-core-syntax + "M\\" [ scan-word scan-word method parsed ] define-core-syntax "inline" [ word make-inline ] define-core-syntax "recursive" [ word make-recursive ] define-core-syntax "foldable" [ word make-foldable ] 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 87531caee4..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 ( -- ) ; @@ -143,7 +136,7 @@ IN: vocabs.loader.tests forget-junk [ { } ] [ - "IN: xabbabbja" eval "xabbabbja" vocab-files + "IN: xabbabbja" eval( -- ) "xabbabbja" vocab-files ] unit-test [ "xabbabbja" forget-vocab ] with-compilation-unit diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 4f9005e110..6561c55b67 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -3,7 +3,7 @@ USING: namespaces make sequences io io.files io.pathnames kernel assocs words vocabs definitions parser continuations hashtables sorting source-files arrays combinators strings system -math.parser compiler.errors splitting init accessors sets ; +math.parser splitting init accessors sets ; IN: vocabs.loader SYMBOL: vocab-roots @@ -80,11 +80,11 @@ SYMBOL: load-help? PRIVATE> : require ( vocab -- ) - [ load-vocab drop ] with-compiler-errors ; + load-vocab drop ; : reload ( name -- ) dup vocab - [ [ [ load-source ] [ load-docs ] bi ] with-compiler-errors ] + [ [ load-source ] [ load-docs ] bi ] [ require ] ?if ; @@ -125,9 +125,7 @@ PRIVATE> [ dup vocab-name blacklist get at* [ rethrow ] [ drop dup find-vocab-root - [ [ (load-vocab) ] with-compiler-errors ] - [ dup vocab [ ] [ no-vocab ] ?if ] - if + [ (load-vocab) ] [ dup vocab [ ] [ no-vocab ] ?if ] if ] if ] load-vocab-hook set-global 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/alias/alias-tests.factor b/core/words/alias/alias-tests.factor index 0278a4d4b9..c4bc8519a9 100644 --- a/core/words/alias/alias-tests.factor +++ b/core/words/alias/alias-tests.factor @@ -2,5 +2,5 @@ USING: math eval tools.test effects ; IN: words.alias.tests ALIAS: foo + -[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test -[ (( -- value )) ] [ \ foo stack-effect ] unit-test \ No newline at end of file +[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval( -- ) ] unit-test +[ (( -- value )) ] [ \ foo stack-effect ] unit-test diff --git a/core/words/alias/alias.factor b/core/words/alias/alias.factor index 0615e8333e..73e270dffc 100644 --- a/core/words/alias/alias.factor +++ b/core/words/alias/alias.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: quotations effects accessors sequences words kernel ; +USING: quotations effects accessors sequences words kernel definitions ; IN: words.alias PREDICATE: alias < word "alias" word-prop ; @@ -12,5 +12,6 @@ PREDICATE: alias < word "alias" word-prop ; M: alias reset-word [ call-next-method ] [ f "alias" set-word-prop ] bi ; -M: alias stack-effect - def>> first stack-effect ; +M: alias definer drop \ ALIAS: f ; + +M: alias definition def>> first 1quotation ; \ No newline at end of file diff --git a/core/words/constant/constant-docs.factor b/core/words/constant/constant-docs.factor new file mode 100644 index 0000000000..3175b5d4ff --- /dev/null +++ b/core/words/constant/constant-docs.factor @@ -0,0 +1,12 @@ +USING: help.markup help.syntax words.constant ; +IN: words.constant + +ARTICLE: "words.constant" "Constants" +"There is a syntax for defining words which push literals on the stack." +$nl +"Define a new word that pushes a literal on the stack:" +{ $subsection POSTPONE: CONSTANT: } +"Define an constant at run-time:" +{ $subsection define-constant } ; + +ABOUT: "words.constant" diff --git a/core/words/constant/constant-tests.factor b/core/words/constant/constant-tests.factor new file mode 100644 index 0000000000..721846b2d1 --- /dev/null +++ b/core/words/constant/constant-tests.factor @@ -0,0 +1,20 @@ +IN: words.constant.tests +USING: tools.test math words.constant ; + +CONSTANT: a + + +[ + ] [ a ] unit-test + +[ t ] [ \ a constant? ] unit-test + +CONSTANT: b \ + + +[ \ + ] [ b ] unit-test + +CONSTANT: c { 1 2 3 } + +[ { 1 2 3 } ] [ c ] unit-test + +SYMBOL: foo + +[ f ] [ \ foo constant? ] unit-test \ No newline at end of file diff --git a/core/words/constant/constant.factor b/core/words/constant/constant.factor index 43b7f37599..b518760bf9 100644 --- a/core/words/constant/constant.factor +++ b/core/words/constant/constant.factor @@ -1,10 +1,17 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences words ; +USING: accessors kernel sequences words definitions quotations ; IN: words.constant -PREDICATE: constant < word ( obj -- ? ) - def>> dup length 1 = [ first word? not ] [ drop f ] if ; +PREDICATE: constant < word "constant" word-prop >boolean ; : define-constant ( word value -- ) - [ ] curry (( -- value )) define-inline ; + [ "constant" set-word-prop ] + [ [ ] curry (( -- value )) define-inline ] 2bi ; + +M: constant reset-word + [ call-next-method ] [ f "constant" set-word-prop ] bi ; + +M: constant definer drop \ CONSTANT: f ; + +M: constant definition "constant" word-prop literalize 1quotation ; \ No newline at end of file diff --git a/core/words/symbol/symbol.factor b/core/words/symbol/symbol.factor index a107808eec..34ec6b9174 100644 --- a/core/words/symbol/symbol.factor +++ b/core/words/symbol/symbol.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors definitions -words words.constant ; +USING: kernel sequences accessors definitions words ; IN: words.symbol -PREDICATE: symbol < constant ( obj -- ? ) +PREDICATE: symbol < word ( obj -- ? ) [ def>> ] [ [ ] curry ] bi sequence= ; M: symbol definer drop \ SYMBOL: f ; @@ -12,4 +11,4 @@ M: symbol definer drop \ SYMBOL: f ; M: symbol definition drop f ; : define-symbol ( word -- ) - dup define-constant ; + dup [ ] curry (( -- value )) define-inline ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 1ad6928acb..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 @@ -21,8 +21,8 @@ $nl { $subsection gensym } { $subsection define-temp } ; -ARTICLE: "colon-definition" "Word definitions" -"Every word has an associated quotation definition that is called when the word is executed." +ARTICLE: "colon-definition" "Colon definitions" +"Every word has an associated quotation definition that is called when the word is executed. A " { $emphasis "colon definition" } " is a word where this quotation is supplied directly by the user. This is the simplest and most common type of word definition." $nl "Defining words at parse time:" { $subsection POSTPONE: : } @@ -31,7 +31,7 @@ $nl { $subsection define } { $subsection define-declared } { $subsection define-inline } -"Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "." +"Word definitions must declare their stack effect. See " { $link "effects" } "." $nl "All other types of word definitions, such as " { $link "words.symbol" } " and " { $link "generic" } ", are just special cases of the above." ; @@ -56,29 +56,16 @@ $nl ": foo undefined ;" } ; -ARTICLE: "declarations" "Declarations" -"Declarations are parsing words that set a word property in the most recently defined word. Declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." +ARTICLE: "declarations" "Compiler declarations" +"Compiler declarations are parsing words that set a word property in the most recently defined word. They appear after the final " { $link POSTPONE: ; } " of a word definition:" +{ $code ": cubed ( x -- y ) dup dup * * ; foldable" } +"Compiler declarations assert that the word follows a certain contract, enabling certain optimizations that are not valid in general." { $subsection POSTPONE: inline } { $subsection POSTPONE: foldable } { $subsection POSTPONE: flushable } { $subsection POSTPONE: recursive } -{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." } -"Stack effect declarations are documented in " { $link "effect-declaration" } "." ; - -ARTICLE: "word-definition" "Defining words" -"There are two approaches to creating word definitions:" -{ $list - "using parsing words at parse time," - "using defining words at run time." -} -"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words." -{ $subsection "colon-definition" } -{ $subsection "words.symbol" } -{ $subsection "words.alias" } -{ $subsection "primitives" } -{ $subsection "deferred" } -{ $subsection "declarations" } -"Words implement the definition protocol; see " { $link "definitions" } "." ; +"It is entirely up to the programmer to ensure that the word satisfies the contract of a declaration. Furthermore, if a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract. Unspecified behavior may result if a word does not follow the contract of one of its declarations." +{ $see-also "effects" } ; ARTICLE: "word-props" "Word properties" "Each word has a hashtable of properties." @@ -99,14 +86,10 @@ $nl { { { $snippet "\"reading\"" } ", " { $snippet "\"writing\"" } } { "Set on slot accessor words - " { $link "slots" } } } - { { $snippet "\"declared-effect\"" } { $link "effect-declaration" } } + { { $snippet "\"declared-effect\"" } { $link "effects" } } { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } - { { $snippet "\"infer\"" } { $link "macros" } } - - { { { $snippet "\"inferred-effect\"" } } { $link "inference" } } - { { $snippet "\"specializer\"" } { $link "hints" } } { { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" } @@ -137,9 +120,7 @@ $nl "An " { $emphasis "XT" } " (execution token) is the machine code address of a word:" { $subsection word-xt } ; -ARTICLE: "words" "Words" -"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." -$nl +ARTICLE: "words.introspection" "Word introspection" "Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary." $nl "Word objects contain several slots:" @@ -152,22 +133,36 @@ $nl "Words are instances of a class." { $subsection word } { $subsection word? } +"Words implement the definition protocol; see " { $link "definitions" } "." { $subsection "interned-words" } { $subsection "uninterned-words" } -{ $subsection "word-definition" } { $subsection "word-props" } -{ $subsection "word.private" } +{ $subsection "word.private" } ; + +ARTICLE: "words" "Words" +"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." +$nl +"There are two ways of creating word definitions:" +{ $list + "using parsing words at parse time," + "using defining words at run time." +} +"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words." +$nl +"Types of words:" +{ $subsection "colon-definition" } +{ $subsection "words.symbol" } +{ $subsection "words.alias" } +{ $subsection "words.constant" } +{ $subsection "primitives" } +"Advanced topics:" +{ $subsection "deferred" } +{ $subsection "declarations" } +{ $subsection "words.introspection" } { $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ; ABOUT: "words" -HELP: execute ( word -- ) -{ $values { "word" word } } -{ $description "Executes a word." } -{ $examples - { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ;\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } -} ; - HELP: deferred { $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ; @@ -293,10 +288,6 @@ HELP: define-temp "This word must be called from inside " { $link with-compilation-unit } "." } ; -HELP: quot-uses -{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } } -{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ; - HELP: delimiter? { $values { "obj" object } { "?" "a boolean" } } { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 305541119b..0ecf7b65f0 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -6,7 +6,7 @@ IN: words.tests [ 4 ] [ [ - "poo" "words.tests" create [ 2 2 + ] define + "poo" "words.tests" create [ 2 2 + ] (( -- n )) define-declared ] with-compilation-unit "poo" "words.tests" lookup execute ] unit-test @@ -51,7 +51,7 @@ SYMBOL: a-symbol ! See if redefining a generic as a colon def clears some ! word props. GENERIC: testing ( a -- b ) -"IN: words.tests : testing ( -- ) ;" eval +"IN: words.tests : testing ( -- ) ;" eval( -- ) [ f ] [ \ testing generic? ] unit-test @@ -63,52 +63,6 @@ FORGET: forgotten FORGET: another-forgotten : another-forgotten ( -- ) ; -! I forgot remove-crossref calls! -: fee ( -- ) ; -: foe ( -- ) fee ; -: fie ( -- ) foe ; - -[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test -[ t ] [ \ foe usage empty? ] unit-test -[ f ] [ \ foe crossref get key? ] unit-test - -FORGET: foe - -! xref should not retain references to gensyms -[ ] [ - [ gensym [ * ] define ] with-compilation-unit -] unit-test - -[ t ] [ - \ * usage [ word? ] filter [ crossref? ] all? -] unit-test - -DEFER: calls-a-gensym -[ ] [ - [ - \ calls-a-gensym - gensym dup "x" set 1quotation - define - ] with-compilation-unit -] unit-test - -[ f ] [ "x" get crossref get at ] unit-test - -! more xref buggery -[ f ] [ - GENERIC: xyzzle ( x -- x ) - : a ( -- ) ; \ a - M: integer xyzzle a ; - FORGET: a - M: object xyzzle ; - crossref get at -] unit-test - -! regression -GENERIC: freakish ( x -- y ) -: bar ( x -- y ) freakish ; -M: array freakish ; -[ t ] [ \ bar \ freakish usage member? ] unit-test DEFER: x [ x ] [ undefined? ] must-fail-with @@ -116,45 +70,25 @@ DEFER: x [ ] [ "no-loc" "words.tests" create drop ] unit-test [ f ] [ "no-loc" "words.tests" lookup where ] unit-test -[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval( -- ) ] unit-test [ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test -[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test [ "test-last" ] [ word name>> ] unit-test -! regression -SYMBOL: quot-uses-a -SYMBOL: quot-uses-b - -[ ] [ - [ - quot-uses-a [ 2 3 + ] define - ] with-compilation-unit -] unit-test - -[ { + } ] [ \ quot-uses-a uses ] unit-test - -[ ] [ - [ - quot-uses-b 2 [ 3 + ] curry define - ] with-compilation-unit -] unit-test - -[ { + } ] [ \ quot-uses-b uses ] unit-test - "undef-test" "words.tests" lookup [ [ forget ] with-compilation-unit ] when* -[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval ] +[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval( -- ) ] [ error>> undefined? ] must-fail-with [ ] [ - "IN: words.tests GENERIC: symbol-generic ( -- )" eval + "IN: words.tests GENERIC: symbol-generic ( -- )" eval( -- ) ] unit-test [ ] [ - "IN: words.tests SYMBOL: symbol-generic" eval + "IN: words.tests SYMBOL: symbol-generic" eval( -- ) ] unit-test [ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test @@ -174,14 +108,14 @@ SYMBOL: quot-uses-b [ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test ! Regressions -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval( -- ) ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval( -- ) ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ { } ] @@ -191,8 +125,3 @@ SYMBOL: quot-uses-b keys [ "forgotten" word-prop ] any? ] filter ] unit-test - -[ { } ] [ - crossref get keys - [ word? ] filter [ "forgotten" word-prop ] filter -] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index 5b230c1b00..1976c1e4cd 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 ; @@ -62,37 +62,7 @@ SYMBOL: bootstrapping? GENERIC: crossref? ( word -- ? ) M: word crossref? - dup "forgotten" word-prop [ - drop f - ] [ - vocabulary>> >boolean - ] if ; - -GENERIC: compiled-crossref? ( word -- ? ) - -M: word compiled-crossref? crossref? ; - -GENERIC# (quot-uses) 1 ( obj assoc -- ) - -M: object (quot-uses) 2drop ; - -M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ; - -: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; - -M: array (quot-uses) seq-uses ; - -M: hashtable (quot-uses) [ >alist ] dip seq-uses ; - -M: callable (quot-uses) seq-uses ; - -M: wrapper (quot-uses) [ wrapped>> ] dip (quot-uses) ; - -: quot-uses ( quot -- assoc ) - global [ H{ } clone [ (quot-uses) ] keep ] bind ; - -M: word uses ( word -- seq ) - def>> quot-uses keys ; + dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ; SYMBOL: compiled-crossref @@ -131,44 +101,22 @@ compiled-generic-crossref [ H{ } clone ] initialize : inline? ( word -- ? ) "inline" word-prop ; inline -SYMBOL: visited +GENERIC: subwords ( word -- seq ) -CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" } - -: (redefined) ( word -- ) - dup visited get key? [ drop ] [ - [ reset-on-redefine reset-props ] - [ visited get conjoin ] - [ - crossref get at keys - [ word? ] filter - [ - [ reset-on-redefine [ word-prop ] with any? ] - [ inline? ] - bi or - ] filter - [ (redefined) ] each - ] tri - ] if ; - -: redefined ( word -- ) - [ H{ } clone visited [ (redefined) ] with-variable ] - [ changed-definition ] - bi ; +M: word subwords drop f ; : define ( word def -- ) - [ ] like - over unxref - over redefined - >>def - dup crossref? [ dup xref ] when drop ; + over changed-definition [ ] like >>def drop ; + +: changed-effect ( word -- ) + [ dup changed-effects get set-in-unit ] + [ dup primitive? [ drop ] [ changed-definition ] if ] bi ; : set-stack-effect ( effect word -- ) 2dup "declared-effect" word-prop = [ 2drop ] [ - swap - [ drop changed-effect ] - [ "declared-effect" set-word-prop ] - [ drop dup primitive? [ drop ] [ redefined ] if ] + [ nip changed-effect ] + [ nip subwords [ changed-effect ] each ] + [ swap "declared-effect" set-word-prop ] 2tri ] if ; @@ -176,7 +124,11 @@ CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" } [ nip swap set-stack-effect ] [ drop define ] 3bi ; : make-inline ( word -- ) - t "inline" set-word-prop ; + dup inline? [ drop ] [ + [ t "inline" set-word-prop ] + [ changed-effect ] + bi + ] if ; : make-recursive ( word -- ) t "recursive" set-word-prop ; @@ -199,15 +151,19 @@ M: word reset-word "writer" "delimiter" } reset-props ; -GENERIC: subwords ( word -- seq ) - -M: word subwords drop f ; - : reset-generic ( word -- ) [ subwords forget-all ] [ reset-word ] - [ { "methods" "combination" "default-method" } reset-props ] - tri ; + [ + f >>direct-entry-def + { + "methods" + "combination" + "default-method" + "engines" + "decision-tree" + } reset-props + ] tri ; : gensym ( -- word ) "( gensym )" f ; @@ -250,10 +206,9 @@ M: word set-where swap "loc" set-word-prop ; M: word forget* dup "forgotten" word-prop [ drop ] [ - [ delete-xref ] [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ] [ t "forgotten" set-word-prop ] - tri + bi ] if ; M: word hashcode* @@ -261,6 +216,4 @@ M: word hashcode* M: word literalize ; -: xref-words ( -- ) all-words [ xref ] each ; - INSTANCE: word definition \ No newline at end of file diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor index aae0b40d38..b9679ec26b 100755 --- a/extra/4DNav/4DNav.factor +++ b/extra/4DNav/4DNav.factor @@ -75,8 +75,6 @@ VAR: present-space ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! namespace utilities - -: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ; : closed-quot ( quot -- quot ) namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ; @@ -156,9 +154,9 @@ VAR: present-space 3 model-projection view4> (>>model) ; : camera-action ( quot -- quot ) - [ drop [ ] observer3d> + '[ drop _ observer3d> with-self update-observer-projections ] - make* closed-quot ; + closed-quot ; : win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ; @@ -400,7 +398,7 @@ M: handler handle-gesture ( gesture gadget -- ? ) : add-keyboard-delegate ( obj -- obj ) -{ +H{ { T{ key-down f f "LEFT" } [ [ rotation-step turn-left ] camera-action ] } { T{ key-down f f "RIGHT" } @@ -435,7 +433,7 @@ M: handler handle-gesture ( gesture gadget -- ? ) { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] } { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] } - } [ make* ] map >hashtable >>table + } >>table ; ! -------------------------------------------- diff --git a/extra/4DNav/camera/camera.factor b/extra/4DNav/camera/camera.factor index 1f36a46275..0d46d73f55 100755 --- a/extra/4DNav/camera/camera.factor +++ b/extra/4DNav/camera/camera.factor @@ -1,4 +1,4 @@ -USING: kernel namespaces math.vectors opengl 4DNav.turtle ; +USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ; IN: 4DNav.camera diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor index 9bd0e9c011..51bebc3877 100755 --- a/extra/4DNav/file-chooser/file-chooser.factor +++ b/extra/4DNav/file-chooser/file-chooser.factor @@ -72,17 +72,17 @@ file-chooser H{ : init-filelist-model ( file-chooser -- file-chooser ) dup list-of-files >>model ; -: (fc-go) ( file-chooser quot -- ) +: (fc-go) ( file-chooser button quot -- ) [ [ file-chooser? ] find-parent dup path>> ] dip call normalize-path swap set-model update-filelist-model - drop ; + drop ; inline -: fc-go-parent ( file-chooser -- ) +: fc-go-parent ( file-chooser button -- ) [ dup value>> parent-directory ] (fc-go) ; -: fc-go-home ( file-chooser -- ) +: fc-go-home ( file-chooser button -- ) [ home ] (fc-go) ; : fc-change-directory ( file-chooser file -- ) @@ -92,11 +92,9 @@ file-chooser H{ ; : fc-load-file ( file-chooser file -- ) - dupd [ selected-file>> ] [ name>> ] bi* swap set-model - [ path>> value>> ] - [ selected-file>> value>> append ] - [ hook>> ] tri - call + over [ name>> ] [ selected-file>> ] bi* set-model + [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi + call( path -- ) ; inline ! : fc-ok-action ( file-chooser -- quot ) diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor index 1bece9d4fb..8685d954e8 100644 --- a/extra/annotations/annotations-docs.factor +++ b/extra/annotations/annotations-docs.factor @@ -1,6 +1,6 @@ USING: accessors arrays combinators definitions generalizations help help.markup help.topics kernel sequences sorting vocabs -words combinators.smart ; +words combinators.smart tools.crossref ; IN: annotations audio + +ERROR: format-unsupported-by-openal audio ; + +: openal-format ( audio -- format ) + dup [ channels>> ] [ sample-bits>> ] bi 2array { + { { 1 8 } [ drop AL_FORMAT_MONO8 ] } + { { 1 16 } [ drop AL_FORMAT_MONO16 ] } + { { 2 8 } [ drop AL_FORMAT_STEREO8 ] } + { { 2 16 } [ drop AL_FORMAT_STEREO16 ] } + [ drop format-unsupported-by-openal ] + } case ; + diff --git a/extra/audio/wav/wav.factor b/extra/audio/wav/wav.factor new file mode 100644 index 0000000000..6b76e98f3a --- /dev/null +++ b/extra/audio/wav/wav.factor @@ -0,0 +1,85 @@ +USING: alien.c-types alien.syntax audio combinators +combinators.short-circuit io io.binary io.encodings.binary +io.files io.streams.byte-array kernel locals math +sequences ; +IN: audio.wav + +CONSTANT: RIFF-MAGIC "RIFF" +CONSTANT: WAVE-MAGIC "WAVE" +CONSTANT: FMT-MAGIC "fmt " +CONSTANT: DATA-MAGIC "data" + +C-STRUCT: riff-chunk-header + { "char[4]" "id" } + { "uchar[4]" "size" } + ; + +C-STRUCT: riff-chunk + { "riff-chunk-header" "header" } + { "char[4]" "format" } + ; + +C-STRUCT: wav-fmt-chunk + { "riff-chunk-header" "header" } + { "uchar[2]" "audio-format" } + { "uchar[2]" "num-channels" } + { "uchar[4]" "sample-rate" } + { "uchar[4]" "byte-rate" } + { "uchar[2]" "block-align" } + { "uchar[2]" "bits-per-sample" } + ; + +C-STRUCT: wav-data-chunk + { "riff-chunk-header" "header" } + { "uchar[0]" "body" } + ; + +ERROR: invalid-wav-file ; + +: ensured-read ( count -- output/f ) + [ read ] keep over length = [ drop f ] unless ; +: ensured-read* ( count -- output ) + ensured-read [ invalid-wav-file ] unless* ; + +: read-chunk ( -- byte-array/f ) + 4 ensured-read [ 4 ensured-read* dup le> ensured-read* 3append ] [ f ] if* ; +: read-riff-chunk ( -- byte-array/f ) + "riff-chunk" heap-size ensured-read* ; + +: id= ( chunk id -- ? ) + [ 4 head ] dip sequence= ; + +: check-chunk ( chunk id min-size -- ? ) + [ id= ] [ [ length ] dip >= ] bi-curry* bi and ; + +:: read-wav-chunks ( -- fmt data ) + f :> fmt! f :> data! + [ { [ fmt data and not ] [ read-chunk ] } 0&& dup ] + [ { + { [ dup FMT-MAGIC "wav-fmt-chunk" heap-size check-chunk ] [ fmt! ] } + { [ dup DATA-MAGIC "wav-data-chunk" heap-size check-chunk ] [ data! ] } + } cond ] while drop + fmt data 2dup and [ invalid-wav-file ] unless ; + +: verify-wav ( chunk -- ) + { + [ RIFF-MAGIC id= ] + [ riff-chunk-format 4 memory>byte-array WAVE-MAGIC id= ] + } 1&& + [ invalid-wav-file ] unless ; + +: (read-wav) ( -- audio ) + read-wav-chunks + [ + [ wav-fmt-chunk-num-channels 2 memory>byte-array le> ] + [ wav-fmt-chunk-bits-per-sample 2 memory>byte-array le> ] + [ wav-fmt-chunk-sample-rate 4 memory>byte-array le> ] tri + ] [ + [ riff-chunk-header-size 4 memory>byte-array le> dup ] + [ wav-data-chunk-body ] bi swap memory>byte-array + ] bi* ";if(T.firstChild&&typeof T.firstChild.getAttribute!=="undefined"&&T.firstChild.getAttribute("href")!=="#"){I.attrHandle.href=function(U){return U.getAttribute("href",2)}}})();if(document.querySelectorAll){(function(){var T=F,U=document.createElement("div");U.innerHTML="

";if(U.querySelectorAll&&U.querySelectorAll(".TEST").length===0){return}F=function(Y,X,V,W){X=X||document;if(!W&&X.nodeType===9&&!Q(X)){try{return E(X.querySelectorAll(Y),V)}catch(Z){}}return T(Y,X,V,W)};F.find=T.find;F.filter=T.filter;F.selectors=T.selectors;F.matches=T.matches})()}if(document.getElementsByClassName&&document.documentElement.getElementsByClassName){(function(){var T=document.createElement("div");T.innerHTML="
";if(T.getElementsByClassName("e").length===0){return}T.lastChild.className="e";if(T.getElementsByClassName("e").length===1){return}I.order.splice(1,0,"CLASS");I.find.CLASS=function(U,V,W){if(typeof V.getElementsByClassName!=="undefined"&&!W){return V.getElementsByClassName(U[1])}}})()}function P(U,Z,Y,ad,aa,ac){var ab=U=="previousSibling"&&!ac;for(var W=0,V=ad.length;W0){X=T;break}}}T=T[U]}ad[W]=X}}}var K=document.compareDocumentPosition?function(U,T){return U.compareDocumentPosition(T)&16}:function(U,T){return U!==T&&(U.contains?U.contains(T):true)};var Q=function(T){return T.nodeType===9&&T.documentElement.nodeName!=="HTML"||!!T.ownerDocument&&Q(T.ownerDocument)};var J=function(T,aa){var W=[],X="",Y,V=aa.nodeType?[aa]:aa;while((Y=I.match.PSEUDO.exec(T))){X+=Y[0];T=T.replace(I.match.PSEUDO,"")}T=I.relative[T]?T+"*":T;for(var Z=0,U=V.length;Z0||T.offsetHeight>0};F.selectors.filters.animated=function(T){return o.grep(o.timers,function(U){return T===U.elem}).length};o.multiFilter=function(V,T,U){if(U){V=":not("+V+")"}return F.matches(V,T)};o.dir=function(V,U){var T=[],W=V[U];while(W&&W!=document){if(W.nodeType==1){T.push(W)}W=W[U]}return T};o.nth=function(X,T,V,W){T=T||1;var U=0;for(;X;X=X[V]){if(X.nodeType==1&&++U==T){break}}return X};o.sibling=function(V,U){var T=[];for(;V;V=V.nextSibling){if(V.nodeType==1&&V!=U){T.push(V)}}return T};return;l.Sizzle=F})();o.event={add:function(I,F,H,K){if(I.nodeType==3||I.nodeType==8){return}if(I.setInterval&&I!=l){I=l}if(!H.guid){H.guid=this.guid++}if(K!==g){var G=H;H=this.proxy(G);H.data=K}var E=o.data(I,"events")||o.data(I,"events",{}),J=o.data(I,"handle")||o.data(I,"handle",function(){return typeof o!=="undefined"&&!o.event.triggered?o.event.handle.apply(arguments.callee.elem,arguments):g});J.elem=I;o.each(F.split(/\s+/),function(M,N){var O=N.split(".");N=O.shift();H.type=O.slice().sort().join(".");var L=E[N];if(o.event.specialAll[N]){o.event.specialAll[N].setup.call(I,K,O)}if(!L){L=E[N]={};if(!o.event.special[N]||o.event.special[N].setup.call(I,K,O)===false){if(I.addEventListener){I.addEventListener(N,J,false)}else{if(I.attachEvent){I.attachEvent("on"+N,J)}}}}L[H.guid]=H;o.event.global[N]=true});I=null},guid:1,global:{},remove:function(K,H,J){if(K.nodeType==3||K.nodeType==8){return}var G=o.data(K,"events"),F,E;if(G){if(H===g||(typeof H==="string"&&H.charAt(0)==".")){for(var I in G){this.remove(K,I+(H||""))}}else{if(H.type){J=H.handler;H=H.type}o.each(H.split(/\s+/),function(M,O){var Q=O.split(".");O=Q.shift();var N=RegExp("(^|\\.)"+Q.slice().sort().join(".*\\.")+"(\\.|$)");if(G[O]){if(J){delete G[O][J.guid]}else{for(var P in G[O]){if(N.test(G[O][P].type)){delete G[O][P]}}}if(o.event.specialAll[O]){o.event.specialAll[O].teardown.call(K,Q)}for(F in G[O]){break}if(!F){if(!o.event.special[O]||o.event.special[O].teardown.call(K,Q)===false){if(K.removeEventListener){K.removeEventListener(O,o.data(K,"handle"),false)}else{if(K.detachEvent){K.detachEvent("on"+O,o.data(K,"handle"))}}}F=null;delete G[O]}}})}for(F in G){break}if(!F){var L=o.data(K,"handle");if(L){L.elem=null}o.removeData(K,"events");o.removeData(K,"handle")}}},trigger:function(I,K,H,E){var G=I.type||I;if(!E){I=typeof I==="object"?I[h]?I:o.extend(o.Event(G),I):o.Event(G);if(G.indexOf("!")>=0){I.type=G=G.slice(0,-1);I.exclusive=true}if(!H){I.stopPropagation();if(this.global[G]){o.each(o.cache,function(){if(this.events&&this.events[G]){o.event.trigger(I,K,this.handle.elem)}})}}if(!H||H.nodeType==3||H.nodeType==8){return g}I.result=g;I.target=H;K=o.makeArray(K);K.unshift(I)}I.currentTarget=H;var J=o.data(H,"handle");if(J){J.apply(H,K)}if((!H[G]||(o.nodeName(H,"a")&&G=="click"))&&H["on"+G]&&H["on"+G].apply(H,K)===false){I.result=false}if(!E&&H[G]&&!I.isDefaultPrevented()&&!(o.nodeName(H,"a")&&G=="click")){this.triggered=true;try{H[G]()}catch(L){}}this.triggered=false;if(!I.isPropagationStopped()){var F=H.parentNode||H.ownerDocument;if(F){o.event.trigger(I,K,F,true)}}},handle:function(K){var J,E;K=arguments[0]=o.event.fix(K||l.event);K.currentTarget=this;var L=K.type.split(".");K.type=L.shift();J=!L.length&&!K.exclusive;var I=RegExp("(^|\\.)"+L.slice().sort().join(".*\\.")+"(\\.|$)");E=(o.data(this,"events")||{})[K.type];for(var G in E){var H=E[G];if(J||I.test(H.type)){K.handler=H;K.data=H.data;var F=H.apply(this,arguments);if(F!==g){K.result=F;if(F===false){K.preventDefault();K.stopPropagation()}}if(K.isImmediatePropagationStopped()){break}}}},props:"altKey attrChange attrName bubbles button cancelable charCode clientX clientY ctrlKey currentTarget data detail eventPhase fromElement handler keyCode metaKey newValue originalTarget pageX pageY prevValue relatedNode relatedTarget screenX screenY shiftKey srcElement target toElement view wheelDelta which".split(" "),fix:function(H){if(H[h]){return H}var F=H;H=o.Event(F);for(var G=this.props.length,J;G;){J=this.props[--G];H[J]=F[J]}if(!H.target){H.target=H.srcElement||document}if(H.target.nodeType==3){H.target=H.target.parentNode}if(!H.relatedTarget&&H.fromElement){H.relatedTarget=H.fromElement==H.target?H.toElement:H.fromElement}if(H.pageX==null&&H.clientX!=null){var I=document.documentElement,E=document.body;H.pageX=H.clientX+(I&&I.scrollLeft||E&&E.scrollLeft||0)-(I.clientLeft||0);H.pageY=H.clientY+(I&&I.scrollTop||E&&E.scrollTop||0)-(I.clientTop||0)}if(!H.which&&((H.charCode||H.charCode===0)?H.charCode:H.keyCode)){H.which=H.charCode||H.keyCode}if(!H.metaKey&&H.ctrlKey){H.metaKey=H.ctrlKey}if(!H.which&&H.button){H.which=(H.button&1?1:(H.button&2?3:(H.button&4?2:0)))}return H},proxy:function(F,E){E=E||function(){return F.apply(this,arguments)};E.guid=F.guid=F.guid||E.guid||this.guid++;return E},special:{ready:{setup:B,teardown:function(){}}},specialAll:{live:{setup:function(E,F){o.event.add(this,F[0],c)},teardown:function(G){if(G.length){var E=0,F=RegExp("(^|\\.)"+G[0]+"(\\.|$)");o.each((o.data(this,"events").live||{}),function(){if(F.test(this.type)){E++}});if(E<1){o.event.remove(this,G[0],c)}}}}}};o.Event=function(E){if(!this.preventDefault){return new o.Event(E)}if(E&&E.type){this.originalEvent=E;this.type=E.type}else{this.type=E}this.timeStamp=e();this[h]=true};function k(){return false}function u(){return true}o.Event.prototype={preventDefault:function(){this.isDefaultPrevented=u;var E=this.originalEvent;if(!E){return}if(E.preventDefault){E.preventDefault()}E.returnValue=false},stopPropagation:function(){this.isPropagationStopped=u;var E=this.originalEvent;if(!E){return}if(E.stopPropagation){E.stopPropagation()}E.cancelBubble=true},stopImmediatePropagation:function(){this.isImmediatePropagationStopped=u;this.stopPropagation()},isDefaultPrevented:k,isPropagationStopped:k,isImmediatePropagationStopped:k};var a=function(F){var E=F.relatedTarget;while(E&&E!=this){try{E=E.parentNode}catch(G){E=this}}if(E!=this){F.type=F.data;o.event.handle.apply(this,arguments)}};o.each({mouseover:"mouseenter",mouseout:"mouseleave"},function(F,E){o.event.special[E]={setup:function(){o.event.add(this,F,a,E)},teardown:function(){o.event.remove(this,F,a)}}});o.fn.extend({bind:function(F,G,E){return F=="unload"?this.one(F,G,E):this.each(function(){o.event.add(this,F,E||G,E&&G)})},one:function(G,H,F){var E=o.event.proxy(F||H,function(I){o(this).unbind(I,E);return(F||H).apply(this,arguments)});return this.each(function(){o.event.add(this,G,E,F&&H)})},unbind:function(F,E){return this.each(function(){o.event.remove(this,F,E)})},trigger:function(E,F){return this.each(function(){o.event.trigger(E,F,this)})},triggerHandler:function(E,G){if(this[0]){var F=o.Event(E);F.preventDefault();F.stopPropagation();o.event.trigger(F,G,this[0]);return F.result}},toggle:function(G){var E=arguments,F=1;while(F=0){var E=G.slice(I,G.length);G=G.slice(0,I)}var H="GET";if(J){if(o.isFunction(J)){K=J;J=null}else{if(typeof J==="object"){J=o.param(J);H="POST"}}}var F=this;o.ajax({url:G,type:H,dataType:"html",data:J,complete:function(M,L){if(L=="success"||L=="notmodified"){F.html(E?o("
").append(M.responseText.replace(//g,"")).find(E):M.responseText)}if(K){F.each(K,[M.responseText,L,M])}}});return this},serialize:function(){return o.param(this.serializeArray())},serializeArray:function(){return this.map(function(){return this.elements?o.makeArray(this.elements):this}).filter(function(){return this.name&&!this.disabled&&(this.checked||/select|textarea/i.test(this.nodeName)||/text|hidden|password|search/i.test(this.type))}).map(function(E,F){var G=o(this).val();return G==null?null:o.isArray(G)?o.map(G,function(I,H){return{name:F.name,value:I}}):{name:F.name,value:G}}).get()}});o.each("ajaxStart,ajaxStop,ajaxComplete,ajaxError,ajaxSuccess,ajaxSend".split(","),function(E,F){o.fn[F]=function(G){return this.bind(F,G)}});var r=e();o.extend({get:function(E,G,H,F){if(o.isFunction(G)){H=G;G=null}return o.ajax({type:"GET",url:E,data:G,success:H,dataType:F})},getScript:function(E,F){return o.get(E,null,F,"script")},getJSON:function(E,F,G){return o.get(E,F,G,"json")},post:function(E,G,H,F){if(o.isFunction(G)){H=G;G={}}return o.ajax({type:"POST",url:E,data:G,success:H,dataType:F})},ajaxSetup:function(E){o.extend(o.ajaxSettings,E)},ajaxSettings:{url:location.href,global:true,type:"GET",contentType:"application/x-www-form-urlencoded",processData:true,async:true,xhr:function(){return l.ActiveXObject?new ActiveXObject("Microsoft.XMLHTTP"):new XMLHttpRequest()},accepts:{xml:"application/xml, text/xml",html:"text/html",script:"text/javascript, application/javascript",json:"application/json, text/javascript",text:"text/plain",_default:"*/*"}},lastModified:{},ajax:function(M){M=o.extend(true,M,o.extend(true,{},o.ajaxSettings,M));var W,F=/=\?(&|$)/g,R,V,G=M.type.toUpperCase();if(M.data&&M.processData&&typeof M.data!=="string"){M.data=o.param(M.data)}if(M.dataType=="jsonp"){if(G=="GET"){if(!M.url.match(F)){M.url+=(M.url.match(/\?/)?"&":"?")+(M.jsonp||"callback")+"=?"}}else{if(!M.data||!M.data.match(F)){M.data=(M.data?M.data+"&":"")+(M.jsonp||"callback")+"=?"}}M.dataType="json"}if(M.dataType=="json"&&(M.data&&M.data.match(F)||M.url.match(F))){W="jsonp"+r++;if(M.data){M.data=(M.data+"").replace(F,"="+W+"$1")}M.url=M.url.replace(F,"="+W+"$1");M.dataType="script";l[W]=function(X){V=X;I();L();l[W]=g;try{delete l[W]}catch(Y){}if(H){H.removeChild(T)}}}if(M.dataType=="script"&&M.cache==null){M.cache=false}if(M.cache===false&&G=="GET"){var E=e();var U=M.url.replace(/(\?|&)_=.*?(&|$)/,"$1_="+E+"$2");M.url=U+((U==M.url)?(M.url.match(/\?/)?"&":"?")+"_="+E:"")}if(M.data&&G=="GET"){M.url+=(M.url.match(/\?/)?"&":"?")+M.data;M.data=null}if(M.global&&!o.active++){o.event.trigger("ajaxStart")}var Q=/^(\w+:)?\/\/([^\/?#]+)/.exec(M.url);if(M.dataType=="script"&&G=="GET"&&Q&&(Q[1]&&Q[1]!=location.protocol||Q[2]!=location.host)){var H=document.getElementsByTagName("head")[0];var T=document.createElement("script");T.src=M.url;if(M.scriptCharset){T.charset=M.scriptCharset}if(!W){var O=false;T.onload=T.onreadystatechange=function(){if(!O&&(!this.readyState||this.readyState=="loaded"||this.readyState=="complete")){O=true;I();L();T.onload=T.onreadystatechange=null;H.removeChild(T)}}}H.appendChild(T);return g}var K=false;var J=M.xhr();if(M.username){J.open(G,M.url,M.async,M.username,M.password)}else{J.open(G,M.url,M.async)}try{if(M.data){J.setRequestHeader("Content-Type",M.contentType)}if(M.ifModified){J.setRequestHeader("If-Modified-Since",o.lastModified[M.url]||"Thu, 01 Jan 1970 00:00:00 GMT")}J.setRequestHeader("X-Requested-With","XMLHttpRequest");J.setRequestHeader("Accept",M.dataType&&M.accepts[M.dataType]?M.accepts[M.dataType]+", */*":M.accepts._default)}catch(S){}if(M.beforeSend&&M.beforeSend(J,M)===false){if(M.global&&!--o.active){o.event.trigger("ajaxStop")}J.abort();return false}if(M.global){o.event.trigger("ajaxSend",[J,M])}var N=function(X){if(J.readyState==0){if(P){clearInterval(P);P=null;if(M.global&&!--o.active){o.event.trigger("ajaxStop")}}}else{if(!K&&J&&(J.readyState==4||X=="timeout")){K=true;if(P){clearInterval(P);P=null}R=X=="timeout"?"timeout":!o.httpSuccess(J)?"error":M.ifModified&&o.httpNotModified(J,M.url)?"notmodified":"success";if(R=="success"){try{V=o.httpData(J,M.dataType,M)}catch(Z){R="parsererror"}}if(R=="success"){var Y;try{Y=J.getResponseHeader("Last-Modified")}catch(Z){}if(M.ifModified&&Y){o.lastModified[M.url]=Y}if(!W){I()}}else{o.handleError(M,J,R)}L();if(X){J.abort()}if(M.async){J=null}}}};if(M.async){var P=setInterval(N,13);if(M.timeout>0){setTimeout(function(){if(J&&!K){N("timeout")}},M.timeout)}}try{J.send(M.data)}catch(S){o.handleError(M,J,null,S)}if(!M.async){N()}function I(){if(M.success){M.success(V,R)}if(M.global){o.event.trigger("ajaxSuccess",[J,M])}}function L(){if(M.complete){M.complete(J,R)}if(M.global){o.event.trigger("ajaxComplete",[J,M])}if(M.global&&!--o.active){o.event.trigger("ajaxStop")}}return J},handleError:function(F,H,E,G){if(F.error){F.error(H,E,G)}if(F.global){o.event.trigger("ajaxError",[H,F,G])}},active:0,httpSuccess:function(F){try{return !F.status&&location.protocol=="file:"||(F.status>=200&&F.status<300)||F.status==304||F.status==1223}catch(E){}return false},httpNotModified:function(G,E){try{var H=G.getResponseHeader("Last-Modified");return G.status==304||H==o.lastModified[E]}catch(F){}return false},httpData:function(J,H,G){var F=J.getResponseHeader("content-type"),E=H=="xml"||!H&&F&&F.indexOf("xml")>=0,I=E?J.responseXML:J.responseText;if(E&&I.documentElement.tagName=="parsererror"){throw"parsererror"}if(G&&G.dataFilter){I=G.dataFilter(I,H)}if(typeof I==="string"){if(H=="script"){o.globalEval(I)}if(H=="json"){I=l["eval"]("("+I+")")}}return I},param:function(E){var G=[];function H(I,J){G[G.length]=encodeURIComponent(I)+"="+encodeURIComponent(J)}if(o.isArray(E)||E.jquery){o.each(E,function(){H(this.name,this.value)})}else{for(var F in E){if(o.isArray(E[F])){o.each(E[F],function(){H(F,this)})}else{H(F,o.isFunction(E[F])?E[F]():E[F])}}}return G.join("&").replace(/%20/g,"+")}});var m={},n,d=[["height","marginTop","marginBottom","paddingTop","paddingBottom"],["width","marginLeft","marginRight","paddingLeft","paddingRight"],["opacity"]];function t(F,E){var G={};o.each(d.concat.apply([],d.slice(0,E)),function(){G[this]=F});return G}o.fn.extend({show:function(J,L){if(J){return this.animate(t("show",3),J,L)}else{for(var H=0,F=this.length;H").appendTo("body");K=I.css("display");if(K==="none"){K="block"}I.remove();m[G]=K}o.data(this[H],"olddisplay",K)}}for(var H=0,F=this.length;H=0;H--){if(G[H].elem==this){if(E){G[H](true)}G.splice(H,1)}}});if(!E){this.dequeue()}return this}});o.each({slideDown:t("show",1),slideUp:t("hide",1),slideToggle:t("toggle",1),fadeIn:{opacity:"show"},fadeOut:{opacity:"hide"}},function(E,F){o.fn[E]=function(G,H){return this.animate(F,G,H)}});o.extend({speed:function(G,H,F){var E=typeof G==="object"?G:{complete:F||!F&&H||o.isFunction(G)&&G,duration:G,easing:F&&H||H&&!o.isFunction(H)&&H};E.duration=o.fx.off?0:typeof E.duration==="number"?E.duration:o.fx.speeds[E.duration]||o.fx.speeds._default;E.old=E.complete;E.complete=function(){if(E.queue!==false){o(this).dequeue()}if(o.isFunction(E.old)){E.old.call(this)}};return E},easing:{linear:function(G,H,E,F){return E+F*G},swing:function(G,H,E,F){return((-Math.cos(G*Math.PI)/2)+0.5)*F+E}},timers:[],fx:function(F,E,G){this.options=E;this.elem=F;this.prop=G;if(!E.orig){E.orig={}}}});o.fx.prototype={update:function(){if(this.options.step){this.options.step.call(this.elem,this.now,this)}(o.fx.step[this.prop]||o.fx.step._default)(this);if((this.prop=="height"||this.prop=="width")&&this.elem.style){this.elem.style.display="block"}},cur:function(F){if(this.elem[this.prop]!=null&&(!this.elem.style||this.elem.style[this.prop]==null)){return this.elem[this.prop]}var E=parseFloat(o.css(this.elem,this.prop,F));return E&&E>-10000?E:parseFloat(o.curCSS(this.elem,this.prop))||0},custom:function(I,H,G){this.startTime=e();this.start=I;this.end=H;this.unit=G||this.unit||"px";this.now=this.start;this.pos=this.state=0;var E=this;function F(J){return E.step(J)}F.elem=this.elem;if(F()&&o.timers.push(F)&&!n){n=setInterval(function(){var K=o.timers;for(var J=0;J=this.options.duration+this.startTime){this.now=this.end;this.pos=this.state=1;this.update();this.options.curAnim[this.prop]=true;var E=true;for(var F in this.options.curAnim){if(this.options.curAnim[F]!==true){E=false}}if(E){if(this.options.display!=null){this.elem.style.overflow=this.options.overflow;this.elem.style.display=this.options.display;if(o.css(this.elem,"display")=="none"){this.elem.style.display="block"}}if(this.options.hide){o(this.elem).hide()}if(this.options.hide||this.options.show){for(var I in this.options.curAnim){o.attr(this.elem.style,I,this.options.orig[I])}}this.options.complete.call(this.elem)}return false}else{var J=G-this.startTime;this.state=J/this.options.duration;this.pos=o.easing[this.options.easing||(o.easing.swing?"swing":"linear")](this.state,J,0,1,this.options.duration);this.now=this.start+((this.end-this.start)*this.pos);this.update()}return true}};o.extend(o.fx,{speeds:{slow:600,fast:200,_default:400},step:{opacity:function(E){o.attr(E.elem.style,"opacity",E.now)},_default:function(E){if(E.elem.style&&E.elem.style[E.prop]!=null){E.elem.style[E.prop]=E.now+E.unit}else{E.elem[E.prop]=E.now}}}});if(document.documentElement.getBoundingClientRect){o.fn.offset=function(){if(!this[0]){return{top:0,left:0}}if(this[0]===this[0].ownerDocument.body){return o.offset.bodyOffset(this[0])}var G=this[0].getBoundingClientRect(),J=this[0].ownerDocument,F=J.body,E=J.documentElement,L=E.clientTop||F.clientTop||0,K=E.clientLeft||F.clientLeft||0,I=G.top+(self.pageYOffset||o.boxModel&&E.scrollTop||F.scrollTop)-L,H=G.left+(self.pageXOffset||o.boxModel&&E.scrollLeft||F.scrollLeft)-K;return{top:I,left:H}}}else{o.fn.offset=function(){if(!this[0]){return{top:0,left:0}}if(this[0]===this[0].ownerDocument.body){return o.offset.bodyOffset(this[0])}o.offset.initialized||o.offset.initialize();var J=this[0],G=J.offsetParent,F=J,O=J.ownerDocument,M,H=O.documentElement,K=O.body,L=O.defaultView,E=L.getComputedStyle(J,null),N=J.offsetTop,I=J.offsetLeft;while((J=J.parentNode)&&J!==K&&J!==H){M=L.getComputedStyle(J,null);N-=J.scrollTop,I-=J.scrollLeft;if(J===G){N+=J.offsetTop,I+=J.offsetLeft;if(o.offset.doesNotAddBorder&&!(o.offset.doesAddBorderForTableAndCells&&/^t(able|d|h)$/i.test(J.tagName))){N+=parseInt(M.borderTopWidth,10)||0,I+=parseInt(M.borderLeftWidth,10)||0}F=G,G=J.offsetParent}if(o.offset.subtractsBorderForOverflowNotVisible&&M.overflow!=="visible"){N+=parseInt(M.borderTopWidth,10)||0,I+=parseInt(M.borderLeftWidth,10)||0}E=M}if(E.position==="relative"||E.position==="static"){N+=K.offsetTop,I+=K.offsetLeft}if(E.position==="fixed"){N+=Math.max(H.scrollTop,K.scrollTop),I+=Math.max(H.scrollLeft,K.scrollLeft)}return{top:N,left:I}}}o.offset={initialize:function(){if(this.initialized){return}var L=document.body,F=document.createElement("div"),H,G,N,I,M,E,J=L.style.marginTop,K='
';M={position:"absolute",top:0,left:0,margin:0,border:0,width:"1px",height:"1px",visibility:"hidden"};for(E in M){F.style[E]=M[E]}F.innerHTML=K;L.insertBefore(F,L.firstChild);H=F.firstChild,G=H.firstChild,I=H.nextSibling.firstChild.firstChild;this.doesNotAddBorder=(G.offsetTop!==5);this.doesAddBorderForTableAndCells=(I.offsetTop===5);H.style.overflow="hidden",H.style.position="relative";this.subtractsBorderForOverflowNotVisible=(G.offsetTop===-5);L.style.marginTop="1px";this.doesNotIncludeMarginInBodyOffset=(L.offsetTop===0);L.style.marginTop=J;L.removeChild(F);this.initialized=true},bodyOffset:function(E){o.offset.initialized||o.offset.initialize();var G=E.offsetTop,F=E.offsetLeft;if(o.offset.doesNotIncludeMarginInBodyOffset){G+=parseInt(o.curCSS(E,"marginTop",true),10)||0,F+=parseInt(o.curCSS(E,"marginLeft",true),10)||0}return{top:G,left:F}}};o.fn.extend({position:function(){var I=0,H=0,F;if(this[0]){var G=this.offsetParent(),J=this.offset(),E=/^body|html$/i.test(G[0].tagName)?{top:0,left:0}:G.offset();J.top-=j(this,"marginTop");J.left-=j(this,"marginLeft");E.top+=j(G,"borderTopWidth");E.left+=j(G,"borderLeftWidth");F={top:J.top-E.top,left:J.left-E.left}}return F},offsetParent:function(){var E=this[0].offsetParent||document.body;while(E&&(!/^body|html$/i.test(E.tagName)&&o.css(E,"position")=="static")){E=E.offsetParent}return o(E)}});o.each(["Left","Top"],function(F,E){var G="scroll"+E;o.fn[G]=function(H){if(!this[0]){return null}return H!==g?this.each(function(){this==l||this==document?l.scrollTo(!F?H:o(l).scrollLeft(),F?H:o(l).scrollTop()):this[G]=H}):this[0]==l||this[0]==document?self[F?"pageYOffset":"pageXOffset"]||o.boxModel&&document.documentElement[G]||document.body[G]:this[0][G]}});o.each(["Height","Width"],function(I,G){var E=I?"Left":"Top",H=I?"Right":"Bottom",F=G.toLowerCase();o.fn["inner"+G]=function(){return this[0]?o.css(this[0],F,false,"padding"):null};o.fn["outer"+G]=function(K){return this[0]?o.css(this[0],F,false,K?"margin":"border"):null};var J=G.toLowerCase();o.fn[J]=function(K){return this[0]==l?document.compatMode=="CSS1Compat"&&document.documentElement["client"+G]||document.body["client"+G]:this[0]==document?Math.max(document.documentElement["client"+G],document.body["scroll"+G],document.documentElement["scroll"+G],document.body["offset"+G],document.documentElement["offset"+G]):K===g?(this.length?o.css(this[0],J):null):this.css(J,typeof K==="string"?K:K+"px")}})})(); \ No newline at end of file diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor index 5030cb6904..de60049c84 100644 --- a/extra/benchmark/md5/md5.factor +++ b/extra/benchmark/md5/md5.factor @@ -1,7 +1,7 @@ -USING: checksums checksums.md5 io.files kernel ; +USING: checksums checksums.md5 sequences byte-arrays kernel ; IN: benchmark.md5 : md5-file ( -- ) - "vocab:mime/multipart/multipart-tests.factor" md5 checksum-file drop ; + 2000000 iota >byte-array md5 checksum-bytes drop ; MAIN: md5-file diff --git a/extra/benchmark/pidigits/authors.txt b/extra/benchmark/pidigits/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/benchmark/pidigits/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor new file mode 100644 index 0000000000..5de5cc5e99 --- /dev/null +++ b/extra/benchmark/pidigits/pidigits.factor @@ -0,0 +1,59 @@ +! Copyright (c) 2009 Aaron Schaefer. All rights reserved. +! The contents of this file are licensed under the Simplified BSD License +! A copy of the license is available at http://factorcode.org/license.txt +USING: arrays formatting fry grouping io kernel locals math math.functions + math.matrices math.parser math.primes.factors math.vectors prettyprint + sequences sequences.deep sets ; +IN: benchmark.pidigits + +: extract ( z x -- n ) + 1 2array '[ _ v* sum ] map first2 /i ; + +: next ( z -- n ) + 3 extract ; + +: safe? ( z n -- ? ) + [ 4 extract ] dip = ; + +: >matrix ( q s r t -- z ) + 4array 2 group ; + +: produce ( z n -- z' ) + [ 10 ] dip -10 * 0 1 >matrix swap m. ; + +: gen-x ( x -- matrix ) + dup 2 * 1 + [ 2 * 0 ] keep >matrix ; + +: consume ( z k -- z' ) + gen-x m. ; + +:: (padded-total) ( row col -- str n format ) + "" row col + "%" "s\t:%d\n" + 10 col - number>string glue ; + +: padded-total ( row col -- ) + (padded-total) '[ _ printf ] call( str n -- ) ; + +:: (pidigits) ( k z n row col -- ) + n 0 > [ + z next :> y + z y safe? [ + col 10 = [ + row 10 + y "\t:%d\n%d" printf + k z y produce n 1 - row 10 + 1 (pidigits) + ] [ + y number>string write + k z y produce n 1 - row col 1 + (pidigits) + ] if + ] [ + k 1 + z k consume n row col (pidigits) + ] if + ] [ row col padded-total ] if ; + +: pidigits ( n -- ) + [ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ; + +: pidigits-main ( -- ) + 10000 pidigits ; + +MAIN: pidigits-main diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor index d2eb4cdab5..4eab7c1669 100755 --- a/extra/benchmark/random/random.factor +++ b/extra/benchmark/random/random.factor @@ -11,6 +11,6 @@ IN: benchmark.random ] with-file-writer ; : random-main ( -- ) - 1000000 write-random-numbers ; + 300000 write-random-numbers ; MAIN: random-main diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index a4df1fe04d..642b3dbb93 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -53,7 +53,7 @@ C: sphere : sphere-t ( b d -- t ) -+ dup 0.0 < - [ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline + [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline : sphere-b&v ( sphere ray -- b v ) [ sphere-v ] [ nip ] 2bi diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor index 8e19ba9a8f..c1a7af2966 100644 --- a/extra/benchmark/sha1/sha1.factor +++ b/extra/benchmark/sha1/sha1.factor @@ -1,7 +1,7 @@ -USING: checksums checksums.sha1 io.files kernel ; +USING: checksums checksums.sha1 sequences byte-arrays kernel ; IN: benchmark.sha1 : sha1-file ( -- ) - "vocab:mime/multipart/multipart-tests.factor" sha1 checksum-file drop ; + 2000000 iota >byte-array sha1 checksum-bytes drop ; MAIN: sha1-file diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor index bb7aebba62..b1f27830ee 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/extra/benchmark/sum-file/sum-file.factor @@ -9,6 +9,6 @@ IN: benchmark.sum-file ascii [ 0 sum-file-loop ] with-file-reader . ; : sum-file-main ( -- ) - random-numbers-path sum-file ; + 5 [ random-numbers-path sum-file ] times ; MAIN: sum-file-main diff --git a/extra/benchmark/tuple-arrays/authors.txt b/extra/benchmark/tuple-arrays/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/tuple-arrays/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor new file mode 100644 index 0000000000..483311d4f4 --- /dev/null +++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions tuple-arrays accessors fry sequences +prettyprint ; +IN: benchmark.tuple-arrays + +TUPLE: point { x float } { y float } { z float } ; + +TUPLE-ARRAY: point + +: tuple-array-benchmark ( -- ) + 100 [ + drop 5000 [ + [ 1+ ] change-x + [ 1- ] change-y + [ 1+ 2 / ] change-z + ] map [ z>> ] sigma + ] sigma . ; + +MAIN: tuple-array-benchmark \ No newline at end of file diff --git a/extra/benchmark/typecheck3/typecheck3.factor b/extra/benchmark/typecheck3/typecheck3.factor index c4887c03c4..fccd80a607 100644 --- a/extra/benchmark/typecheck3/typecheck3.factor +++ b/extra/benchmark/typecheck3/typecheck3.factor @@ -3,7 +3,7 @@ IN: benchmark.typecheck3 TUPLE: hello n ; -: hello-n* ( obj -- val ) dup tag 2 eq? [ 2 slot ] [ 3 throw ] if ; +: hello-n* ( obj -- val ) 2 slot ; : foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ; diff --git a/extra/benchmark/typecheck4/typecheck4.factor b/extra/benchmark/typecheck4/typecheck4.factor deleted file mode 100644 index c881864304..0000000000 --- a/extra/benchmark/typecheck4/typecheck4.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: math kernel kernel.private slots.private ; -IN: benchmark.typecheck4 - -TUPLE: hello n ; - -: hello-n* ( obj -- val ) 2 slot ; - -: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ; - -: typecheck-main ( -- ) 0 hello boa foo 2drop ; - -MAIN: typecheck-main diff --git a/extra/bson/authors.txt b/extra/bson/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/bson/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/bson/bson.factor b/extra/bson/bson.factor new file mode 100644 index 0000000000..a97b5029b0 --- /dev/null +++ b/extra/bson/bson.factor @@ -0,0 +1,6 @@ +USING: vocabs.loader ; + +IN: bson + +"bson.reader" require +"bson.writer" require diff --git a/extra/bson/constants/authors.txt b/extra/bson/constants/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/bson/constants/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/bson/constants/constants.factor b/extra/bson/constants/constants.factor new file mode 100644 index 0000000000..5148413b61 --- /dev/null +++ b/extra/bson/constants/constants.factor @@ -0,0 +1,49 @@ +USING: accessors constructors kernel strings uuid ; + +IN: bson.constants + +: ( -- objid ) + uuid1 ; inline + +TUPLE: oid { a initial: 0 } { b initial: 0 } ; + +TUPLE: objref ns objid ; + +CONSTRUCTOR: objref ( ns objid -- objref ) ; + +TUPLE: mdbregexp { regexp string } { options string } ; + +: ( string -- mdbregexp ) + [ mdbregexp new ] dip >>regexp ; + + +CONSTANT: MDB_OID_FIELD "_id" +CONSTANT: MDB_META_FIELD "_mfd" + +CONSTANT: T_EOO 0 +CONSTANT: T_Double 1 +CONSTANT: T_Integer 16 +CONSTANT: T_Boolean 8 +CONSTANT: T_String 2 +CONSTANT: T_Object 3 +CONSTANT: T_Array 4 +CONSTANT: T_Binary 5 +CONSTANT: T_Undefined 6 +CONSTANT: T_OID 7 +CONSTANT: T_Date 9 +CONSTANT: T_NULL 10 +CONSTANT: T_Regexp 11 +CONSTANT: T_DBRef 12 +CONSTANT: T_Code 13 +CONSTANT: T_ScopedCode 17 +CONSTANT: T_Symbol 14 +CONSTANT: T_JSTypeMax 16 +CONSTANT: T_MaxKey 127 + +CONSTANT: T_Binary_Function 1 +CONSTANT: T_Binary_Bytes 2 +CONSTANT: T_Binary_UUID 3 +CONSTANT: T_Binary_MD5 5 +CONSTANT: T_Binary_Custom 128 + + diff --git a/extra/bson/constants/summary.txt b/extra/bson/constants/summary.txt new file mode 100644 index 0000000000..11b05920ef --- /dev/null +++ b/extra/bson/constants/summary.txt @@ -0,0 +1 @@ +Shared constants and classes diff --git a/extra/bson/reader/authors.txt b/extra/bson/reader/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/bson/reader/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor new file mode 100644 index 0000000000..96cde41c2b --- /dev/null +++ b/extra/bson/reader/reader.factor @@ -0,0 +1,200 @@ +USING: accessors assocs bson.constants byte-arrays byte-vectors fry io +io.binary io.encodings.string io.encodings.utf8 kernel math namespaces +sequences serialize arrays calendar io.encodings ; + +IN: bson.reader + + ( exemplar -- state ) + [ state new ] dip + [ clone >>exemplar ] keep + clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi + V{ } clone [ T_Object "" element boa swap push ] keep >>element ; + +PREDICATE: bson-eoo < integer T_EOO = ; +PREDICATE: bson-not-eoo < integer T_EOO > ; + +PREDICATE: bson-double < integer T_Double = ; +PREDICATE: bson-integer < integer T_Integer = ; +PREDICATE: bson-string < integer T_String = ; +PREDICATE: bson-object < integer T_Object = ; +PREDICATE: bson-array < integer T_Array = ; +PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-regexp < integer T_Regexp = ; +PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; +PREDICATE: bson-binary-function < integer T_Binary_Function = ; +PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ; +PREDICATE: bson-binary-custom < integer T_Binary_Custom = ; +PREDICATE: bson-oid < integer T_OID = ; +PREDICATE: bson-boolean < integer T_Boolean = ; +PREDICATE: bson-date < integer T_Date = ; +PREDICATE: bson-null < integer T_NULL = ; +PREDICATE: bson-ref < integer T_DBRef = ; + +GENERIC: element-read ( type -- cont? ) +GENERIC: element-data-read ( type -- object ) +GENERIC: element-binary-read ( length type -- object ) + +: byte-array>number ( seq -- number ) + byte-array>bignum >integer ; inline + +: get-state ( -- state ) + state get ; inline + +: count-bytes ( count -- ) + [ get-state ] dip '[ _ + ] change-read drop ; inline + +: read-int32 ( -- int32 ) + 4 [ read byte-array>number ] [ count-bytes ] bi ; inline + +: read-longlong ( -- longlong ) + 8 [ read byte-array>number ] [ count-bytes ] bi ; inline + +: read-double ( -- double ) + 8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline + +: read-byte-raw ( -- byte-raw ) + 1 [ read ] [ count-bytes ] bi ; inline + +: read-byte ( -- byte ) + read-byte-raw first ; inline + +: read-cstring ( -- string ) + input-stream get utf8 + "\0" swap stream-read-until drop ; inline + +: read-sized-string ( length -- string ) + drop read-cstring ; inline + +: read-element-type ( -- type ) + read-byte ; inline + +: push-element ( type name -- element ) + element boa + [ get-state element>> push ] keep ; inline + +: pop-element ( -- element ) + get-state element>> pop ; inline + +: peek-scope ( -- ht ) + get-state scope>> peek ; inline + +: read-elements ( -- ) + read-element-type + element-read + [ read-elements ] when ; inline recursive + +GENERIC: fix-result ( assoc type -- result ) + +M: bson-object fix-result ( assoc type -- result ) + drop ; + +M: bson-array fix-result ( assoc type -- result ) + drop + values ; + +GENERIC: end-element ( type -- ) + +M: bson-object end-element ( type -- ) + drop ; + +M: bson-array end-element ( type -- ) + drop ; + +M: object end-element ( type -- ) + drop + pop-element drop ; + +M: bson-eoo element-read ( type -- cont? ) + drop + get-state scope>> [ pop ] keep swap ! vec assoc + pop-element [ type>> ] keep ! vec assoc element + [ fix-result ] dip + rot length 0 > ! assoc element + [ name>> peek-scope set-at t ] + [ drop [ get-state ] dip >>result drop f ] if ; + +M: bson-not-eoo element-read ( type -- cont? ) + [ peek-scope ] dip ! scope type + '[ _ read-cstring push-element [ name>> ] [ type>> ] bi + [ element-data-read ] keep + end-element + swap + ] dip set-at t ; + +: [scope-changer] ( state -- state quot ) + dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline + +: (object-data-read) ( type -- object ) + drop + read-int32 drop + get-state + [scope-changer] change-scope + scope>> peek ; inline + +M: bson-object element-data-read ( type -- object ) + (object-data-read) ; + +M: bson-array element-data-read ( type -- object ) + (object-data-read) ; + +M: bson-string element-data-read ( type -- object ) + drop + read-int32 read-sized-string ; + +M: bson-integer element-data-read ( type -- object ) + drop + read-int32 ; + +M: bson-double element-data-read ( type -- double ) + drop + read-double ; + +M: bson-boolean element-data-read ( type -- boolean ) + drop + read-byte 1 = ; + +M: bson-date element-data-read ( type -- timestamp ) + drop + read-longlong millis>timestamp ; + +M: bson-binary element-data-read ( type -- binary ) + drop + read-int32 read-byte element-binary-read ; + +M: bson-regexp element-data-read ( type -- mdbregexp ) + drop mdbregexp new + read-cstring >>regexp read-cstring >>options ; + +M: bson-null element-data-read ( type -- bf ) + drop + f ; + +M: bson-oid element-data-read ( type -- oid ) + drop + read-longlong + read-int32 oid boa ; + +M: bson-binary-custom element-binary-read ( size type -- dbref ) + 2drop + read-cstring + read-cstring objref boa ; + +M: bson-binary-bytes element-binary-read ( size type -- bytes ) + drop read ; + +M: bson-binary-function element-binary-read ( size type -- quot ) + drop read bytes>object ; + +PRIVATE> + +: stream>assoc ( exemplar -- assoc bytes-read ) + dup state + [ read-int32 >>size read-elements ] with-variable + [ result>> ] [ read>> ] bi ; diff --git a/extra/bson/reader/summary.txt b/extra/bson/reader/summary.txt new file mode 100644 index 0000000000..384fe07a42 --- /dev/null +++ b/extra/bson/reader/summary.txt @@ -0,0 +1 @@ +BSON to Factor deserializer diff --git a/extra/bson/summary.txt b/extra/bson/summary.txt new file mode 100644 index 0000000000..58604e6990 --- /dev/null +++ b/extra/bson/summary.txt @@ -0,0 +1 @@ +BSON reader and writer diff --git a/extra/bson/writer/authors.txt b/extra/bson/writer/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/bson/writer/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/bson/writer/summary.txt b/extra/bson/writer/summary.txt new file mode 100644 index 0000000000..5dc8501bcb --- /dev/null +++ b/extra/bson/writer/summary.txt @@ -0,0 +1 @@ +Factor to BSON serializer diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor new file mode 100644 index 0000000000..1b9d45b124 --- /dev/null +++ b/extra/bson/writer/writer.factor @@ -0,0 +1,164 @@ +! Copyright (C) 2008 Sascha Matzke. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs bson.constants byte-arrays byte-vectors +calendar fry io io.binary io.encodings io.encodings.binary +io.encodings.utf8 io.streams.byte-array kernel math math.parser +namespaces quotations sequences sequences.private serialize strings +words combinators.short-circuit literals ; + +IN: bson.writer + + [ shared-buffer set ] keep ] unless* ; inline + +: >le-stream ( x n -- ) + swap + '[ _ swap nth-byte 0 B{ 0 } + [ set-nth-unsafe ] keep write ] each ; inline + +PRIVATE> + +: reset-buffer ( buffer -- ) + 0 >>length drop ; inline + +: ensure-buffer ( -- ) + (buffer) drop ; inline + +: with-buffer ( quot -- byte-vector ) + [ (buffer) [ reset-buffer ] keep dup ] dip + with-output-stream* dup encoder? [ stream>> ] when ; inline + +: with-length ( quot: ( -- ) -- bytes-written start-index ) + [ (buffer) [ length ] keep ] dip call + length swap [ - ] keep ; inline + +: with-length-prefix ( quot: ( -- ) -- ) + [ B{ 0 0 0 0 } write ] prepose with-length + [ INT32-SIZE >le ] dip (buffer) + '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] + [ INT32-SIZE ] dip each-integer ; inline + +: with-length-prefix-excl ( quot: ( -- ) -- ) + [ B{ 0 0 0 0 } write ] prepose with-length + [ INT32-SIZE - INT32-SIZE >le ] dip (buffer) + '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] + [ INT32-SIZE ] dip each-integer ; inline + + stream-write ; inline + +: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline +: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline +: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline +: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline +: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline + +: write-eoo ( -- ) T_EOO write-byte ; inline +: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline +: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline + +M: f bson-write ( f -- ) + drop 0 write-byte ; + +M: t bson-write ( t -- ) + drop 1 write-byte ; + +M: string bson-write ( obj -- ) + '[ _ write-cstring ] with-length-prefix-excl ; + +M: integer bson-write ( num -- ) + write-int32 ; + +M: real bson-write ( num -- ) + >float write-double ; + +M: timestamp bson-write ( timestamp -- ) + timestamp>millis write-longlong ; + +M: byte-array bson-write ( binary -- ) + [ length write-int32 ] keep + T_Binary_Bytes write-byte + write ; + +M: quotation bson-write ( quotation -- ) + object>bytes [ length write-int32 ] keep + T_Binary_Function write-byte + write ; + +M: oid bson-write ( oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; + +M: objref bson-write ( objref -- ) + [ binary ] dip + '[ _ + [ ns>> write-cstring ] + [ objid>> write-cstring ] bi ] with-byte-writer + [ length write-int32 ] keep + T_Binary_Custom write-byte write ; + +M: mdbregexp bson-write ( regexp -- ) + [ regexp>> write-cstring ] + [ options>> write-cstring ] bi ; + +M: sequence bson-write ( array -- ) + '[ _ [ [ write-type ] dip number>string + write-cstring bson-write ] each-index + write-eoo ] with-length-prefix ; + +: write-oid ( assoc -- ) + [ MDB_OID_FIELD ] dip at + [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline + +: skip-field? ( name -- boolean ) + { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline + +M: assoc bson-write ( assoc -- ) + '[ _ [ write-oid ] keep + [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each + write-eoo ] with-length-prefix ; + +M: word bson-write name>> bson-write ; + +PRIVATE> + +: assoc>bv ( assoc -- byte-vector ) + [ '[ _ bson-write ] with-buffer ] with-scope ; inline + +: assoc>stream ( assoc -- ) + bson-write ; inline + +: mdb-special-value? ( value -- ? ) + { [ timestamp? ] [ quotation? ] [ mdbregexp? ] + [ oid? ] [ byte-array? ] } 1|| ; \ No newline at end of file diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index d0625e464f..620f737fe3 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,58 +1,67 @@ USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline bunny.model bunny.outlined destructors kernel math opengl.demo-support opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures -ui.render words ; +ui.render words ui.pixel-formats ; IN: bunny -TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; +TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ; -: ( -- bunny-gadget ) - 0.0 0.0 0.375 bunny-gadget new-demo-gadget - maybe-download read-model >>model-triangles ; - -: bunny-gadget-draw ( gadget -- draw ) +: get-draw ( gadget -- draw ) [ draw-n>> ] [ draw-seq>> ] bi nth ; -: bunny-gadget-next-draw ( gadget -- ) +: next-draw ( gadget -- ) dup [ draw-seq>> ] [ draw-n>> ] bi 1+ swap length mod >>draw-n relayout-1 ; -M: bunny-gadget graft* ( gadget -- ) - dup find-gl-context - GL_DEPTH_TEST glEnable - dup model-triangles>> >>geom - dup +: make-draws ( gadget -- draw-seq ) [ ] [ ] [ ] tri 3array - sift >>draw-seq + sift ; + +M: bunny-world begin-world + GL_DEPTH_TEST glEnable + 0.0 0.0 0.375 set-demo-orientation + maybe-download read-model + [ >>model-triangles ] [ >>geom ] bi + dup make-draws >>draw-seq 0 >>draw-n drop ; -M: bunny-gadget ungraft* ( gadget -- ) +M: bunny-world end-world dup find-gl-context [ geom>> [ dispose ] when* ] [ draw-seq>> [ [ dispose ] when* ] each ] bi ; -M: bunny-gadget draw-gadget* ( gadget -- ) +M: bunny-world draw-world* dup draw-seq>> empty? [ drop ] [ 0.15 0.15 0.15 1.0 glClearColor GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear - dup demo-gadget-set-matrices + dup demo-world-set-matrix GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny + [ geom>> ] [ get-draw ] bi draw-bunny ] if ; -M: bunny-gadget pref-dim* ( gadget -- dim ) +M: bunny-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; -bunny-gadget H{ - { T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] } +bunny-world H{ + { T{ key-down f f "TAB" } [ next-draw ] } } set-gestures : bunny-window ( -- ) - [ "Bunny" open-window ] with-ui ; + [ + f T{ world-attributes + { world-class bunny-world } + { title "Bunny" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 16 } } + } } + } open-window + ] with-ui ; MAIN: bunny-window diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 7491ed8bcb..0ad2a72100 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -216,7 +216,11 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- ) ] with-framebuffer ; : (pass2) ( draw -- ) - init-matrices { + GL_PROJECTION glMatrixMode + glPushMatrix glLoadIdentity + GL_MODELVIEW glMatrixMode + glLoadIdentity + { [ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ] [ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ] @@ -230,7 +234,9 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- ) } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ] - } cleave ; + } cleave + GL_PROJECTION glMatrixMode + glPopMatrix ; M: bunny-outlined draw-bunny [ remake-framebuffer-if-needed ] diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index f7cd10a0e9..f787befc31 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: html.parser.state io io.encodings.utf8 io.files +USING: sequence-parser io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories assocs math splitting make unicode.categories @@ -41,7 +41,7 @@ ifs elifs elses ; DEFER: preprocess-file -ERROR: unknown-c-preprocessor state-parser name ; +ERROR: unknown-c-preprocessor sequence-parser name ; ERROR: bad-include-line line ; @@ -69,8 +69,16 @@ ERROR: header-file-missing path ; drop ] if ; -: handle-include ( preprocessor-state state-parser -- ) - skip-whitespace advance dup previous { +: skip-whitespace/comments ( sequence-parser -- sequence-parser ) + skip-whitespace + { + { [ dup take-c-comment ] [ skip-whitespace/comments ] } + { [ dup take-c++-comment ] [ skip-whitespace/comments ] } + [ ] + } cond ; + +: handle-include ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments advance dup previous { { CHAR: < [ CHAR: > take-until-object read-standard-include ] } { CHAR: " [ CHAR: " take-until-object read-local-include ] } [ bad-include-line ] @@ -81,58 +89,58 @@ ERROR: header-file-missing path ; : readlns ( -- string ) [ (readlns) ] { } make concat ; -: take-define-identifier ( state-parser -- string ) - skip-whitespace +: take-define-identifier ( sequence-parser -- string ) + skip-whitespace/comments [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; -: handle-define ( preprocessor-state state-parser -- ) +: handle-define ( preprocessor-state sequence-parser -- ) [ take-define-identifier ] - [ skip-whitespace take-rest ] bi + [ skip-whitespace/comments take-rest ] bi "\\" ?tail [ readlns append ] when spin symbol-table>> set-at ; -: handle-undef ( preprocessor-state state-parser -- ) +: handle-undef ( preprocessor-state sequence-parser -- ) take-token swap symbol-table>> delete-at ; -: handle-ifdef ( preprocessor-state state-parser -- ) +: handle-ifdef ( preprocessor-state sequence-parser -- ) [ [ 1 + ] change-ifdef-nesting ] dip take-token over symbol-table>> key? [ drop ] [ t >>processing-disabled? drop ] if ; -: handle-ifndef ( preprocessor-state state-parser -- ) +: handle-ifndef ( preprocessor-state sequence-parser -- ) [ [ 1 + ] change-ifdef-nesting ] dip take-token over symbol-table>> key? [ t >>processing-disabled? drop ] [ drop ] if ; -: handle-endif ( preprocessor-state state-parser -- ) +: handle-endif ( preprocessor-state sequence-parser -- ) drop [ 1 - ] change-ifdef-nesting drop ; -: handle-if ( preprocessor-state state-parser -- ) +: handle-if ( preprocessor-state sequence-parser -- ) [ [ 1 + ] change-ifdef-nesting ] dip - skip-whitespace take-rest swap ifs>> push ; + skip-whitespace/comments take-rest swap ifs>> push ; -: handle-elif ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap elifs>> push ; +: handle-elif ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap elifs>> push ; -: handle-else ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap elses>> push ; +: handle-else ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap elses>> push ; -: handle-pragma ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap pragmas>> push ; +: handle-pragma ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap pragmas>> push ; -: handle-include-next ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap include-nexts>> push ; +: handle-include-next ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap include-nexts>> push ; -: handle-error ( preprocessor-state state-parser -- ) - skip-whitespace take-rest swap errors>> push ; +: handle-error ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap errors>> push ; ! nip take-rest throw ; -: handle-warning ( preprocessor-state state-parser -- ) - skip-whitespace +: handle-warning ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments take-rest swap warnings>> push ; -: parse-directive ( preprocessor-state state-parser string -- ) +: parse-directive ( preprocessor-state sequence-parser string -- ) { { "warning" [ handle-warning ] } { "error" [ handle-error ] } @@ -150,7 +158,7 @@ ERROR: header-file-missing path ; [ unknown-c-preprocessor ] } case ; -: parse-directive-line ( preprocessor-state state-parser -- ) +: parse-directive-line ( preprocessor-state sequence-parser -- ) advance dup take-token pick processing-disabled?>> [ "endif" = [ @@ -162,14 +170,14 @@ ERROR: header-file-missing path ; parse-directive ] if ; -: preprocess-line ( preprocessor-state state-parser -- ) - skip-whitespace dup current CHAR: # = +: preprocess-line ( preprocessor-state sequence-parser -- ) + skip-whitespace/comments dup current CHAR: # = [ parse-directive-line ] [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ; : preprocess-lines ( preprocessor-state -- ) readln - [ [ preprocess-line ] [ drop preprocess-lines ] 2bi ] + [ [ preprocess-line ] [ drop preprocess-lines ] 2bi ] [ drop ] if* ; ERROR: include-nested-too-deeply ; diff --git a/extra/contributors/contributors-tests.factor b/extra/contributors/contributors-tests.factor index 1476715588..3d9ce0403d 100644 --- a/extra/contributors/contributors-tests.factor +++ b/extra/contributors/contributors-tests.factor @@ -1,5 +1,4 @@ IN: contributors.tests USING: contributors tools.test ; -\ contributors must-infer [ ] [ contributors ] unit-test diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 1879c52826..73bee76c0a 100755 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -7,7 +7,7 @@ IN: contributors : changelog ( -- authors ) image parent-directory [ - "git log --pretty=format:%an" ascii lines + "git log --pretty=format:%an" ascii stream-lines ] with-directory ; : patch-counts ( authors -- assoc ) diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor index 51276336e3..6b334822c0 100644 --- a/extra/coroutines/coroutines.factor +++ b/extra/coroutines/coroutines.factor @@ -19,9 +19,10 @@ TUPLE: coroutine resumecc exitcc originalcc ; : coresume ( v co -- result ) [ >>exitcc - resumecc>> call + resumecc>> call( -- ) #! At this point, the coroutine quotation must have terminated - #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen. + #! normally (without calling coyield, coreset, or coterminate). + #! This shouldn't happen. f over ] callcc1 2nip ; @@ -47,4 +48,4 @@ TUPLE: coroutine resumecc exitcc originalcc ; : coreset ( v -- ) current-coro get dup originalcc>> >>resumecc - exitcc>> continue-with ; \ No newline at end of file + exitcc>> continue-with ; diff --git a/unmaintained/morse/authors.txt b/extra/couchdb/authors.txt similarity index 100% rename from unmaintained/morse/authors.txt rename to extra/couchdb/authors.txt diff --git a/extra/couchdb/couchdb-tests.factor b/extra/couchdb/couchdb-tests.factor new file mode 100644 index 0000000000..d7161a14cd --- /dev/null +++ b/extra/couchdb/couchdb-tests.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs couchdb kernel namespaces sequences strings tools.test ; +IN: couchdb.tests + +! You must have a CouchDB server (currently only the version from svn will +! work) running on localhost and listening on the default port for these tests +! to work. + + "factor-test" [ + [ ] [ couch get create-db ] unit-test + [ couch get create-db ] must-fail + [ ] [ couch get delete-db ] unit-test + [ couch get delete-db ] must-fail + [ ] [ couch get ensure-db ] unit-test + [ ] [ couch get ensure-db ] unit-test + [ 0 ] [ couch get db-info "doc_count" swap at ] unit-test + [ ] [ couch get compact-db ] unit-test + [ t ] [ couch get server>> next-uuid string? ] unit-test + [ ] [ H{ + { "Subject" "I like Planktion" } + { "Tags" { "plankton" "baseball" "decisions" } } + { "Body" + "I decided today that I don't like baseball. I like plankton." } + { "Author" "Rusty" } + { "PostedDate" "2006-08-15T17:30:12Z-04:00" } + } save-doc ] unit-test + [ t ] [ couch get all-docs "rows" swap at first "id" swap at dup "id" set string? ] unit-test + [ t ] [ "id" get dup load-doc id> = ] unit-test + [ ] [ "id" get load-doc save-doc ] unit-test + [ "Rusty" ] [ "id" get load-doc "Author" swap at ] unit-test + [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test + [ "Alex" ] [ "id" get load-doc "Author" swap at ] unit-test + [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" swap at ] unit-test + [ ] [ H{ + { "_id" "_design/posts" } + { "language" "javascript" } + { "views" H{ + { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } } + } + } + } save-doc ] unit-test + [ t ] [ "id" get load-doc delete-doc string? ] unit-test + [ "id" get load-doc ] must-fail + [ ] [ couch get delete-db ] unit-test +] with-couch diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor new file mode 100644 index 0000000000..da71acb074 --- /dev/null +++ b/extra/couchdb/couchdb.factor @@ -0,0 +1,200 @@ +! Copyright (C) 2008, 2009 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs continuations debugger hashtables http +http.client io io.encodings.string io.encodings.utf8 json.reader +json.writer kernel make math math.parser namespaces sequences strings +urls urls.encoding vectors ; +IN: couchdb + +! NOTE: This code only works with the latest couchdb (0.9.*), because old +! versions didn't provide the /_uuids feature which this code relies on when +! creating new documents. + +SYMBOL: couch +: with-couch ( db quot -- ) + couch swap with-variable ; inline + +! errors +TUPLE: couchdb-error { data assoc } ; +C: couchdb-error + +M: couchdb-error error. ( error -- ) + "CouchDB Error: " write data>> + "error" over at [ print ] when* + "reason" swap at [ print ] when* ; + +PREDICATE: file-exists-error < couchdb-error + data>> "error" swap at "file_exists" = ; + +! http tools +: couch-http-request ( request -- data ) + [ http-request ] [ + dup download-failed? [ + response>> body>> json> throw + ] [ + rethrow + ] if + ] recover nip ; + +: couch-request ( request -- assoc ) + couch-http-request json> ; + +: couch-get ( url -- assoc ) + couch-request ; + +: couch-put ( post-data url -- assoc ) + couch-request ; + +: couch-post ( post-data url -- assoc ) + couch-request ; + +: couch-delete ( url -- assoc ) + couch-request ; + +: response-ok ( assoc -- assoc ) + "ok" over delete-at* and t assert= ; + +: response-ok* ( assoc -- ) + response-ok drop ; + +! server +TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ; + +: default-couch-host ( -- host ) "localhost" ; inline +: default-couch-port ( -- port ) 5984 ; inline +: default-uuids-to-cache ( -- n ) 100 ; inline + +: ( host port -- server ) + V{ } clone default-uuids-to-cache server boa ; + +: ( -- server ) + default-couch-host default-couch-port ; + +: (server-url) ( server -- ) + "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline + +: server-url ( server -- url ) + [ (server-url) ] "" make ; + +: all-dbs ( server -- dbs ) + server-url "_all_dbs" append couch-get ; + +: uuids-url ( server -- url ) + [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ; + +: uuids-get ( server -- uuids ) + uuids-url couch-get "uuids" swap at >vector ; + +: get-uuids ( server -- server ) + dup uuids-get [ nip ] curry change-uuids ; + +: ensure-uuids ( server -- server ) + dup uuids>> empty? [ get-uuids ] when ; + +: next-uuid ( server -- uuid ) + ensure-uuids uuids>> pop ; + +! db +TUPLE: db { server server } { name string } ; +C: db + +: (db-url) ( db -- ) + [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline + +: db-url ( db -- url ) + [ (db-url) ] "" make ; + +: create-db ( db -- ) + f swap db-url couch-put response-ok* ; + +: ensure-db ( db -- ) + [ create-db ] [ + dup file-exists-error? [ 2drop ] [ rethrow ] if + ] recover ; + +: delete-db ( db -- ) + db-url couch-delete drop ; + +: db-info ( db -- info ) + db-url couch-get ; + +: compact-db ( db -- ) + f swap db-url "_compact" append couch-post response-ok* ; + +: all-docs ( db -- docs ) + ! TODO: queries. Maybe pass in a hashtable with options + db-url "_all_docs" append couch-get ; + +: ( assoc -- post-data ) + >json utf8 encode "application/json" swap >>data ; + +! documents +: id> ( assoc -- id ) "_id" swap at ; +: >id ( assoc id -- assoc ) "_id" pick set-at ; +: rev> ( assoc -- rev ) "_rev" swap at ; +: >rev ( assoc rev -- assoc ) "_rev" pick set-at ; +: attachments> ( assoc -- attachments ) "_attachments" swap at ; +: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ; + +: copy-key ( to from to-key from-key -- ) + rot at spin set-at ; + +: copy-id ( to from -- ) + "_id" "id" copy-key ; + +: copy-rev ( to from -- ) + "_rev" "rev" copy-key ; + +: id-url ( id -- url ) + couch get db-url swap url-encode-full append ; + +: doc-url ( assoc -- url ) + id> id-url ; + +: temp-view ( view -- results ) + couch get db-url "_temp_view" append couch-post ; + +: temp-view-map ( map -- results ) + "map" H{ } clone [ set-at ] keep temp-view ; + +: save-doc-as ( assoc id -- ) + [ dup ] dip id-url couch-put response-ok + [ copy-id ] [ copy-rev ] 2bi ; + +: save-new-doc ( assoc -- ) + couch get server>> next-uuid save-doc-as ; + +: save-doc ( assoc -- ) + dup id> [ save-doc-as ] [ save-new-doc ] if* ; + +: load-doc ( id -- assoc ) + id-url couch-get ; + +: delete-doc ( assoc -- deletion-revision ) + [ + [ doc-url % ] + [ "?rev=" % "_rev" swap at % ] bi + ] "" make couch-delete response-ok "rev" swap at ; + +: remove-keys ( assoc keys -- ) + swap [ delete-at ] curry each ; + +: remove-couch-info ( assoc -- ) + { "_id" "_rev" "_attachments" } remove-keys ; + +! : construct-attachment ( content-type data -- assoc ) +! H{ } clone "name" pick set-at "content-type" pick set-at ; +! +! : add-attachment ( assoc name attachment -- ) +! pick attachments> [ H{ } clone ] unless* +! +! : attach ( assoc name content-type data -- ) +! construct-attachment H{ } clone + +! TODO: +! - startkey, limit, descending, etc. +! - loading specific revisions +! - views +! - attachments +! - bulk insert/update +! - ...? diff --git a/extra/couchdb/tags.txt b/extra/couchdb/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/couchdb/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index eff95bbcd6..274e99d2f6 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -2,10 +2,37 @@ USING: kernel io strings byte-arrays sequences namespaces math parser crypto.hmac tools.test ; IN: crypto.hmac.tests -[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" byte-array>md5-hmac >string ] unit-test -[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test -[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>md5-hmac >string ] unit-test +[ + "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" +] [ + 16 11 "Hi There" sequence>md5-hmac >string ] unit-test -[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test -[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test -[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test +[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] +[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test + +[ + "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" +] +[ + 16 HEX: aa + 50 HEX: dd sequence>md5-hmac >string +] unit-test + +[ + "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" +] [ + 16 11 "Hi There" sequence>sha1-hmac >string +] unit-test + +[ + "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" +] [ + "Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string +] unit-test + +[ + "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" +] [ + 16 HEX: aa + 50 HEX: dd sequence>sha1-hmac >string +] unit-test diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 73b15b9473..6e6229f182 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -6,6 +6,8 @@ io.streams.byte-array kernel math math.vectors memoize sequences io.encodings.binary ; IN: crypto.hmac +sha1 get-sha1 @@ -24,6 +26,7 @@ IN: crypto.hmac [ bitxor ] 2map ; MEMO: ipad ( -- seq ) 64 HEX: 36 ; + MEMO: opad ( -- seq ) 64 HEX: 5c ; : init-hmac ( K -- o i ) @@ -31,13 +34,15 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; [ opad seq-bitxor ] keep ipad seq-bitxor ; +PRIVATE> + : stream>sha1-hmac ( K stream -- hmac ) [ init-hmac sha1-hmac ] with-input-stream ; : file>sha1-hmac ( K path -- hmac ) binary stream>sha1-hmac ; -: byte-array>sha1-hmac ( K string -- hmac ) +: sequence>sha1-hmac ( K sequence -- hmac ) binary stream>sha1-hmac ; : stream>md5-hmac ( K stream -- hmac ) @@ -46,5 +51,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : file>md5-hmac ( K path -- hmac ) binary stream>md5-hmac ; -: byte-array>md5-hmac ( K string -- hmac ) +: sequence>md5-hmac ( K sequence -- hmac ) binary stream>md5-hmac ; diff --git a/extra/descriptive/descriptive-docs.factor b/extra/descriptive/descriptive-docs.factor index dc02f8bd9d..6ced201c13 100755 --- a/extra/descriptive/descriptive-docs.factor +++ b/extra/descriptive/descriptive-docs.factor @@ -1,20 +1,28 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup words ; IN: descriptive HELP: DESCRIPTIVE: { $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" } -{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ; +{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ; HELP: DESCRIPTIVE:: { $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" } -{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ; +{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ; -HELP: descriptive -{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ; +HELP: descriptive-error +{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ; + +HELP: make-descriptive +{ $values { "word" word } } +{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ; ARTICLE: "descriptive" "Descriptive errors" -"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:" -{ $subsection descriptive } +"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:" +{ $subsection descriptive-error } +"The wrapper contains the word itself, the input parameters, as well as the original error." +$nl +"To annotate an existing word with descriptive error checking:" +{ $subsection make-descriptive } "To define words which throw descriptive errors, use the following words:" { $subsection POSTPONE: DESCRIPTIVE: } { $subsection POSTPONE: DESCRIPTIVE:: } ; diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index ceadc9fe6e..9af94aa4ed 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -1,6 +1,9 @@ -USING: words kernel sequences locals locals.parser +! Copyright (c) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: words kernel sequences locals locals.parser fry locals.definitions accessors parser namespaces continuations -summary definitions generalizations arrays prettyprint debugger io ; +summary definitions generalizations arrays prettyprint debugger io +effects tools.annotations ; IN: descriptive ERROR: descriptive-error args underlying word ; @@ -23,6 +26,10 @@ M: descriptive-error error. PRIVATE> +: make-descriptive ( word -- ) + dup [ ] [ def>> ] [ stack-effect ] tri [descriptive] + '[ drop _ ] annotate-methods ; + : define-descriptive ( word def effect -- ) [ drop "descriptive-definition" set-word-prop ] [ [ [ dup ] 2dip [descriptive] ] keep define-declared ] diff --git a/extra/descriptive/tags.txt b/extra/descriptive/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/descriptive/tags.txt @@ -0,0 +1 @@ +extensions diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index cf98154e7a..6d81f2a14b 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -6,7 +6,7 @@ USING: kernel byte-arrays combinators strings arrays sequences splitting io io.binary io.sockets io.encodings.binary accessors combinators.smart - newfx + assocs ; IN: dns @@ -148,8 +148,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ name>> dn->ba ] - [ type>> type-table of uint16->ba ] - [ class>> class-table of uint16->ba ] + [ type>> type-table at uint16->ba ] + [ class>> class-table at uint16->ba ] } cleave ] output>array concat ; @@ -203,8 +203,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ name>> dn->ba ] - [ type>> type-table of uint16->ba ] - [ class>> class-table of uint16->ba ] + [ type>> type-table at uint16->ba ] + [ class>> class-table at uint16->ba ] [ ttl>> uint32->ba ] [ [ type>> ] [ rdata>> ] bi rdata->ba @@ -219,13 +219,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ qr>> 15 shift ] - [ opcode>> opcode-table of 11 shift ] + [ opcode>> opcode-table at 11 shift ] [ aa>> 10 shift ] [ tc>> 9 shift ] [ rd>> 8 shift ] [ ra>> 7 shift ] [ z>> 4 shift ] - [ rcode>> rcode-table of 0 shift ] + [ rcode>> rcode-table at 0 shift ] } cleave ] sum-outputs uint16->ba ; @@ -301,8 +301,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ get-name ] [ skip-name - [ 0 + get-double type-table key-of ] - [ 2 + get-double class-table key-of ] + [ 0 + get-double type-table value-at ] + [ 2 + get-double class-table value-at ] 2bi ] 2bi query boa ; @@ -364,10 +364,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ skip-name { - [ 0 + get-double type-table key-of ] - [ 2 + get-double class-table key-of ] + [ 0 + get-double type-table value-at ] + [ 2 + get-double class-table value-at ] [ 4 + get-quad ] - [ [ 10 + ] [ get-double type-table key-of ] 2bi get-rdata ] + [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ] } 2cleave ] @@ -393,13 +393,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED get-double { [ 15 >> BIN: 1 bitand ] - [ 11 >> BIN: 111 bitand opcode-table key-of ] + [ 11 >> BIN: 111 bitand opcode-table value-at ] [ 10 >> BIN: 1 bitand ] [ 9 >> BIN: 1 bitand ] [ 8 >> BIN: 1 bitand ] [ 7 >> BIN: 1 bitand ] [ 4 >> BIN: 111 bitand ] - [ BIN: 1111 bitand rcode-table key-of ] + [ BIN: 1111 bitand rcode-table value-at ] } cleave ; @@ -484,7 +484,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: message-query ( message -- query ) question-section>> 1st ; +: message-query ( message -- query ) question-section>> first ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/dns/misc/misc.factor b/extra/dns/misc/misc.factor index 6e62513a80..af080f61eb 100644 --- a/extra/dns/misc/misc.factor +++ b/extra/dns/misc/misc.factor @@ -1,6 +1,6 @@ USING: kernel combinators sequences splitting math - io.files io.encodings.utf8 random newfx dns.util ; + io.files io.encodings.utf8 random dns.util ; IN: dns.misc @@ -9,8 +9,8 @@ IN: dns.misc : resolv-conf-servers ( -- seq ) "/etc/resolv.conf" utf8 file-lines [ " " split ] map - [ 1st "nameserver" = ] filter - [ 2nd ] map ; + [ first "nameserver" = ] filter + [ second ] map ; : resolv-conf-server ( -- ip ) resolv-conf-servers random ; diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index b14d765e8d..644533d3a2 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -2,7 +2,7 @@ USING: kernel combinators sequences sets math threads namespaces continuations debugger io io.sockets unicode.case accessors destructors combinators.short-circuit combinators.smart - newfx fry arrays + fry arrays dns dns.util dns.misc ; IN: dns.server @@ -64,7 +64,7 @@ SYMBOL: records-var [ rr->rdata-names ] map concat ; : extract-names ( message -- names ) - [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ; + [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! fill-authority @@ -99,7 +99,7 @@ DEFER: query->rrs : matching-cname? ( query -- rrs/f ) [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs [ empty? not ] - [ 1st swap clone over rdata>> >>name query->rrs prefix-on ] + [ first swap clone over rdata>> >>name query->rrs swap prefix ] [ 2drop f ] 1if ; diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 5b2e63838a..f47eb7010c 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -28,4 +28,4 @@ TUPLE: packet data addr socket ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file +: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file diff --git a/extra/drills/deployed/deploy.factor b/extra/drills/deployed/deploy.factor new file mode 100644 index 0000000000..2f62912360 --- /dev/null +++ b/extra/drills/deployed/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-unicode? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-name "drills" } + { deploy-ui? t } + { deploy-compiler? t } + { "stop-after-last-window?" t } + { deploy-word-props? f } + { deploy-c-types? f } + { deploy-io 2 } + { deploy-word-defs? f } + { deploy-reflection 1 } +} diff --git a/extra/drills/deployed/deployed.factor b/extra/drills/deployed/deployed.factor new file mode 100644 index 0000000000..43873c99bb --- /dev/null +++ b/extra/drills/deployed/deployed.factor @@ -0,0 +1,36 @@ +USING: accessors arrays cocoa.dialogs combinators continuations +fry grouping io.encodings.utf8 io.files io.styles kernel math +math.parser models models.arrow models.history namespaces random +sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras +ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames +ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts +wrap.strings system ; + +IN: drills.deployed +SYMBOLS: it startLength ; +: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ; +: card ( model quot -- button ) big [ next ] ; +: op ( quot str -- gadget )