diff --git a/Factor.app/Contents/Info.plist b/Factor.app/Contents/Info.plist index 7f58d46485..4669858677 100644 --- a/Factor.app/Contents/Info.plist +++ b/Factor.app/Contents/Info.plist @@ -32,7 +32,7 @@ CFBundlePackageType APPL CFBundleVersion - 0.96 + 0.97 NSHumanReadableCopyright Copyright © 2003-2013 Factor developers NSServices diff --git a/GNUmakefile b/GNUmakefile index eec78a9f6a..b4ccd5f7b7 100755 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,8 +1,5 @@ ifdef CONFIG - CC = gcc - CPP = g++ - - VERSION = 0.96 + VERSION = 0.97 BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib @@ -14,7 +11,7 @@ ifdef CONFIG ifdef DEBUG CFLAGS += -g -DFACTOR_DEBUG else - CFLAGS += -O3 + CFLAGS += -O3 -g endif ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) @@ -26,7 +23,6 @@ ifdef CONFIG vm/alien.o \ vm/arrays.o \ vm/bignum.o \ - vm/booleans.o \ vm/byte_arrays.o \ vm/callbacks.o \ vm/callstack.o \ @@ -99,13 +95,10 @@ ifdef CONFIG vm/data_heap.hpp \ vm/code_heap.hpp \ vm/gc.hpp \ - vm/debug.hpp \ vm/strings.hpp \ - vm/words.hpp \ vm/float_bits.hpp \ vm/io.hpp \ vm/image.hpp \ - vm/alien.hpp \ vm/callbacks.hpp \ vm/dispatch.hpp \ vm/entry_points.hpp \ @@ -124,7 +117,6 @@ ifdef CONFIG vm/aging_collector.hpp \ vm/to_tenured_collector.hpp \ vm/code_block_visitor.hpp \ - vm/compaction.hpp \ vm/full_collector.hpp \ vm/arrays.hpp \ vm/math.hpp \ @@ -215,11 +207,11 @@ $(ENGINE): $(DLL_OBJS) factor-lib: $(ENGINE) factor: $(EXE_OBJS) $(DLL_OBJS) - $(TOOLCHAIN_PREFIX)$(CPP) $(LIBPATH) -L. $(DLL_OBJS) \ + $(TOOLCHAIN_PREFIX)$(CXX) $(LIBPATH) -L. $(DLL_OBJS) \ $(CFLAGS) -o $(EXECUTABLE) $(LIBS) $(EXE_OBJS) factor-console: $(EXE_OBJS) $(DLL_OBJS) - $(TOOLCHAIN_PREFIX)$(CPP) $(LIBPATH) -L. $(DLL_OBJS) \ + $(TOOLCHAIN_PREFIX)$(CXX) $(LIBPATH) -L. $(DLL_OBJS) \ $(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(LIBS) $(EXE_OBJS) factor-ffi-test: $(FFI_TEST_LIBRARY) @@ -234,16 +226,16 @@ vm/ffi_test.o: vm/ffi_test.c $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $< vm/master.hpp.gch: vm/master.hpp $(MASTER_HEADERS) - $(TOOLCHAIN_PREFIX)$(CPP) -c -x c++-header $(CFLAGS) -o $@ $< + $(TOOLCHAIN_PREFIX)$(CXX) -c -x c++-header $(CFLAGS) -o $@ $< %.o: %.cpp vm/master.hpp.gch - $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< + $(TOOLCHAIN_PREFIX)$(CXX) -c $(CFLAGS) -o $@ $< %.o: %.S $(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $< %.o: %.mm vm/master.hpp.gch - $(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $< + $(TOOLCHAIN_PREFIX)$(CXX) -c $(CFLAGS) -o $@ $< .SUFFIXES: .mm diff --git a/Nmakefile b/Nmakefile index 05aa8cb562..02dbfd4fa9 100755 --- a/Nmakefile +++ b/Nmakefile @@ -6,17 +6,28 @@ BOOTIMAGE_VERSION = latest LINK_FLAGS = /nologo shell32.lib CL_FLAGS = /nologo /O2 /WX /W3 /D_CRT_SECURE_NO_WARNINGS - -!IF DEFINED(DEBUG) -LINK_FLAGS = $(LINK_FLAGS) /DEBUG -CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG -!ENDIF +CL_FLAGS_VISTA = /D_WIN32_WINNT=0x0600 !IF "$(PLATFORM)" == "x86-32" LINK_FLAGS = $(LINK_FLAGS) /safeseh PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj + +!ELSEIF "$(PLATFORM)" == "x86-32-vista" +LINK_FLAGS = $(LINK_FLAGS) /safeseh +CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA) +PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj vm\cpu-x86.obj + !ELSEIF "$(PLATFORM)" == "x86-64" PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj + +!ELSEIF "$(PLATFORM)" == "x86-64-vista" +CL_FLAGS = $(CL_FLAGS) $(CL_FLAGS_VISTA) +PLAF_DLL_OBJS = vm\os-windows-x86.64.obj vm\cpu-x86.obj +!ENDIF + +!IF DEFINED(DEBUG) +LINK_FLAGS = $(LINK_FLAGS) /DEBUG +CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG !ENDIF ML_FLAGS = /nologo /safeseh @@ -29,7 +40,6 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm\alien.obj \ vm\arrays.obj \ vm\bignum.obj \ - vm\booleans.obj \ vm\byte_arrays.obj \ vm\callbacks.obj \ vm\callstack.obj \ @@ -104,6 +114,8 @@ default: @echo Where platform is one of: @echo x86-32 @echo x86-64 + @echo x86-32-vista + @echo x86-64-vista @exit 1 x86-32: @@ -112,6 +124,12 @@ x86-32: x86-64: nmake /nologo PLATFORM=x86-64 /f Nmakefile all +x86-32-vista: + nmake /nologo PLATFORM=x86-32-vista /f Nmakefile all + +x86-64-vista: + nmake /nologo PLATFORM=x86-64-vista /f Nmakefile all + clean: del vm\*.obj if exist factor.lib del factor.lib @@ -121,6 +139,6 @@ clean: if exist factor.dll del factor.dll if exist factor.dll.lib del factor.dll.lib -.PHONY: all default x86-32 x86-64 clean +.PHONY: all default x86-32 x86-64 x86-32-vista x86-64-vista clean .SUFFIXES: .rs diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index f8cdf9c197..f65080046b 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -318,6 +318,7 @@ M: pointer lookup-c-type \ double typedef cell 8 = [ + ! 64bit-vm int fixnum >>class fixnum >>boxed-class @@ -332,6 +333,7 @@ M: pointer lookup-c-type [ >fixnum ] >>unboxer-quot \ int typedef + ! 64bit-vm uint fixnum >>class fixnum >>boxed-class @@ -345,6 +347,7 @@ M: pointer lookup-c-type [ >fixnum ] >>unboxer-quot \ uint typedef + ! 64bit-vm longlong integer >>class integer >>boxed-class @@ -355,10 +358,11 @@ M: pointer lookup-c-type 8 >>align 8 >>align-first "from_signed_cell" >>boxer - "to_fixnum" >>unboxer + "to_signed_8" >>unboxer [ >integer ] >>unboxer-quot \ longlong typedef + ! 64bit-vm ulonglong integer >>class integer >>boxed-class @@ -386,6 +390,7 @@ M: pointer lookup-c-type \ ulonglong lookup-c-type \ uintptr_t typedef \ ulonglong lookup-c-type \ size_t typedef ] [ + ! 32bit-vm int integer >>class integer >>boxed-class @@ -400,6 +405,7 @@ M: pointer lookup-c-type [ >integer ] >>unboxer-quot \ int typedef + ! 32bit-vm uint integer >>class integer >>boxed-class @@ -413,6 +419,7 @@ M: pointer lookup-c-type [ >integer ] >>unboxer-quot \ uint typedef + ! 32bit-vm longlong integer >>class integer >>boxed-class @@ -426,6 +433,7 @@ M: pointer lookup-c-type [ >integer ] >>unboxer-quot \ longlong typedef + ! 32bit-vm ulonglong integer >>class integer >>boxed-class diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor index f8bd14456b..789094fb8b 100644 --- a/basis/alien/data/data.factor +++ b/basis/alien/data/data.factor @@ -8,7 +8,7 @@ QUALIFIED: math IN: alien.data : ( value c-type -- c-ptr ) - [ heap-size ] keep + [ heap-size (byte-array) ] keep '[ 0 _ set-alien-value ] keep ; inline : deref ( c-ptr c-type -- value ) diff --git a/basis/alien/endian/endian.factor b/basis/alien/endian/endian.factor index f7cc0b0f97..ff0a0d09eb 100644 --- a/basis/alien/endian/endian.factor +++ b/basis/alien/endian/endian.factor @@ -4,7 +4,7 @@ USING: accessors alien alien.accessors alien.c-types alien.data classes.struct.private combinators compiler.units endian fry generalizations kernel macros math namespaces sequences words arrays slots math.bitwise ; -QUALIFIED-WITH: alien.c-types ac +QUALIFIED-WITH: alien.c-types c IN: alien.endian ERROR: invalid-signed-conversion n ; @@ -12,7 +12,7 @@ ERROR: invalid-signed-conversion n ; : convert-signed-quot ( n -- quot ) { { 1 [ [ char char deref ] ] } - { 2 [ [ ac:short ac:short deref ] ] } + { 2 [ [ c:short c:short deref ] ] } { 4 [ [ int int deref ] ] } { 8 [ [ longlong longlong deref ] ] } [ invalid-signed-conversion ] @@ -47,7 +47,7 @@ ERROR: unknown-endian-c-type symbol ; : endian-c-type>c-type-symbol ( symbol -- symbol' ) { { [ dup { ule16 ube16 } member? ] [ drop ushort ] } - { [ dup { le16 be16 } member? ] [ drop ac:short ] } + { [ dup { le16 be16 } member? ] [ drop c:short ] } { [ dup { ule32 ube32 } member? ] [ drop uint ] } { [ dup { le32 be32 } member? ] [ drop int ] } { [ dup { ule64 ube64 } member? ] [ drop ulonglong ] } @@ -111,7 +111,7 @@ ERROR: unknown-endian-c-type symbol ; ! otherwise return the opposite of our endianness : endian-slot ( endian c-type pair -- endian-slot ) [ native-endianness get = ] 2dip rot [ drop ] [ nip pair>c-type ] if ; - + ERROR: unsupported-endian-type endian slot ; : slot>endian-slot ( endian slot -- endian-slot ) @@ -121,7 +121,7 @@ ERROR: unsupported-endian-type endian slot ; { { [ dup char = ] [ 2drop char ] } { [ dup uchar = ] [ 2drop uchar ] } - { [ dup ac:short = ] [ { le16 be16 } endian-slot ] } + { [ dup c:short = ] [ { le16 be16 } endian-slot ] } { [ dup ushort = ] [ { ule16 ube16 } endian-slot ] } { [ dup int = ] [ { le32 be32 } endian-slot ] } { [ dup uint = ] [ { ule32 ube32 } endian-slot ] } diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor index cd4225c4ab..2056a5ad52 100644 --- a/basis/alien/enums/enums.factor +++ b/basis/alien/enums/enums.factor @@ -1,7 +1,7 @@ ! (c)2010 Joe Groff, Erik Charlebois bsd license -USING: accessors alien.c-types arrays combinators delegate fry -generic.parser kernel macros math parser sequences words words.symbol -classes.singleton assocs ; +USING: accessors alien.c-types arrays assocs classes.singleton +combinators delegate fry kernel macros math parser sequences +words ; IN: alien.enums : define-enum ( word base-type members -- ) [ (define-enum) ] [ [ define-enum-value ] assoc-each ] bi ; - + PREDICATE: enum-c-type-word < c-type-word "c-type" word-prop enum-c-type? ; diff --git a/basis/alien/libraries/finder/finder-docs.factor b/basis/alien/libraries/finder/finder-docs.factor new file mode 100644 index 0000000000..598fd3d214 --- /dev/null +++ b/basis/alien/libraries/finder/finder-docs.factor @@ -0,0 +1,24 @@ +USING: help.markup help.syntax ; +IN: alien.libraries.finder + +HELP: find-library* +{ $values + { "name" "a shared library name" } + { "path/f" "a filesystem path or f" } +} +{ $description + "Returns a filesystem path for a plain shared library name, or f if no library can be found." +} ; + +HELP: find-library +{ $values + { "name" "a shared library name" } + { "path/library-not-found" "a filesystem path or " { $snippet "name" } } +} +{ $description + "Used to load libraries whose exact filenames is not known in advance:" + { $code + "<< \"sqlite\" \"sqlite3\" find-library cdecl add-library >>" + } + "Note the parse time evaluation with " { $link POSTPONE: << } "." +} ; diff --git a/basis/alien/libraries/finder/finder-tests.factor b/basis/alien/libraries/finder/finder-tests.factor new file mode 100644 index 0000000000..c0731a8464 --- /dev/null +++ b/basis/alien/libraries/finder/finder-tests.factor @@ -0,0 +1,5 @@ +USING: alien alien.libraries.finder tools.test ; +IN: alien.libraries.finder + +{ f } [ "dont-exist" find-library* ] unit-test +{ "dont-exist" } [ "dont-exist" find-library ] unit-test diff --git a/basis/alien/libraries/finder/finder.factor b/basis/alien/libraries/finder/finder.factor new file mode 100644 index 0000000000..3a763cf1b8 --- /dev/null +++ b/basis/alien/libraries/finder/finder.factor @@ -0,0 +1,21 @@ +USING: combinators kernel sequences system vocabs +alien.libraries ; +IN: alien.libraries.finder + +HOOK: find-library* os ( name -- path/f ) + +: find-library ( name -- path/library-not-found ) + dup find-library* [ nip ] when* ; + +! Try to find the library from a list, but if it's not found, +! try to open a library that is the first name in that list anyway +! or "library_not_found" as a last resort for better debugging. +: find-library-from-list ( seq -- path/f ) + dup [ find-library* ] map-find drop + [ nip ] [ ?first "library_not_found" or ] if* ; + +{ + { [ os macosx? ] [ "alien.libraries.finder.macosx" ] } + { [ os linux? ] [ "alien.libraries.finder.linux" ] } + { [ os windows? ] [ "alien.libraries.finder.windows" ] } +} cond require diff --git a/basis/alien/libraries/finder/linux/linux-tests.factor b/basis/alien/libraries/finder/linux/linux-tests.factor new file mode 100644 index 0000000000..416217560f --- /dev/null +++ b/basis/alien/libraries/finder/linux/linux-tests.factor @@ -0,0 +1,5 @@ +USING: alien.libraries.finder sequences tools.test ; +IN: alien.libraries.fidner.linux + +{ t } [ "libm.so" "m" find-library subseq? ] unit-test +{ t } [ "libc.so" "c" find-library subseq? ] unit-test diff --git a/basis/alien/libraries/finder/linux/linux.factor b/basis/alien/libraries/finder/linux/linux.factor new file mode 100644 index 0000000000..5d2446fbf8 --- /dev/null +++ b/basis/alien/libraries/finder/linux/linux.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2013 Björn Lindqvist, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license +USING: alien.libraries.finder arrays assocs +combinators.short-circuit io io.encodings.utf8 io.files +io.files.info io.launcher kernel sequences sets splitting system +unicode.categories ; +IN: alien.libraries.finder.linux + +" split1 [ [ blank? ] trim ] bi@ + [ + " " split1 [ "()" in? ] trim "," split + [ [ blank? ] trim ] map + [ "OS ABI:" head? not ] filter + ] dip 3array + ] map ; + +: load-ldconfig-cache ( -- seq ) + "/sbin/ldconfig -p" utf8 [ lines ] with-process-reader + rest parse-ldconfig-lines ; + +: ldconfig-arch ( -- str ) + mach-map cpu of { "libc6" } or ; + +: name-matches? ( lib triple -- ? ) + first swap ?head [ ?first CHAR: . = ] [ drop f ] if ; + +: arch-matches? ( lib triple -- ? ) + [ drop ldconfig-arch ] [ second swap subset? ] bi* ; + +: ldconfig-matches? ( lib triple -- ? ) + { [ name-matches? ] [ arch-matches? ] } 2&& ; + +: ldconfig-find-soname ( lib -- seq ) + load-ldconfig-cache [ ldconfig-matches? ] with filter + [ third ] map ; + +PRIVATE> + +M: linux find-library* + "lib" prepend ldconfig-find-soname [ + { [ exists? ] [ file-info regular-file? ] } 1&& + ] map-find nip ; diff --git a/basis/tools/ps/platforms.txt b/basis/alien/libraries/finder/linux/platforms.txt similarity index 100% rename from basis/tools/ps/platforms.txt rename to basis/alien/libraries/finder/linux/platforms.txt diff --git a/basis/alien/libraries/finder/macosx/macosx-tests.factor b/basis/alien/libraries/finder/macosx/macosx-tests.factor new file mode 100644 index 0000000000..3fe2f938c2 --- /dev/null +++ b/basis/alien/libraries/finder/macosx/macosx-tests.factor @@ -0,0 +1,50 @@ + +USING: alien.libraries.finder +alien.libraries.finder.macosx.private sequences tools.test ; + +IN: alien.libraries.finder.macosx + +{ + { + f + f + f + f + T{ framework-info f "Location" "Name.framework/Name" "Name" f f } + T{ framework-info f "Location" "Name.framework/Name_suffix" "Name" f "suffix" } + f + f + T{ framework-info f "Location" "Name.framework/Versions/A/Name" "Name" "A" f } + T{ framework-info f "Location" "Name.framework/Versions/A/Name_suffix" "Name" "A" "suffix" } + } +} [ + { + "broken/path" + "broken/path/_suffix" + "Location/Name.framework" + "Location/Name.framework/_suffix" + "Location/Name.framework/Name" + "Location/Name.framework/Name_suffix" + "Location/Name.framework/Versions" + "Location/Name.framework/Versions/A" + "Location/Name.framework/Versions/A/Name" + "Location/Name.framework/Versions/A/Name_suffix" + } [ make-framework-info ] map +] unit-test + +{ + { + "/usr/lib/libSystem.dylib" + "/System/Library/Frameworks/System.framework/System" + } +} [ + { + "libSystem.dylib" + "System.framework/System" + } [ dyld-find ] map +] unit-test + +{ t } [ "libm.dylib" "m" find-library subseq? ] unit-test +{ t } [ "libc.dylib" "c" find-library subseq? ] unit-test +{ t } [ "libbz2.dylib" "bz2" find-library subseq? ] unit-test +{ t } [ "AGL.framework" "AGL" find-library subseq? ] unit-test diff --git a/basis/alien/libraries/finder/macosx/macosx.factor b/basis/alien/libraries/finder/macosx/macosx.factor new file mode 100644 index 0000000000..c6d260b6d9 --- /dev/null +++ b/basis/alien/libraries/finder/macosx/macosx.factor @@ -0,0 +1,135 @@ +! Copyright (C) 2013 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: accessors alien.libraries.finder arrays assocs +combinators.short-circuit environment io.files io.files.info +io.pathnames kernel locals make namespaces sequences splitting +system ; + +IN: alien.libraries.finder.macosx + +>location ] [ >>name ] bi* + ] keep [ + rest dup ?first "Versions" = [ + rest dup empty? [ + unclip swap [ >>version ] dip + ] unless + ] when ?first "_" split1 [ >>shortname ] [ >>suffix ] bi* + ] unless-empty + ] [ drop ] if* dup shortname>> empty? [ drop f ] when ; + +CONSTANT: default-framework-fallback { + "~/Library/Frameworks" + "/Library/Frameworks" + "/Network/Library/Frameworks" + "/System/Library/Frameworks" +} + +CONSTANT: default-library-fallback { + "~/lib" + "/usr/local/lib" + "/lib" + "/usr/lib" +} + +SYMBOL: dyld-environment + +: dyld-env ( name -- seq ) + dyld-environment get [ at ] [ os-env ] if* ; + +: dyld-paths ( name -- seq ) + dyld-env [ ":" split ] [ f ] if* ; + +: paths% ( name seq -- ) + [ prepend-path , ] with each ; + +: dyld-override-search ( name -- seq ) + [ + dup make-framework-info [ + name>> "DYLD_FRAMEWORK_PATH" dyld-paths paths% + ] when* + + file-name "DYLD_LIBRARY_PATH" dyld-paths paths% + ] { } make ; + +SYMBOL: dyld-executable-path + +: dyld-executable-path-search ( name -- seq ) + "@executable_path/" ?head dyld-executable-path get and [ + dyld-executable-path get prepend-path + ] [ + drop f + ] if ; + +:: dyld-default-search ( name -- seq ) + name make-framework-info :> framework + name file-name :> basename + "DYLD_FALLBACK_FRAMEWORK_PATH" dyld-paths :> fallback-framework-path + "DYLD_FALLBACK_LIBRARY_PATH" dyld-paths :> fallback-library-path + [ + name , + + framework [ + name>> fallback-framework-path paths% + ] when* + + basename fallback-library-path paths% + + framework fallback-framework-path empty? and [ + framework name>> default-framework-fallback paths% + ] when + + fallback-library-path empty? [ + basename default-library-fallback paths% + ] when + ] { } make ; + +: dyld-image-suffix-search ( seq -- str ) + "DYLD_IMAGE_SUFFIX" dyld-env [ + swap [ + [ + [ + ".dylib" ?tail [ prepend ] dip + [ ".dylib" append ] when , + ] [ + , + ] bi + ] with each + ] { } make + ] when* ; + +: dyld-search-paths ( name -- paths ) + [ dyld-override-search ] + [ dyld-executable-path-search ] + [ dyld-default-search ] tri 3append + dyld-image-suffix-search ; + +PRIVATE> + +: dyld-find ( name -- path/f ) + dyld-search-paths + [ { [ exists? ] [ file-info regular-file? ] } 1&& ] find + [ nip ] when* ; + +: framework-find ( name -- path ) + dup dyld-find [ nip ] [ + ".framework" over start [ + dupd head + ] [ + [ ".framework" append ] keep + ] if* file-name append-path dyld-find + ] if* ; + +M: macosx find-library* + [ "lib" ".dylib" surround ] + [ ".dylib" append ] + [ ".framework/" over 3append ] tri 3array + [ dyld-find ] map-find drop ; diff --git a/basis/alien/libraries/finder/macosx/platforms.txt b/basis/alien/libraries/finder/macosx/platforms.txt new file mode 100644 index 0000000000..6e806f449e --- /dev/null +++ b/basis/alien/libraries/finder/macosx/platforms.txt @@ -0,0 +1 @@ +macosx diff --git a/basis/alien/libraries/finder/windows/platforms.txt b/basis/alien/libraries/finder/windows/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/basis/alien/libraries/finder/windows/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/basis/alien/libraries/finder/windows/windows.factor b/basis/alien/libraries/finder/windows/windows.factor new file mode 100644 index 0000000000..1f1fbbe38d --- /dev/null +++ b/basis/alien/libraries/finder/windows/windows.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2013 Björn Lindqvist, John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: alien.libraries.finder arrays combinators.short-circuit +environment io.backend io.files io.files.info io.pathnames kernel +sequences splitting system system-info.windows ; + +IN: alien.libraries.finder.windows + + + +M: windows find-library* + candidate-paths [ + { [ exists? ] [ file-info regular-file? ] } 1&& + ] map-find nip ; diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor index f9828e2835..b09cc904df 100644 --- a/basis/alien/libraries/libraries-docs.factor +++ b/basis/alien/libraries/libraries-docs.factor @@ -4,7 +4,7 @@ USING: accessors alien alien.syntax assocs help.markup help.syntax io.backend kernel namespaces strings ; IN: alien.libraries -HELP: +HELP: make-library { $values { "path" "a pathname string" } { "abi" "the ABI used by the library, either " { $link cdecl } " or " { $link stdcall } } { "library" library } } diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor index 7e8611405e..5a06b01a84 100755 --- a/basis/alien/libraries/libraries.factor +++ b/basis/alien/libraries/libraries.factor @@ -17,16 +17,20 @@ SYMBOL: libraries libraries [ H{ } clone ] initialize -TUPLE: library { path string } { abi abi initial: cdecl } dll dlerror ; +TUPLE: library { path string } dll dlerror { abi abi initial: cdecl } ; + +C: library ERROR: no-library name ; : lookup-library ( name -- library ) libraries get at ; -: ( path abi -- library ) - over dup - [ dlopen dup dll-valid? [ f ] [ dlerror ] if ] [ f ] if - \ library boa ; +: open-dll ( path -- dll dll-error/f ) + [ dlopen dup dll-valid? [ f ] [ dlerror ] if ] + [ f f ] if* ; + +: make-library ( path abi -- library ) + [ dup open-dll ] dip ; : library-dll ( library -- dll ) dup [ dll>> ] when ; @@ -48,7 +52,8 @@ M: library dispose dll>> [ dispose ] when* ; : add-library ( name path abi -- ) 3dup add-library? [ [ 2drop remove-library ] - [ swap libraries get set-at ] 3bi + [ [ nip ] dip make-library ] + [ 2drop libraries get set-at ] 3tri ] [ 3drop ] if ; : library-abi ( library -- abi ) diff --git a/basis/alien/parser/parser-tests.factor b/basis/alien/parser/parser-tests.factor index 2333eb3725..ecbb92a03e 100644 --- a/basis/alien/parser/parser-tests.factor +++ b/basis/alien/parser/parser-tests.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff bsd license USING: accessors alien.c-types alien.parser alien.syntax -tools.test vocabs.parser parser eval debugger kernel -continuations words ; +continuations debugger eval parser tools.test vocabs.parser +words ; IN: alien.parser.tests TYPEDEF: char char2 diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor index ba94b11238..9242460718 100644 --- a/basis/ascii/ascii-docs.factor +++ b/basis/ascii/ascii-docs.factor @@ -1,44 +1,44 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax kernel strings ; IN: ascii HELP: blank? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for an ASCII whitespace character." } ; HELP: letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for a lowercase alphabet ASCII character." } ; HELP: LETTER? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for a uppercase alphabet ASCII character." } ; HELP: digit? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for an ASCII decimal digit character." } ; HELP: Letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for an ASCII alphabet character, both upper and lower case." } ; HELP: alpha? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for an alphanumeric ASCII character." } ; HELP: printable? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for a printable ASCII character." } ; HELP: control? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for an ASCII control character." } ; HELP: quotable? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for characters which may appear in a Factor string literal without escaping." } ; HELP: ascii? -{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $values { "ch" "a character" } { "?" boolean } } { $description "Tests for whether a number is an ASCII character." } ; HELP: ch>lower @@ -50,23 +50,23 @@ HELP: ch>upper { $description "Converts an ASCII character to upper case." } ; HELP: >lower -{ $values { "str" "a string" } { "lower" "a string" } } +{ $values { "str" string } { "lower" string } } { $description "Converts an ASCII string to lower case." } ; HELP: >upper -{ $values { "str" "a string" } { "upper" "a string" } } +{ $values { "str" string } { "upper" string } } { $description "Converts an ASCII string to upper case." } ; HELP: >title -{ $values { "str" "a string" } { "title" "a string" } } +{ $values { "str" string } { "title" string } } { $description "Converts a string to title case." } ; HELP: >words -{ $values { "str" "a string" } { "words" "an array of slices" } } +{ $values { "str" string } { "words" "an array of slices" } } { $description "Divides the string up into words." } ; HELP: capitalize -{ $values { "str" "a string" } { "str'" "a string" } } +{ $values { "str" string } { "str'" string } } { $description "Capitalize all the words in a string." } ; ARTICLE: "ascii" "ASCII" diff --git a/basis/atk/ffi/ffi.factor b/basis/atk/ffi/ffi.factor index 8a7be511c6..3f7ad28b91 100644 --- a/basis/atk/ffi/ffi.factor +++ b/basis/atk/ffi/ffi.factor @@ -13,7 +13,8 @@ LIBRARY: atk << "atk" { { [ os windows? ] [ "libatk-1.0-0.dll" cdecl add-library ] } - { [ os unix? ] [ drop ] } + { [ os macosx? ] [ "libatk-1.0.dylib" cdecl add-library ] } + { [ os unix? ] [ "libatk-1.0.so" cdecl add-library ] } } cond >> diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index c3847f5d51..0f25a812be 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: combinators fry io io.binary io.encodings.binary -io.streams.byte-array kernel math namespaces +io.streams.byte-array kernel math namespaces sbufs sequences strings ; IN: base64 @@ -11,12 +11,15 @@ ERROR: malformed-base64 ; : read1-ignoring ( ignoring stream -- ch ) dup stream-read1 pick dupd member? - [ drop read1-ignoring ] [ 2nip ] if ; + [ drop read1-ignoring ] [ 2nip ] if ; inline recursive -: read-ignoring ( n ignoring stream -- str ) - '[ _ _ read1-ignoring ] replicate - [ { f 0 } member-eq? not ] "" filter-as - [ f ] when-empty ; +: push-ignoring ( accum ch -- accum ) + dup { f 0 } member-eq? [ drop ] [ over push ] if ; inline + +: read-ignoring ( n ignoring stream -- str/f ) + [ [ ] keep ] 2dip + '[ _ _ read1-ignoring push-ignoring ] times + [ f ] [ "" like ] if-empty ; inline : ch>base64 ( ch -- ch ) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" @@ -47,8 +50,8 @@ SYMBOL: column : encode3 ( seq -- ) column output-stream get '[ - swap be> { 3 2 1 0 } [ - -6 * shift 0x3f bitand ch>base64 _ write1-lines + swap be> { -18 -12 -6 0 } [ + shift 0x3f bitand ch>base64 _ write1-lines ] with each ] change ; inline diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor index da71d34dce..289435c5b3 100644 --- a/basis/binary-search/binary-search-docs.factor +++ b/basis/binary-search/binary-search-docs.factor @@ -2,7 +2,7 @@ IN: binary-search USING: help.markup help.syntax sequences kernel math.order ; HELP: search -{ $values { "seq" "a sorted sequence" } { "quot" { $quotation "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } +{ $values { "seq" "a sorted sequence" } { "quot" { $quotation ( elt -- <=> ) } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } { $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")." $nl "If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "." @@ -34,13 +34,13 @@ HELP: sorted-index { index index-from last-index last-index-from sorted-index } related-words HELP: sorted-member? -{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } } +{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" boolean } } { $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ; { member? sorted-member? } related-words HELP: sorted-member-eq? -{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } } +{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" boolean } } { $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ; { member-eq? sorted-member-eq? } related-words diff --git a/basis/bit-arrays/bit-arrays-docs.factor b/basis/bit-arrays/bit-arrays-docs.factor index df81771ae0..899cfebcaf 100644 --- a/basis/bit-arrays/bit-arrays-docs.factor +++ b/basis/bit-arrays/bit-arrays-docs.factor @@ -1,5 +1,4 @@ -USING: arrays help.markup help.syntax kernel -kernel.private math prettyprint strings vectors sbufs ; +USING: help.markup help.syntax math sequences ; IN: bit-arrays ARTICLE: "bit-arrays" "Bit arrays" @@ -48,7 +47,7 @@ HELP: { $description "Creates a new bit array with the given length and all elements initially set to " { $link f } "." } ; HELP: >bit-array -{ $values { "seq" "a sequence" } { "bit-array" bit-array } } +{ $values { "seq" sequence } { "bit-array" bit-array } } { $description "Outputs a freshly-allocated bit array whose elements have the same boolean values as a given sequence." } ; HELP: clear-bits diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor index b70b62a74b..0f1bca7999 100644 --- a/basis/bit-sets/bit-sets.factor +++ b/basis/bit-sets/bit-sets.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors sequences byte-arrays bit-arrays math -math.bitwise hints sets ; +USING: accessors bit-arrays fry kernel math math.bitwise +sequences sequences.private sets ; IN: bit-sets TUPLE: bit-set { table bit-array read-only } ; @@ -22,9 +22,7 @@ M: bit-set adjoin M: bit-set delete ! This isn't allowed to throw an error if the elt wasn't ! in the set - over integer? [ - [ f ] 2dip table>> ?set-nth - ] [ 2drop ] if ; + over integer? [ [ f ] 2dip table>> ?set-nth ] [ 2drop ] if ; ! If you do binary set operations with a bit-set, it's expected ! that the other thing can also be represented as a bit-set @@ -37,13 +35,9 @@ ERROR: check-bit-set-failed ; dup bit-set? [ check-bit-set-failed ] unless ; inline : bit-set-map ( seq1 seq2 quot -- seq ) - [ 2drop length>> ] - [ - [ - [ [ length ] bi@ assert= ] - [ [ underlying>> ] bi@ ] 2bi - ] dip 2map - ] 3bi bit-array boa ; inline + [ drop [ length ] bi@ [ assert= ] keep ] + [ [ [ underlying>> ] bi@ ] dip 2map ] 3bi + bit-array boa ; inline : (bit-set-op) ( set1 set2 -- table1 table2 ) [ set-like ] keep [ table>> ] bi@ ; inline @@ -66,7 +60,7 @@ M: bit-set subset? [ intersect ] keep = ; M: bit-set members - [ table>> length iota ] keep [ in? ] curry filter ; + table>> [ length iota ] keep '[ _ nth-unsafe ] filter ; { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ; HELP: >bit-vector -{ $values { "seq" "a sequence" } { "vector" bit-vector } } +{ $values { "seq" sequence } { "vector" bit-vector } } { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; HELP: ?V{ diff --git a/basis/boxes/boxes-docs.factor b/basis/boxes/boxes-docs.factor index 7b28682910..5c0514b213 100644 --- a/basis/boxes/boxes-docs.factor +++ b/basis/boxes/boxes-docs.factor @@ -19,7 +19,7 @@ HELP: box> { $errors "Throws an error if the box is empty." } ; HELP: ?box -{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" "a boolean" } } +{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" boolean } } { $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ; ARTICLE: "boxes" "Boxes" diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor index 1babfde23f..f623b878a2 100755 --- a/basis/cache/cache.factor +++ b/basis/cache/cache.factor @@ -38,9 +38,9 @@ M: cache-assoc dispose* clear-assoc ; PRIVATE> : purge-cache ( cache -- ) - [ assoc>> ] [ max-age>> ] bi '[ - [ + [ assoc>> ] [ max-age>> ] bi V{ } clone [ + '[ nip dup age>> 1 + [ >>age ] keep - _ < [ drop t ] [ dispose, f ] if + _ < [ drop t ] [ _ dispose-to f ] if ] assoc-filter! drop - ] { } make [ last rethrow ] unless-empty ; + ] keep [ last rethrow ] unless-empty ; diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor index 6f0001d5d8..d04564c8d5 100644 --- a/basis/cairo/ffi/ffi.factor +++ b/basis/cairo/ffi/ffi.factor @@ -8,10 +8,10 @@ IN: cairo.ffi ! Adapted from cairo.h, version 1.8.10 -<< { - { [ os windows? ] [ "cairo" "libcairo-2.dll" cdecl add-library ] } - { [ os macosx? ] [ "cairo" "libcairo.dylib" cdecl add-library ] } - { [ os unix? ] [ ] } +<< "cairo" { + { [ os windows? ] [ "libcairo-2.dll" cdecl add-library ] } + { [ os macosx? ] [ "libcairo.dylib" cdecl add-library ] } + { [ os unix? ] [ "libcairo.so" cdecl add-library ] } } cond >> LIBRARY: cairo diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 6442c232a3..b2e42958ef 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -175,7 +175,7 @@ HELP: nanoseconds { years months days hours minutes seconds milliseconds microseconds nanoseconds } related-words HELP: leap-year? -{ $values { "obj" object } { "?" "a boolean" } } +{ $values { "obj" object } { "?" boolean } } { $description "Returns " { $link t } " if the object represents a leap year." } { $examples { $example "USING: calendar prettyprint ;" @@ -357,7 +357,7 @@ HELP: { $description "Returns a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ; HELP: valid-timestamp? -{ $values { "timestamp" timestamp } { "?" "a boolean" } } +{ $values { "timestamp" timestamp } { "?" boolean } } { $description "Tests if a timestamp is valid or not." } ; HELP: unix-1970 diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 0fd023ee04..a0c111fb5e 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -33,6 +33,8 @@ TUPLE: timestamp C: timestamp +M: timestamp clone (clone) [ clone ] change-gmt-offset ; + : gmt-offset-duration ( -- duration ) 0 0 0 gmt-offset ; inline @@ -324,10 +326,10 @@ GENERIC: time- ( time1 time2 -- time3 ) ] if ; : >local-time ( timestamp -- timestamp' ) - gmt-offset-duration convert-timezone ; + clone gmt-offset-duration convert-timezone ; : >gmt ( timestamp -- timestamp' ) - dup gmt-offset>> dup instant = + clone dup gmt-offset>> dup instant = [ drop ] [ [ neg +second 0 ] change-second [ neg +minute 0 ] change-minute diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index cb1ff0b60f..b1598df2fe 100644 --- a/basis/calendar/format/format-tests.factor +++ b/basis/calendar/format/format-tests.factor @@ -1,85 +1,120 @@ -USING: calendar.format calendar kernel math tools.test -io.streams.string accessors io math.order sequences ; -IN: calendar.format.tests - -[ 0 ] [ - "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours -] unit-test - -[ 1 ] [ - "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours -] unit-test - -[ -1 ] [ - "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours -] unit-test - -[ -1-1/2 ] [ - "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours -] unit-test - -[ 1+1/2 ] [ - "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours -] unit-test - -[ ] [ now timestamp>rfc3339 drop ] unit-test -[ ] [ now timestamp>rfc822 drop ] unit-test - -[ 8/1000 -4 ] [ - "2008-04-19T04:56:00.008-04:00" rfc3339>timestamp - [ second>> ] [ gmt-offset>> hour>> ] bi -] unit-test - -[ T{ duration f 0 0 0 0 0 0 } ] [ - "GMT" parse-rfc822-gmt-offset -] unit-test - -[ T{ duration f 0 0 0 -5 0 0 } ] [ - "-0500" parse-rfc822-gmt-offset -] unit-test - -[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [ - "Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp -] unit-test - -[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test - -[ t ] [ now dup timestamp>cookie-string cookie-string>timestamp time- 1 seconds before? ] unit-test - -[ "Sun, 4 May 2008 07:00:00" ] [ - "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp - timestamp>string -] unit-test - -[ "20080504070000" ] [ - "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp - timestamp>mdtm -] unit-test - -[ - T{ timestamp f - 2008 - 5 - 26 - 0 - 37 - 42+2469/20000 - T{ duration f 0 0 0 -5 0 0 } - } -] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test - -[ - T{ timestamp - { year 2008 } - { month 10 } - { day 2 } - { hour 23 } - { minute 59 } - { second 59 } - { gmt-offset T{ duration f 0 0 0 0 0 0 } } - } -] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test - - -[ ] -[ { 2008 2009 } [ year. ] each ] unit-test +USING: calendar.format calendar kernel math tools.test +io.streams.string accessors io math.order sequences ; +IN: calendar.format.tests + +[ 0 ] [ + "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours +] unit-test + +[ 1 ] [ + "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours +] unit-test + +[ -1 ] [ + "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours +] unit-test + +[ -1-1/2 ] [ + "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours +] unit-test + +[ 1+1/2 ] [ + "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours +] unit-test + +[ ] [ now timestamp>rfc3339 drop ] unit-test +[ ] [ now timestamp>rfc822 drop ] unit-test + +[ 8/1000 -4 ] [ + "2008-04-19T04:56:00.008-04:00" rfc3339>timestamp + [ second>> ] [ gmt-offset>> hour>> ] bi +] unit-test + +[ T{ duration f 0 0 0 0 0 0 } ] [ + "GMT" parse-rfc822-gmt-offset +] unit-test + +[ T{ duration f 0 0 0 -5 0 0 } ] [ + "-0500" parse-rfc822-gmt-offset +] unit-test + +[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [ + "Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp +] unit-test + +[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test + +[ t ] [ now dup timestamp>cookie-string cookie-string>timestamp time- 1 seconds before? ] unit-test + +[ "Sun, 4 May 2008 07:00:00" ] [ + "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp + timestamp>string +] unit-test + +[ "20080504070000" ] [ + "Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp + timestamp>mdtm +] unit-test + +[ + T{ timestamp f + 2008 + 5 + 26 + 0 + 37 + 42+2469/20000 + T{ duration f 0 0 0 -5 0 0 } + } +] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test + +[ + T{ timestamp + { year 2008 } + { month 10 } + { day 2 } + { hour 23 } + { minute 59 } + { second 59 } + { gmt-offset T{ duration f 0 0 0 0 0 0 } } + } +] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test + + +[ ] +[ { 2008 2009 } [ year. ] each ] unit-test + +[ + T{ timestamp + { year 2013 } + { month 4 } + { day 23 } + { hour 13 } + { minute 50 } + { second 24 } + } +] [ "2013-04-23T13:50:24" rfc3339>timestamp ] unit-test + +{ "2001-12-14T21:59:43.100000-05:00" } [ "2001-12-14T21:59:43.1-05:00" rfc3339>timestamp timestamp>rfc3339 ] unit-test + +[ + T{ timestamp + { year 2001 } + { month 12 } + { day 15 } + { hour 02 } + { minute 59 } + { second 43+1/10 } + } +] [ "2001-12-15 02:59:43.1Z" rfc3339>timestamp ] unit-test + +[ + T{ timestamp + { year 2001 } + { month 12 } + { day 15 } + { hour 02 } + { minute 59 } + { second 43+1/10 } + } +] [ "2001-12-15 02:59:43.1Z" rfc3339>timestamp ] unit-test diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index e2af02a3cc..aa02460607 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -1,328 +1,338 @@ -! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar calendar.format.macros -combinators io io.streams.string kernel math math.functions -math.order math.parser present sequences typed ; -IN: calendar.format - -: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ; - -: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ; - -: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ; - -: write-00 ( n -- ) pad-00 write ; - -: write-0000 ( n -- ) pad-0000 write ; - -: write-00000 ( n -- ) pad-00000 write ; - -: hh ( time -- ) hour>> write-00 ; - -: mm ( time -- ) minute>> write-00 ; - -: ss ( time -- ) second>> >integer write-00 ; - -: D ( time -- ) day>> number>string write ; - -: DD ( time -- ) day>> write-00 ; - -: DAY ( time -- ) day-of-week day-abbreviation3 write ; - -: MM ( time -- ) month>> write-00 ; - -: MONTH ( time -- ) month>> month-abbreviation write ; - -: YYYY ( time -- ) year>> write-0000 ; - -: YYYYY ( time -- ) year>> write-00000 ; - -: expect ( str -- ) - read1 swap member? [ "Parse error" throw ] unless ; - -: read-00 ( -- n ) 2 read string>number ; - -: read-000 ( -- n ) 3 read string>number ; - -: read-0000 ( -- n ) 4 read string>number ; - -: hhmm>timestamp ( hhmm -- timestamp ) - [ - 0 0 0 read-00 read-00 0 instant - ] with-string-reader ; - -GENERIC: day. ( obj -- ) - -M: integer day. ( n -- ) - number>string dup length 2 < [ bl ] when write ; - -M: timestamp day. ( timestamp -- ) - day>> day. ; - -GENERIC: month. ( obj -- ) - -M: array month. ( pair -- ) - first2 - [ month-name write bl number>string print ] - [ 1 zeller-congruence ] - [ (days-in-month) day-abbreviations2 " " join print ] 2tri - over " " "" concat-as write - [ - [ 1 + day. ] keep - 1 + + 7 mod zero? [ nl ] [ bl ] if - ] with each-integer nl ; - -M: timestamp month. ( timestamp -- ) - [ year>> ] [ month>> ] bi 2array month. ; - -GENERIC: year. ( obj -- ) - -M: integer year. ( n -- ) - 12 [ 1 + 2array month. nl ] with each-integer ; - -M: timestamp year. ( timestamp -- ) - year>> year. ; - -: timestamp>mdtm ( timestamp -- str ) - [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ; - -: (timestamp>string) ( timestamp -- ) - { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ; - -: timestamp>string ( timestamp -- str ) - [ (timestamp>string) ] with-string-writer ; - -: (write-gmt-offset) ( duration -- ) - [ hh ] [ mm ] bi ; - -: write-gmt-offset ( gmt-offset -- ) - dup instant <=> { - { +eq+ [ drop "GMT" write ] } - { +lt+ [ "-" write before (write-gmt-offset) ] } - { +gt+ [ "+" write (write-gmt-offset) ] } - } case ; - -: timestamp>rfc822 ( timestamp -- str ) - #! RFC822 timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 +0200 - [ - [ (timestamp>string) bl ] - [ gmt-offset>> write-gmt-offset ] - bi - ] with-string-writer ; - -: timestamp>http-string ( timestamp -- str ) - #! http timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt timestamp>rfc822 ; - -: (timestamp>cookie-string) ( timestamp -- ) - >gmt - { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ; - -: timestamp>cookie-string ( timestamp -- str ) - [ (timestamp>cookie-string) ] with-string-writer ; - -: (write-rfc3339-gmt-offset) ( duration -- ) - [ hh ":" write ] [ mm ] bi ; - -: write-rfc3339-gmt-offset ( duration -- ) - dup instant <=> { - { +eq+ [ drop "Z" write ] } - { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] } - { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] } - } case ; - -: (timestamp>rfc3339) ( timestamp -- ) - { - YYYY "-" MM "-" DD "T" hh ":" mm ":" ss - [ gmt-offset>> write-rfc3339-gmt-offset ] - } formatted ; - -: timestamp>rfc3339 ( timestamp -- str ) - [ (timestamp>rfc3339) ] with-string-writer ; - -: signed-gmt-offset ( dt ch -- dt' ) - { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ; - -: read-rfc3339-gmt-offset ( ch -- dt ) - dup CHAR: Z = [ drop instant ] [ - [ - read-00 hours - read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes - time+ - ] dip signed-gmt-offset - ] if ; - -: read-ymd ( -- y m d ) - read-0000 "-" expect read-00 "-" expect read-00 ; - -: read-hms ( -- h m s ) - read-00 ":" expect read-00 ":" expect read-00 ; - -: read-rfc3339-seconds ( s -- s' ch ) - "+-Z" read-until [ - [ string>number ] [ length 10^ ] bi / + - ] dip ; - -: (rfc3339>timestamp) ( -- timestamp ) - read-ymd - "Tt" expect - read-hms - read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case - read-rfc3339-gmt-offset - ; - -: rfc3339>timestamp ( str -- timestamp ) - [ (rfc3339>timestamp) ] with-string-reader ; - -ERROR: invalid-timestamp-format ; - -: check-timestamp ( obj/f -- obj ) - [ invalid-timestamp-format ] unless* ; - -: read-token ( seps -- token ) - [ read-until ] keep member? check-timestamp drop ; - -: read-sp ( -- token ) " " read-token ; - -: checked-number ( str -- n ) - string>number check-timestamp ; - -: parse-rfc822-gmt-offset ( string -- dt ) - dup "GMT" = [ drop instant ] [ - unclip [ - 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+ - ] dip signed-gmt-offset - ] if ; - -: (rfc822>timestamp) ( -- timestamp ) - timestamp new - "," read-token day-abbreviations3 member? check-timestamp drop - read1 CHAR: \s assert= - read-sp checked-number >>day - read-sp month-abbreviations index 1 + check-timestamp >>month - read-sp checked-number >>year - ":" read-token checked-number >>hour - ":" read-token checked-number >>minute - read-sp checked-number >>second - readln parse-rfc822-gmt-offset >>gmt-offset ; - -: rfc822>timestamp ( str -- timestamp ) - [ (rfc822>timestamp) ] with-string-reader ; - -: check-day-name ( str -- ) - [ day-abbreviations3 member? ] [ day-names member? ] bi or - check-timestamp drop ; - -: (cookie-string>timestamp-1) ( -- timestamp ) - timestamp new - "," read-token check-day-name - read1 CHAR: \s assert= - "-" read-token checked-number >>day - "-" read-token month-abbreviations index 1 + check-timestamp >>month - read-sp checked-number >>year - ":" read-token checked-number >>hour - ":" read-token checked-number >>minute - read-sp checked-number >>second - readln parse-rfc822-gmt-offset >>gmt-offset ; - -: cookie-string>timestamp-1 ( str -- timestamp ) - [ (cookie-string>timestamp-1) ] with-string-reader ; - -: (cookie-string>timestamp-2) ( -- timestamp ) - timestamp new - read-sp check-day-name - read-sp month-abbreviations index 1 + check-timestamp >>month - read-sp checked-number >>day - ":" read-token checked-number >>hour - ":" read-token checked-number >>minute - read-sp checked-number >>second - read-sp checked-number >>year - readln parse-rfc822-gmt-offset >>gmt-offset ; - -: cookie-string>timestamp-2 ( str -- timestamp ) - [ (cookie-string>timestamp-2) ] with-string-reader ; - -: cookie-string>timestamp ( str -- timestamp ) - { - [ cookie-string>timestamp-1 ] - [ cookie-string>timestamp-2 ] - [ rfc822>timestamp ] - } attempt-all-quots ; - -: (ymdhms>timestamp) ( -- timestamp ) - read-ymd " " expect read-hms instant ; - -: ymdhms>timestamp ( str -- timestamp ) - [ (ymdhms>timestamp) ] with-string-reader ; - -: (hms>timestamp) ( -- timestamp ) - 0 0 0 read-hms instant ; - -: hms>timestamp ( str -- timestamp ) - [ (hms>timestamp) ] with-string-reader ; - -: (ymd>timestamp) ( -- timestamp ) - read-ymd ; - -: ymd>timestamp ( str -- timestamp ) - [ (ymd>timestamp) ] with-string-reader ; - -: (timestamp>ymd) ( timestamp -- ) - { YYYY "-" MM "-" DD } formatted ; - -TYPED: timestamp>ymd ( timestamp: timestamp -- str ) - [ (timestamp>ymd) ] with-string-writer ; - -: (timestamp>hms) ( timestamp -- ) - { hh ":" mm ":" ss } formatted ; - -TYPED: timestamp>hms ( timestamp: timestamp -- str ) - [ (timestamp>hms) ] with-string-writer ; - -: (timestamp>hm) ( timestamp -- ) - { hh ":" mm } formatted ; - -TYPED: timestamp>hm ( timestamp: timestamp -- str ) - [ (timestamp>hm) ] with-string-writer ; - -TYPED: timestamp>ymdhms ( timestamp: timestamp -- str ) - [ - >gmt - { (timestamp>ymd) " " (timestamp>hms) } formatted - ] with-string-writer ; - -: file-time-string ( timestamp -- string ) - [ - { - MONTH " " DD " " - [ - dup now [ year>> ] same? - [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if - ] - } formatted - ] with-string-writer ; - -M: timestamp present timestamp>string ; - -TYPED: duration>hm ( duration: duration -- string ) - [ duration>hours >integer 24 mod pad-00 ] - [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ; - -TYPED: duration>human-readable ( duration: duration -- string ) - [ - [ - duration>years >integer - [ - [ number>string write ] - [ 1 > " years, " " year, " ? write ] bi - ] unless-zero - ] [ - duration>days >integer 365 mod - [ - [ number>string write ] - [ 1 > " days, " " day, " ? write ] bi - ] unless-zero - ] [ duration>hm write ] tri - ] with-string-writer ; +! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays calendar calendar.format.macros +combinators io io.streams.string kernel math math.functions +math.order math.parser math.parser.private present sequences +typed ; +IN: calendar.format + +: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ; + +: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ; + +: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ; + +: write-00 ( n -- ) pad-00 write ; + +: write-0000 ( n -- ) pad-0000 write ; + +: write-00000 ( n -- ) pad-00000 write ; + +: hh ( time -- ) hour>> write-00 ; + +: mm ( time -- ) minute>> write-00 ; + +: ss ( time -- ) second>> >integer write-00 ; + +: D ( time -- ) day>> number>string write ; + +: DD ( time -- ) day>> write-00 ; + +: DAY ( time -- ) day-of-week day-abbreviation3 write ; + +: MM ( time -- ) month>> write-00 ; + +: MONTH ( time -- ) month>> month-abbreviation write ; + +: YYYY ( time -- ) year>> write-0000 ; + +: YYYYY ( time -- ) year>> write-00000 ; + +: expect ( str -- ) + read1 swap member? [ "Parse error" throw ] unless ; + +: read-00 ( -- n ) 2 read string>number ; + +: read-000 ( -- n ) 3 read string>number ; + +: read-0000 ( -- n ) 4 read string>number ; + +: hhmm>timestamp ( hhmm -- timestamp ) + [ + 0 0 0 read-00 read-00 0 instant + ] with-string-reader ; + +GENERIC: day. ( obj -- ) + +M: integer day. ( n -- ) + number>string dup length 2 < [ bl ] when write ; + +M: timestamp day. ( timestamp -- ) + day>> day. ; + +GENERIC: month. ( obj -- ) + +M: array month. ( pair -- ) + first2 + [ month-name write bl number>string print ] + [ 1 zeller-congruence ] + [ (days-in-month) day-abbreviations2 " " join print ] 2tri + over " " "" concat-as write + [ + [ 1 + day. ] keep + 1 + + 7 mod zero? [ nl ] [ bl ] if + ] with each-integer nl ; + +M: timestamp month. ( timestamp -- ) + [ year>> ] [ month>> ] bi 2array month. ; + +GENERIC: year. ( obj -- ) + +M: integer year. ( n -- ) + 12 [ 1 + 2array month. nl ] with each-integer ; + +M: timestamp year. ( timestamp -- ) + year>> year. ; + +: timestamp>mdtm ( timestamp -- str ) + [ { YYYY MM DD hh mm ss } formatted ] with-string-writer ; + +: (timestamp>string) ( timestamp -- ) + { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ; + +: timestamp>string ( timestamp -- str ) + [ (timestamp>string) ] with-string-writer ; + +: (write-gmt-offset) ( duration -- ) + [ hh ] [ mm ] bi ; + +: write-gmt-offset ( gmt-offset -- ) + dup instant <=> { + { +eq+ [ drop "GMT" write ] } + { +lt+ [ "-" write before (write-gmt-offset) ] } + { +gt+ [ "+" write (write-gmt-offset) ] } + } case ; + +: timestamp>rfc822 ( timestamp -- str ) + #! RFC822 timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 +0200 + [ + [ (timestamp>string) bl ] + [ gmt-offset>> write-gmt-offset ] + bi + ] with-string-writer ; + +: timestamp>http-string ( timestamp -- str ) + #! http timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 GMT + >gmt timestamp>rfc822 ; + +: (timestamp>cookie-string) ( timestamp -- ) + >gmt + { DAY ", " DD "-" MONTH "-" YYYY " " hh ":" mm ":" ss " GMT" } formatted ; + +: timestamp>cookie-string ( timestamp -- str ) + [ (timestamp>cookie-string) ] with-string-writer ; + +: (write-rfc3339-gmt-offset) ( duration -- ) + [ hh ":" write ] [ mm ] bi ; + +: write-rfc3339-gmt-offset ( duration -- ) + dup instant <=> { + { +eq+ [ drop "Z" write ] } + { +lt+ [ "-" write before (write-rfc3339-gmt-offset) ] } + { +gt+ [ "+" write (write-rfc3339-gmt-offset) ] } + } case ; + +! Should be enough for anyone, allows to not do a fancy +! algorithm to detect infinite decimals (e.g 1/3) +: ss.SSSSSS ( timestamp -- ) + second>> >float "%.6f" format-float 9 CHAR: 0 pad-head write ; + +: (timestamp>rfc3339) ( timestamp -- ) + { + YYYY "-" MM "-" DD "T" hh ":" mm ":" ss.SSSSSS + [ gmt-offset>> write-rfc3339-gmt-offset ] + } formatted ; + +: timestamp>rfc3339 ( timestamp -- str ) + [ (timestamp>rfc3339) ] with-string-writer ; + +: signed-gmt-offset ( dt ch -- dt' ) + { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ; + +: read-rfc3339-gmt-offset ( ch -- dt ) + { + { f [ instant ] } + { CHAR: Z [ instant ] } + [ + [ + read-00 hours + read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes + time+ + ] dip signed-gmt-offset + ] + } case ; + +: read-ymd ( -- y m d ) + read-0000 "-" expect read-00 "-" expect read-00 ; + +: read-hms ( -- h m s ) + read-00 ":" expect read-00 ":" expect read-00 ; + +: read-rfc3339-seconds ( s -- s' ch ) + "+-Z" read-until [ + [ string>number ] [ length 10^ ] bi / + + ] dip ; + +: (rfc3339>timestamp) ( -- timestamp ) + read-ymd + "Tt \t" expect + read-hms + read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case + read-rfc3339-gmt-offset + ; + +: rfc3339>timestamp ( str -- timestamp ) + [ (rfc3339>timestamp) ] with-string-reader ; + +ERROR: invalid-timestamp-format ; + +: check-timestamp ( obj/f -- obj ) + [ invalid-timestamp-format ] unless* ; + +: read-token ( seps -- token ) + [ read-until ] keep member? check-timestamp drop ; + +: read-sp ( -- token ) " " read-token ; + +: checked-number ( str -- n ) + string>number check-timestamp ; + +: parse-rfc822-gmt-offset ( string -- dt ) + dup "GMT" = [ drop instant ] [ + unclip [ + 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+ + ] dip signed-gmt-offset + ] if ; + +: (rfc822>timestamp) ( -- timestamp ) + timestamp new + "," read-token day-abbreviations3 member? check-timestamp drop + read1 CHAR: \s assert= + read-sp checked-number >>day + read-sp month-abbreviations index 1 + check-timestamp >>month + read-sp checked-number >>year + ":" read-token checked-number >>hour + ":" read-token checked-number >>minute + read-sp checked-number >>second + readln parse-rfc822-gmt-offset >>gmt-offset ; + +: rfc822>timestamp ( str -- timestamp ) + [ (rfc822>timestamp) ] with-string-reader ; + +: check-day-name ( str -- ) + [ day-abbreviations3 member? ] [ day-names member? ] bi or + check-timestamp drop ; + +: (cookie-string>timestamp-1) ( -- timestamp ) + timestamp new + "," read-token check-day-name + read1 CHAR: \s assert= + "-" read-token checked-number >>day + "-" read-token month-abbreviations index 1 + check-timestamp >>month + read-sp checked-number >>year + ":" read-token checked-number >>hour + ":" read-token checked-number >>minute + read-sp checked-number >>second + readln parse-rfc822-gmt-offset >>gmt-offset ; + +: cookie-string>timestamp-1 ( str -- timestamp ) + [ (cookie-string>timestamp-1) ] with-string-reader ; + +: (cookie-string>timestamp-2) ( -- timestamp ) + timestamp new + read-sp check-day-name + read-sp month-abbreviations index 1 + check-timestamp >>month + read-sp checked-number >>day + ":" read-token checked-number >>hour + ":" read-token checked-number >>minute + read-sp checked-number >>second + read-sp checked-number >>year + readln parse-rfc822-gmt-offset >>gmt-offset ; + +: cookie-string>timestamp-2 ( str -- timestamp ) + [ (cookie-string>timestamp-2) ] with-string-reader ; + +: cookie-string>timestamp ( str -- timestamp ) + { + [ cookie-string>timestamp-1 ] + [ cookie-string>timestamp-2 ] + [ rfc822>timestamp ] + } attempt-all-quots ; + +: (ymdhms>timestamp) ( -- timestamp ) + read-ymd " " expect read-hms instant ; + +: ymdhms>timestamp ( str -- timestamp ) + [ (ymdhms>timestamp) ] with-string-reader ; + +: (hms>timestamp) ( -- timestamp ) + 0 0 0 read-hms instant ; + +: hms>timestamp ( str -- timestamp ) + [ (hms>timestamp) ] with-string-reader ; + +: (ymd>timestamp) ( -- timestamp ) + read-ymd ; + +: ymd>timestamp ( str -- timestamp ) + [ (ymd>timestamp) ] with-string-reader ; + +: (timestamp>ymd) ( timestamp -- ) + { YYYY "-" MM "-" DD } formatted ; + +TYPED: timestamp>ymd ( timestamp: timestamp -- str ) + [ (timestamp>ymd) ] with-string-writer ; + +: (timestamp>hms) ( timestamp -- ) + { hh ":" mm ":" ss } formatted ; + +TYPED: timestamp>hms ( timestamp: timestamp -- str ) + [ (timestamp>hms) ] with-string-writer ; + +: (timestamp>hm) ( timestamp -- ) + { hh ":" mm } formatted ; + +TYPED: timestamp>hm ( timestamp: timestamp -- str ) + [ (timestamp>hm) ] with-string-writer ; + +TYPED: timestamp>ymdhms ( timestamp: timestamp -- str ) + [ + >gmt + { (timestamp>ymd) " " (timestamp>hms) } formatted + ] with-string-writer ; + +: file-time-string ( timestamp -- string ) + [ + { + MONTH " " DD " " + [ + dup now [ year>> ] same? + [ [ hh ":" write ] [ mm ] bi ] [ YYYYY ] if + ] + } formatted + ] with-string-writer ; + +M: timestamp present timestamp>string ; + +TYPED: duration>hm ( duration: duration -- string ) + [ duration>hours >integer 24 mod pad-00 ] + [ duration>minutes >integer 60 mod pad-00 ] bi ":" glue ; + +TYPED: duration>human-readable ( duration: duration -- string ) + [ + [ + duration>years >integer + [ + [ number>string write ] + [ 1 > " years, " " year, " ? write ] bi + ] unless-zero + ] [ + duration>days >integer 365 mod + [ + [ number>string write ] + [ 1 > " days, " " day, " ? write ] bi + ] unless-zero + ] [ duration>hm write ] tri + ] with-string-writer ; diff --git a/basis/calendar/threads/threads.factor b/basis/calendar/threads/threads.factor index efdbb6923d..cc2c495c78 100644 --- a/basis/calendar/threads/threads.factor +++ b/basis/calendar/threads/threads.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: calendar math system threads ; +USING: calendar threads ; IN: calendar.threads -M: duration sleep - duration>nanoseconds >integer nano-count + sleep-until ; +M: duration sleep duration>nanoseconds sleep ; + +M: timestamp sleep-until now time- sleep ; diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index f106f8810e..ac729a5cef 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.data calendar calendar.private -classes.struct kernel math system unix unix.time unix.types ; +classes.struct kernel math system libc unix unix.time unix.types ; IN: calendar.unix : timeval>seconds ( timeval -- seconds ) @@ -35,7 +35,7 @@ M: unix gmt-offset ( -- hours minutes seconds ) get-time gmtoff>> 3600 /mod 60 /mod ; : current-timeval ( -- timeval ) - timeval f [ gettimeofday io-error ] 2keep drop ; inline + timeval [ f gettimeofday io-error ] keep ; inline : system-micros ( -- n ) current-timeval timeval>micros ; diff --git a/basis/channels/channels-docs.factor b/basis/channels/channels-docs.factor index 09dac901fe..931d424195 100644 --- a/basis/channels/channels-docs.factor +++ b/basis/channels/channels-docs.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup ; +USING: help.syntax help.markup kernel ; IN: channels HELP: -{ $values { "channel" "a channel object" } +{ $values { "channel" channel } } { $description "Create a channel that can be used for communicating between " "concurrent processes and threads. " { $link to } " and " { $link from } @@ -15,19 +15,19 @@ HELP: { $see-also from to } ; HELP: to -{ $values { "value" "an object" } - { "channel" "a channel object" } +{ $values { "value" object } + { "channel" channel } } { $description "Sends an object to a channel. The send operation is synchronous." " It will block the calling thread until there is a receiver waiting " "for data on the channel. It will return when the receiver has received " -"the data successfully." +"the data successfully." } { $see-also from } ; HELP: from -{ $values { "channel" "a channel object" } - { "value" "an object" } +{ $values { "channel" channel } + { "value" object } } { $description "Receives an object from a channel. The operation is synchronous." " It will block the calling thread until there is data in the channel." diff --git a/basis/channels/remote/remote-docs.factor b/basis/channels/remote/remote-docs.factor index 2215d959a3..bbecb361ea 100644 --- a/basis/channels/remote/remote-docs.factor +++ b/basis/channels/remote/remote-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: channels concurrency.distributed help.markup help.syntax -io.servers ; +io.servers strings ; IN: channels.remote HELP: @@ -20,7 +20,7 @@ HELP: { $see-also publish unpublish } ; HELP: unpublish -{ $values { "id" "a string" } +{ $values { "id" string } } { $description "Stop a previously published channel from being " "accessible by remote nodes." @@ -32,7 +32,7 @@ HELP: unpublish HELP: publish { $values { "channel" "a channel object" } - { "id" "a string" } + { "id" string } } { $description "Make a channel accessible via remote Factor nodes. " "An id is returned that can be used by another node to use " diff --git a/basis/checksums/fletcher/authors.txt b/basis/checksums/fletcher/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/checksums/fletcher/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/checksums/fletcher/fletcher-docs.factor b/basis/checksums/fletcher/fletcher-docs.factor new file mode 100644 index 0000000000..82d111aebb --- /dev/null +++ b/basis/checksums/fletcher/fletcher-docs.factor @@ -0,0 +1,17 @@ +USING: help.markup help.syntax ; +IN: checksums.fletcher + +HELP: fletcher-16 +{ $class-description "Fletcher's 16-bit checksum algorithm." } ; + +HELP: fletcher-32 +{ $class-description "Fletcher's 32-bit checksum algorithm." } ; + +HELP: fletcher-64 +{ $class-description "Fletcher's 64-bit checksum algorithm." } ; + +ARTICLE: "checksums.fletcher" "Fletcher's checksum" +"The Fletcher checksum is an algorithm for computing a position-dependent checksum devised by John G. Fletcher at Lawrence Livermore Labs in the late 1970s." +{ $subsections fletcher-16 fletcher-32 fletcher-64 } ; + +ABOUT: "checksums.fletcher" diff --git a/basis/checksums/fletcher/fletcher-tests.factor b/basis/checksums/fletcher/fletcher-tests.factor new file mode 100644 index 0000000000..8f3a1f0421 --- /dev/null +++ b/basis/checksums/fletcher/fletcher-tests.factor @@ -0,0 +1,10 @@ +USING: checksums kernel sequences tools.test ; +IN: checksums.fletcher + +{ + { 51440 3948201259 14034561336514601929 } +} [ + "abcde" { fletcher-16 fletcher-32 fletcher-64 } + [ checksum-bytes ] with map +] unit-test + diff --git a/basis/checksums/fletcher/fletcher.factor b/basis/checksums/fletcher/fletcher.factor new file mode 100644 index 0000000000..257912d8a8 --- /dev/null +++ b/basis/checksums/fletcher/fletcher.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2013 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: checksums grouping io.binary kernel locals math sequences +; + +IN: checksums.fletcher + +SINGLETON: fletcher-16 +SINGLETON: fletcher-32 +SINGLETON: fletcher-64 + +INSTANCE: fletcher-16 checksum +INSTANCE: fletcher-32 checksum +INSTANCE: fletcher-64 checksum + +:: fletcher ( seq k -- n ) + k 16 / :> chars + k 2 / 2^ :> base + base 1 - :> modulo + 0 0 seq chars [ + be> + modulo mod [ + modulo mod ] keep + ] each [ base * ] [ + ] bi* ; inline + +M: fletcher-16 checksum-bytes drop 16 fletcher ; +M: fletcher-32 checksum-bytes drop 32 fletcher ; +M: fletcher-64 checksum-bytes drop 64 fletcher ; diff --git a/basis/checksums/fletcher/summary.txt b/basis/checksums/fletcher/summary.txt new file mode 100644 index 0000000000..489839537f --- /dev/null +++ b/basis/checksums/fletcher/summary.txt @@ -0,0 +1 @@ +Fletcher's checksum algorithm diff --git a/basis/checksums/internet/internet.factor b/basis/checksums/internet/internet.factor index 5d3b24b3e0..b8175a61d4 100644 --- a/basis/checksums/internet/internet.factor +++ b/basis/checksums/internet/internet.factor @@ -10,7 +10,7 @@ SINGLETON: internet ! RFC 1071 INSTANCE: internet checksum M: internet checksum-bytes - drop 0 swap 2 [ le> + ] each + drop 2 [ le> ] map-sum [ -16 shift ] [ 0xffff bitand ] bi + [ -16 shift ] keep + bitnot 2 >le ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 3f813dd387..13edf0ed50 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2006, 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.data kernel io io.binary io.files -io.streams.byte-array math math.functions math.parser namespaces -splitting grouping strings sequences byte-arrays locals -sequences.private macros fry io.encodings.binary math.bitwise -checksums accessors checksums.common checksums.stream -combinators combinators.smart specialized-arrays literals hints ; +USING: accessors alien.c-types alien.data byte-arrays checksums +checksums.common checksums.stream combinators fry grouping hints +kernel kernel.private literals locals macros math math.bitwise +math.functions sequences sequences.private specialized-arrays ; FROM: sequences.private => change-nth-unsafe ; SPECIALIZED-ARRAY: uint IN: checksums.md5 @@ -14,7 +12,9 @@ SINGLETON: md5 INSTANCE: md5 stream-checksum -TUPLE: md5-state < checksum-state state old-state ; +TUPLE: md5-state < checksum-state +{ state uint-array } +{ old-state uint-array } ; : ( -- md5 ) md5-state new-checksum-state @@ -26,16 +26,13 @@ M: md5 initialize-checksum-state drop ; > ] [ old-state>> v-w+ dup clone ] [ ] tri - [ old-state<< ] [ state<< ] bi ; + [ state>> ] [ old-state>> [ w+ ] 2map dup clone ] [ ] tri + [ old-state<< ] [ state<< ] bi ; inline -CONSTANT: T - $[ - 80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as - ] +CONSTANT: T $[ + 80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as +] :: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z @@ -84,14 +81,14 @@ CONSTANT: d 3 k x nth-unsafe w+ i T nth-unsafe w+ s bitroll-32 - b state nth-unsafe w+ 32 bits + b state nth-unsafe w+ ] change-nth-unsafe ; inline MACRO: with-md5-round ( ops quot -- ) '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ; : (process-md5-block-F) ( block state -- ) - { + { uint-array uint-array } declare { [ a b c d 0 S11 1 ] [ d a b c 1 S12 2 ] [ c d a b 2 S13 3 ] @@ -111,7 +108,7 @@ MACRO: with-md5-round ( ops quot -- ) } [ F ] with-md5-round ; : (process-md5-block-G) ( block state -- ) - { + { uint-array uint-array } declare { [ a b c d 1 S21 17 ] [ d a b c 6 S22 18 ] [ c d a b 11 S23 19 ] @@ -131,7 +128,7 @@ MACRO: with-md5-round ( ops quot -- ) } [ G ] with-md5-round ; : (process-md5-block-H) ( block state -- ) - { + { uint-array uint-array } declare { [ a b c d 5 S31 33 ] [ d a b c 8 S32 34 ] [ c d a b 11 S33 35 ] @@ -151,7 +148,7 @@ MACRO: with-md5-round ( ops quot -- ) } [ H ] with-md5-round ; : (process-md5-block-I) ( block state -- ) - { + { uint-array uint-array } declare { [ a b c d 0 S41 49 ] [ d a b c 7 S42 50 ] [ c d a b 14 S43 51 ] @@ -170,11 +167,6 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 9 S44 64 ] } [ I ] with-md5-round ; -HINTS: (process-md5-block-F) { uint-array md5-state } ; -HINTS: (process-md5-block-G) { uint-array md5-state } ; -HINTS: (process-md5-block-H) { uint-array md5-state } ; -HINTS: (process-md5-block-I) { uint-array md5-state } ; - : byte-array>le ( byte-array -- byte-array ) little-endian? [ dup 4 [ @@ -183,19 +175,11 @@ HINTS: (process-md5-block-I) { uint-array md5-state } ; ] each ] unless ; -: uint-array-cast-le ( byte-array -- uint-array ) - byte-array>le uint cast-array ; +HINTS: byte-array>le byte-array ; -HINTS: uint-array-cast-le byte-array ; - -: uint-array>byte-array-le ( uint-array -- byte-array ) - underlying>> byte-array>le ; - -HINTS: uint-array>byte-array-le uint-array ; - -M: md5-state checksum-block ( block state -- ) +M: md5-state checksum-block [ - [ uint-array-cast-le ] [ state>> ] bi* { + [ byte-array>le uint cast-array ] [ state>> ] bi* { [ (process-md5-block-F) ] [ (process-md5-block-G) ] [ (process-md5-block-H) ] @@ -205,18 +189,20 @@ M: md5-state checksum-block ( block state -- ) nip update-md5 ] 2bi ; -: md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ; +: md5>checksum ( md5 -- bytes ) + state>> underlying>> byte-array>le ; -M: md5-state clone ( md5 -- new-md5 ) +M: md5-state clone call-next-method [ clone ] change-state [ clone ] change-old-state ; -M: md5-state get-checksum ( md5 -- bytes ) - clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri +M: md5-state get-checksum + clone + [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri [ [ checksum-block ] curry each ] [ md5>checksum ] bi ; -M: md5 checksum-stream ( stream checksum -- byte-array ) +M: md5 checksum-stream drop [ ] dip add-checksum-stream get-checksum ; diff --git a/basis/checksums/murmur/authors.txt b/basis/checksums/murmur/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/checksums/murmur/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/checksums/murmur/murmur-docs.factor b/basis/checksums/murmur/murmur-docs.factor new file mode 100644 index 0000000000..da9f612075 --- /dev/null +++ b/basis/checksums/murmur/murmur-docs.factor @@ -0,0 +1,11 @@ +USING: help.markup help.syntax ; +IN: checksums.murmur + +HELP: murmur3-32 +{ $class-description "MurmurHash3 32-bit checksum algorithm." } ; + +ARTICLE: "checksums.murmur" "MurmurHash checksum" +"MurmurHash is a non-cryptographic hash function suitable for general hash-based lookup, created by Austin Appleby in 2008." +{ $subsections murmur3-32 } ; + +ABOUT: "checksums.murmur" diff --git a/basis/checksums/murmur/murmur-tests.factor b/basis/checksums/murmur/murmur-tests.factor new file mode 100644 index 0000000000..8a16c5a905 --- /dev/null +++ b/basis/checksums/murmur/murmur-tests.factor @@ -0,0 +1,38 @@ +USING: byte-arrays checksums fry kernel math sequences +tools.test ; +IN: checksums.murmur + +{ 455139366 } [ "asdf" >byte-array 0 checksum-bytes ] unit-test +{ 417250299 } [ "asdf" >byte-array 156 checksum-bytes ] unit-test +{ 3902511862 } [ "abcde" >byte-array 0 checksum-bytes ] unit-test +{ 2517562459 } [ "abcde" >byte-array 156 checksum-bytes ] unit-test +{ 2444432334 } [ "12345678" >byte-array 0 checksum-bytes ] unit-test +{ 2584512840 } [ "12345678" >byte-array 156 checksum-bytes ] unit-test +{ 3560398725 } [ "hello, world!!!" >byte-array 156 checksum-bytes ] unit-test + +{ + { + 3903553677 + 3120384252 + 3928660296 + 2995164002 + 500661690 + 2764333444 + 1941147762 + 161439790 + 2584512840 + 3803370487 + 626154228 + } +} [ + "1234567890" [ length 1 + ] keep 156 + '[ _ swap head _ checksum-bytes ] { } map-integers +] unit-test + + +{ t } [ + "1234567890" dup >byte-array [ + [ length 1 + ] keep 156 + '[ _ swap head _ checksum-bytes ] { } map-integers + ] bi@ = +] unit-test diff --git a/basis/checksums/murmur/murmur.factor b/basis/checksums/murmur/murmur.factor new file mode 100644 index 0000000000..441a59eaee --- /dev/null +++ b/basis/checksums/murmur/murmur.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2013 John Benediktsson. +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors alien alien.c-types alien.data byte-arrays +checksums fry grouping io.binary kernel math math.bitwise +math.ranges sequences ; + +IN: checksums.murmur + +TUPLE: murmur3-32 seed ; + +C: murmur3-32 + +CONSTANT: c1 0xcc9e2d51 +CONSTANT: c2 0x1b873593 +CONSTANT: r1 15 +CONSTANT: r2 13 +CONSTANT: m 5 +CONSTANT: n 0xe6546b64 + + ] dip + [ pick int deref hash-chunk ] reduce + ] [ + [ dup length 4 mod dupd head-slice* 4 ] dip + [ le> hash-chunk ] reduce + ] if ; inline + +: end-case ( seq hash -- hash' ) + swap dup length + [ 4 mod tail-slice* be> (hash-chunk) bitxor ] + [ bitxor ] bi 32 bits ; inline + +: avalanche ( hash -- hash' ) + [ -16 shift ] [ bitxor 0x85ebca6b w* ] bi + [ -13 shift ] [ bitxor 0xc2b2ae35 w* ] bi + [ -16 shift ] [ bitxor ] bi ; inline + +PRIVATE> + +M: murmur3-32 checksum-bytes ( bytes checksum -- value ) + seed>> 32 bits main-loop end-case avalanche ; + +INSTANCE: murmur3-32 checksum diff --git a/basis/checksums/murmur/summary.txt b/basis/checksums/murmur/summary.txt new file mode 100644 index 0000000000..4ac7b4acb2 --- /dev/null +++ b/basis/checksums/murmur/summary.txt @@ -0,0 +1 @@ +MurmurHash checksum algorithm diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor index fc4e96aee7..182dbe5e42 100644 --- a/basis/checksums/sha/sha.factor +++ b/basis/checksums/sha/sha.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors checksums checksums.common checksums.stream -combinators combinators.smart fry generalizations grouping -io.binary kernel literals locals make math math.bitwise -math.ranges multiline namespaces sbufs sequences -sequences.generalizations sequences.private splitting strings ; +USING: accessors arrays checksums checksums.common +checksums.stream combinators combinators.smart fry grouping +io.binary kernel literals locals math math.bitwise math.ranges +sequences sequences.generalizations sequences.private ; IN: checksums.sha SINGLETON: sha1 @@ -16,10 +15,14 @@ SINGLETON: sha-256 INSTANCE: sha-224 stream-checksum INSTANCE: sha-256 stream-checksum -TUPLE: sha1-state < checksum-state K H W word-size ; +TUPLE: sha1-state < checksum-state +{ K array } +{ H array } +{ W array } +{ word-size fixnum } ; CONSTANT: initial-H-sha1 - { + { 0x67452301 0xefcdab89 0x98badcfe @@ -36,7 +39,10 @@ CONSTANT: K-sha1 4 { } nappend-as ] -TUPLE: sha2-state < checksum-state K H word-size ; +TUPLE: sha2-state < checksum-state +{ K array } +{ H array } +{ word-size fixnum } ; TUPLE: sha2-short < sha2-state ; @@ -308,21 +314,21 @@ M: sha2-short checksum-block [ prepare-message-schedule ] [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ; -: sequence>byte-array ( seq n -- string ) - '[ _ >be ] map B{ } concat-as ; +: sequence>byte-array ( seq n -- bytes ) + '[ _ >be ] map B{ } concat-as ; inline : sha1>checksum ( sha2 -- bytes ) - H>> 4 sequence>byte-array ; + H>> 4 sequence>byte-array ; inline : sha-224>checksum ( sha2 -- bytes ) - H>> 7 head 4 sequence>byte-array ; + H>> 7 head 4 sequence>byte-array ; inline : sha-256>checksum ( sha2 -- bytes ) - H>> 4 sequence>byte-array ; + H>> 4 sequence>byte-array ; inline : pad-last-short-block ( state -- ) [ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri - [ checksum-block ] curry each ; + [ checksum-block ] curry each ; inline PRIVATE> @@ -349,7 +355,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) [ [ 14 - ] dip nth-unsafe bitxor ] [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ] [ ] - } 2cleave set-nth-unsafe ; + } 2cleave set-nth-unsafe ; inline : prepare-sha1-message-schedule ( seq -- w-seq ) 4 [ be> ] map @@ -363,7 +369,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) { 1 [ bitxor bitxor ] } { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] } { 3 [ bitxor bitxor ] } - } case ; + } case ; inline :: inner-loop ( n H W K -- temp ) a H nth-unsafe :> A @@ -374,16 +380,16 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) [ A 5 bitroll-32 - B C D n sha1-f + B C D n sha1-f E n K nth-unsafe n W nth-unsafe - ] sum-outputs 32 bits ; + ] sum-outputs 32 bits ; inline -:: process-sha1-chunk ( bytes H W K state -- ) +:: process-sha1-chunk ( H W K state -- ) 80 [ H W K inner-loop d H nth-unsafe e H set-nth-unsafe @@ -397,7 +403,6 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array ) M:: sha1-state checksum-block ( bytes state -- ) bytes prepare-sha1-message-schedule state W<< - bytes state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ; M: sha1-state get-checksum diff --git a/basis/checksums/superfast/authors.txt b/basis/checksums/superfast/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/checksums/superfast/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/checksums/superfast/summary.txt b/basis/checksums/superfast/summary.txt new file mode 100644 index 0000000000..fe5345add9 --- /dev/null +++ b/basis/checksums/superfast/summary.txt @@ -0,0 +1 @@ +SuperFastHash checksum algorithm diff --git a/basis/checksums/superfast/superfast-docs.factor b/basis/checksums/superfast/superfast-docs.factor new file mode 100644 index 0000000000..b20659cd66 --- /dev/null +++ b/basis/checksums/superfast/superfast-docs.factor @@ -0,0 +1,12 @@ +USING: help.markup help.syntax ; +IN: checksums.superfast + +HELP: superfast +{ $class-description "SuperFastHash checksum algorithm." } ; + +ARTICLE: "checksums.superfast" "SuperFastHash checksum" +"SuperFastHash is a hash, created by Paul Hsieh. For more information see: " +{ $url "http://www.azillionmonkeys.com/qed/hash.html" } +{ $subsections superfast } ; + +ABOUT: "checksums.superfast" diff --git a/basis/checksums/superfast/superfast-tests.factor b/basis/checksums/superfast/superfast-tests.factor new file mode 100644 index 0000000000..54b9bbc520 --- /dev/null +++ b/basis/checksums/superfast/superfast-tests.factor @@ -0,0 +1,30 @@ +USING: byte-arrays checksums fry kernel math sequences +tools.test ; +IN: checksums.superfast + +{ + { + 0 + 4064760690 + 2484602674 + 1021960881 + 3514307704 + 762925594 + 95280079 + 516333699 + 1761749771 + 3841726064 + 2549850032 + } +} [ + "1234567890" [ length 1 + ] keep 0 + '[ _ swap head _ checksum-bytes ] { } map-integers +] unit-test + + +{ t } [ + "1234567890" dup >byte-array [ + [ length 1 + ] keep 0 + '[ _ swap head _ checksum-bytes ] { } map-integers + ] bi@ = +] unit-test diff --git a/basis/checksums/superfast/superfast.factor b/basis/checksums/superfast/superfast.factor new file mode 100644 index 0000000000..c3b1545c50 --- /dev/null +++ b/basis/checksums/superfast/superfast.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2013 John Benediktsson. +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors alien alien.c-types alien.data byte-arrays +checksums combinators fry grouping io.binary kernel math +math.bitwise math.ranges sequences sequences.private ; + +IN: checksums.superfast + +TUPLE: superfast seed ; +C: superfast + + ] dip + [ pick int deref (main-loop) ] reduce + ] [ + [ dup length 4 mod dupd head-slice* 4 ] dip + [ le> (main-loop) ] reduce + ] if ; inline + +: end-case ( seq hash -- hash' ) + swap dup length 4 mod [ tail-slice* ] keep { + [ drop ] + [ + first + [ 10 shift ] [ bitxor ] bi 32 bits + [ -1 shift ] [ + ] bi + ] + [ + le> + [ 11 shift ] [ bitxor ] bi 32 bits + [ -17 shift ] [ + ] bi + ] + [ + unclip-last-slice + [ le> + [ 16 shift ] [ bitxor ] bi ] + [ 18 shift bitxor ] bi* 32 bits + [ -11 shift ] [ + ] bi + ] + } dispatch ; inline + +: avalanche ( hash -- hash' ) + [ 3 shift ] [ bitxor ] bi 32 bits [ -5 shift ] [ + ] bi + [ 4 shift ] [ bitxor ] bi 32 bits [ -17 shift ] [ + ] bi + [ 25 shift ] [ bitxor ] bi 32 bits [ -6 shift ] [ + ] bi ; inline + +PRIVATE> + +M: superfast checksum-bytes + seed>> 32 bits main-loop end-case avalanche ; diff --git a/basis/checksums/xxhash/authors.txt b/basis/checksums/xxhash/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/checksums/xxhash/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/checksums/xxhash/summary.txt b/basis/checksums/xxhash/summary.txt new file mode 100644 index 0000000000..4d3a9eafab --- /dev/null +++ b/basis/checksums/xxhash/summary.txt @@ -0,0 +1 @@ +xxHash checksum algorithm diff --git a/basis/checksums/xxhash/xxhash-docs.factor b/basis/checksums/xxhash/xxhash-docs.factor new file mode 100644 index 0000000000..f5b18b6504 --- /dev/null +++ b/basis/checksums/xxhash/xxhash-docs.factor @@ -0,0 +1,11 @@ +USING: help.markup help.syntax ; +IN: checksums.xxhash + +HELP: xxhash +{ $class-description "xxHash 32-bit checksum algorithm." } ; + +ARTICLE: "checksums.xxhash" "XxHash checksum" +"xxHash is a non-cryptographic hash function suitable for general hash-based lookup." +{ $subsections xxhash } ; + +ABOUT: "checksums.xxhash" diff --git a/basis/checksums/xxhash/xxhash-tests.factor b/basis/checksums/xxhash/xxhash-tests.factor new file mode 100644 index 0000000000..052807b0ae --- /dev/null +++ b/basis/checksums/xxhash/xxhash-tests.factor @@ -0,0 +1,8 @@ +USING: byte-arrays checksums tools.test ; +IN: checksums.xxhash + +{ 1584409650 } [ "asdf" 0 checksum-bytes ] unit-test +{ 4257502458 } [ "Hello World!" 12345 checksum-bytes ] unit-test + +{ 1584409650 } [ "asdf" >byte-array 0 checksum-bytes ] unit-test +{ 4257502458 } [ "Hello World!" >byte-array 12345 checksum-bytes ] unit-test diff --git a/basis/checksums/xxhash/xxhash.factor b/basis/checksums/xxhash/xxhash.factor new file mode 100644 index 0000000000..ea6869e482 --- /dev/null +++ b/basis/checksums/xxhash/xxhash.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2014 John Benediktsson. +! See http://factorcode.org/license.txt for BSD license. + +USING: accessors alien alien.c-types alien.data byte-arrays +checksums combinators generalizations grouping io.binary kernel +locals math math.bitwise math.ranges sequences ; + +IN: checksums.xxhash + +CONSTANT: prime1 2654435761 +CONSTANT: prime2 2246822519 +CONSTANT: prime3 3266489917 +CONSTANT: prime4 668265263 +CONSTANT: prime5 374761393 + +TUPLE: xxhash seed ; + +C: xxhash + + + bytes byte-array? little-endian? and + [ c-type cast-array ] + [ c-type heap-size [ le> ] map ] if ; inline + +PRIVATE> + +M:: xxhash checksum-bytes ( bytes checksum -- value ) + checksum seed>> :> seed + bytes length :> len + + len dup 16 mod - :> len/16 + len dup 4 mod - :> len/4 + + len 16 >= [ + + seed prime1 w+ prime2 w+ + seed prime2 w+ + seed + seed prime1 w- + + 0 len/16 bytes uint native-mapper + + 4 [ + first4 + [ prime2 w* w+ 13 bitroll-32 prime1 w* ] + 4 napply + ] each + + { + [ 1 bitroll-32 ] + [ 7 bitroll-32 ] + [ 12 bitroll-32 ] + [ 18 bitroll-32 ] + } spread w+ w+ w+ + ] [ + seed prime5 w+ + ] if + + len w+ + + len/16 len/4 bytes uint native-mapper + [ prime3 w* w+ 17 bitroll-32 prime4 w* ] each + + bytes len/4 tail-slice + [ prime5 w* w+ 11 bitroll-32 prime1 w* ] each + + [ -15 shift ] [ bitxor ] bi prime2 w* + [ -13 shift ] [ bitxor ] bi prime3 w* + [ -16 shift ] [ bitxor ] bi ; + +INSTANCE: xxhash checksum diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor index 93d137d626..9dcf4817ce 100644 --- a/basis/circular/circular-docs.factor +++ b/basis/circular/circular-docs.factor @@ -55,6 +55,14 @@ HELP: circular-while } { $description "Calls " { $snippet "quot" } " on each element of the sequence until each call yields " { $link f } " in succession." } ; +HELP: circular-loop +{ $values + { "circular" circular } + { "quot" quotation } +} +{ $description "Calls " { $snippet "quot" } " on each element of the sequence until one call yields " { $link f } "." } +{ $notes "This rotates the " { $link circular } " object after each call, so the next element to be applied will always be the first element." } ; + ARTICLE: "circular" "Circular sequences" "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl "Creating a new circular object:" @@ -74,6 +82,6 @@ ARTICLE: "circular" "Circular sequences" growing-circular-push } "Iterating over a circular until a stop condition:" -{ $subsections circular-while } ; +{ $subsections circular-while circular-loop } ; ABOUT: "circular" diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index a3b1d5541c..c83d4eb897 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license -USING: arrays kernel tools.test sequences sequences.private -circular strings ; +USING: arrays circular kernel math sequences sequences.private +strings tools.test ; IN: circular.tests [ 0 ] [ { 0 1 2 3 4 } 0 swap virtual@ drop ] unit-test @@ -42,3 +42,35 @@ IN: circular.tests swap growing-circular-push ] with each >array ] unit-test + +[ V{ 1 2 3 } ] [ + { 1 2 3 } V{ } [ + [ push f ] curry circular-while + ] keep +] unit-test + +CONSTANT: test-sequence1 { t f f f } +[ V{ 1 2 3 1 } ] [ + { 1 2 3 } V{ } [ + [ [ push ] [ length 1 - test-sequence1 nth ] bi ] curry circular-while + ] keep +] unit-test + +CONSTANT: test-sequence2 { t f t t f f t t t f f f } +[ V{ 1 2 3 1 2 3 1 2 3 1 2 3 } ] [ + { 1 2 3 } V{ } [ + [ [ push ] [ length 1 - test-sequence2 nth ] bi ] curry circular-while + ] keep +] unit-test + +[ V{ 1 2 3 1 2 } ] [ + { 1 2 3 } V{ } [ + [ [ push ] [ length 5 < ] bi ] curry circular-loop + ] keep +] unit-test + +[ V{ 1 } ] [ + { 1 2 3 } V{ } [ + [ push f ] curry circular-loop + ] keep +] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index f199413f86..9eba3c94ad 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -60,14 +60,14 @@ TUPLE: circular-iterator { circular read-only } { n integer } { last-start integer } ; : ( circular -- obj ) - 0 0 circular-iterator boa ; inline + 0 -1 circular-iterator boa ; inline > ] [ circular>> ] bi nth ] dip call ] 2keep rot [ [ dup n>> >>last-start ] dip ] when - over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [ + over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + ] bi = [ 2drop ] [ [ [ 1 + ] change-n ] dip (circular-while) @@ -77,3 +77,6 @@ PRIVATE> : circular-while ( ... circular quot: ( ... obj -- ... ? ) -- ... ) [ clone ] dip [ ] dip (circular-while) ; inline + +: circular-loop ( ... circular quot: ( ... obj -- ... ? ) -- ... ) + [ clone ] dip '[ [ first @ ] [ rotate-circular ] bi ] curry loop ; inline diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index c90ae52211..d603e3233a 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -250,7 +250,9 @@ M: struct-bit-slot-spec compute-slot-offset PRIVATE> -M: struct byte-length class-of "struct-size" word-prop ; inline foldable +: struct-size ( class -- n ) "struct-size" word-prop ; inline + +M: struct byte-length class-of struct-size ; inline foldable M: struct binary-zero? binary-object uchar [ 0 = ] all? ; inline ! class definition diff --git a/basis/cocoa/apple-script/apple-script-docs.factor b/basis/cocoa/apple-script/apple-script-docs.factor new file mode 100644 index 0000000000..8013bd2f9f --- /dev/null +++ b/basis/cocoa/apple-script/apple-script-docs.factor @@ -0,0 +1,13 @@ +USING: help.markup help.syntax strings ; + +IN: cocoa.apple-script + +HELP: run-apple-script +{ $values { "str" string } } +{ $description "Runs the provided uncompiled AppleScript code." } +{ $notes "Currently, return values are unsupported." } ; + +HELP: APPLESCRIPT: +{ $syntax "APPLESCRIPT: word ...applescript... ;APPLESCRIPT" } +{ $values { "word" "a new word to define" } { "...applescript..." "AppleScript source text" } } +{ $description "Defines a word that when called will run the provided uncompiled AppleScript. The word has stack effect " { $snippet "( -- )" } " due to return values being currently unsupported." } ; diff --git a/basis/cocoa/apple-script/apple-script.factor b/basis/cocoa/apple-script/apple-script.factor new file mode 100644 index 0000000000..f3cb8ec798 --- /dev/null +++ b/basis/cocoa/apple-script/apple-script.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2013 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: cocoa cocoa.application cocoa.classes kernel parser +multiline words ; + +IN: cocoa.apple-script + +: run-apple-script ( str -- ) + [ NSAppleScript -> alloc ] dip + -> initWithSource: -> autorelease + f -> executeAndReturnError: drop ; + +SYNTAX: APPLESCRIPT: + scan-new-word ";APPLESCRIPT" parse-multiline-string + [ run-apple-script ] curry ( -- ) define-declared ; diff --git a/basis/cocoa/apple-script/authors.txt b/basis/cocoa/apple-script/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/cocoa/apple-script/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/cocoa/apple-script/platforms.txt b/basis/cocoa/apple-script/platforms.txt new file mode 100644 index 0000000000..6e806f449e --- /dev/null +++ b/basis/cocoa/apple-script/platforms.txt @@ -0,0 +1 @@ +macosx diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index c90e238ede..58d7bb133a 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -1,17 +1,15 @@ ! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: compiler io kernel cocoa.runtime cocoa.subclassing -cocoa.messages cocoa.types sequences words vocabs parser -core-foundation.bundles namespaces assocs hashtables -compiler.units lexer init ; +USING: cocoa.messages compiler.units core-foundation.bundles +hashtables init io kernel lexer namespaces sequences vocabs ; FROM: cocoa.messages => selector ; IN: cocoa +SYMBOL: sent-messages + : (remember-send) ( selector variable -- ) [ dupd ?set-at ] change-global ; -SYMBOL: sent-messages - : remember-send ( selector -- ) sent-messages (remember-send) ; @@ -22,12 +20,6 @@ SYNTAX: SEL: [ remember-send ] [ suffix! \ selector suffix! ] bi ; -SYNTAX: SEND: - scan-token - [ remember-send ] - [ suffix! \ selector suffix! ] - [ suffix! \ lookup-sender suffix! ] tri ; - SYMBOL: super-sent-messages : remember-super-send ( selector -- ) @@ -52,6 +44,7 @@ SYNTAX: IMPORT: scan-token [ ] import-objc-class ; [ { "NSAlert" + "NSAppleScript" "NSApplication" "NSArray" "NSAutoreleasePool" diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index f4d1053f0a..a78a29bd7f 100644 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/basis/cocoa/enumeration/enumeration.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel classes.struct cocoa cocoa.runtime cocoa.types alien.data -locals math sequences vectors fry libc destructors specialized-arrays ; +USING: accessors alien.data assocs classes.struct cocoa +cocoa.runtime cocoa.types destructors fry hashtables kernel libc +locals sequences specialized-arrays vectors ; SPECIALIZED-ARRAY: id IN: cocoa.enumeration @@ -32,3 +33,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16 : NSFastEnumeration>vector ( object -- vector ) [ ] NSFastEnumeration-map ; + +: NSFastEnumeration>hashtable ( ... object quot: ( ... elt -- ... key value ) -- ... vector ) + NS-EACH-BUFFER-SIZE + [ '[ @ swap _ set-at ] NSFastEnumeration-each ] keep ; inline diff --git a/basis/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor index 7dee15d2e2..a0eed26c5b 100644 --- a/basis/cocoa/messages/messages-docs.factor +++ b/basis/cocoa/messages/messages-docs.factor @@ -31,7 +31,7 @@ HELP: alien>objc-types { objc>alien-types alien>objc-types } related-words HELP: import-objc-class -{ $values { "name" string } { "quot" { $quotation "( -- )" } } } +{ $values { "name" string } { "quot" { $quotation ( -- ) } } } { $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ; HELP: root-class diff --git a/basis/cocoa/messages/messages-tests.factor b/basis/cocoa/messages/messages-tests.factor new file mode 100644 index 0000000000..c51511ce24 --- /dev/null +++ b/basis/cocoa/messages/messages-tests.factor @@ -0,0 +1,8 @@ +USING: alien.c-types cocoa.runtime tools.test ; +IN: cocoa.messages + +{ "( sender-stub:void() )" } +[ { void { } } sender-stub-name ] unit-test + +{ "( sender-stub:id(id,SEL,void*,Class) )" } +[ { id { id SEL void* Class } } sender-stub-name ] unit-test diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index de3d6c3d94..155c39c25c 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -14,8 +14,13 @@ SPECIALIZED-ARRAY: void* : make-sender ( signature function -- quot ) [ over first , f , , second , \ alien-invoke , ] [ ] make ; -: sender-stub ( name signature function -- word ) - [ "( sender-stub:" ")" surround f dup ] 2dip +: sender-stub-name ( signature -- str ) + first2 [ name>> ] [ + [ name>> ] map "," join "(" ")" surround + ] bi* append "( sender-stub:" " )" surround ; + +: sender-stub ( signature function -- word ) + [ [ sender-stub-name f dup ] keep ] dip over first large-struct? [ "_stret" append ] when make-sender dup infer define-declared ; @@ -25,13 +30,13 @@ SYMBOL: super-message-senders message-senders [ H{ } clone ] initialize super-message-senders [ H{ } clone ] initialize -:: cache-stub ( name signature function assoc -- ) - signature assoc [ [ name ] dip function sender-stub ] cache drop ; +:: cache-stub ( signature function assoc -- ) + signature assoc [ function sender-stub ] cache drop ; -: cache-stubs ( name signature -- ) +: cache-stubs ( signature -- ) [ "objc_msgSendSuper" super-message-senders get cache-stub ] [ "objc_msgSend" message-senders get cache-stub ] - 2bi ; + bi ; : ( receiver -- super ) [ ] [ object_getClass class_getSuperclass ] bi @@ -224,7 +229,7 @@ ERROR: no-objc-type name ; : register-objc-method ( method -- ) [ method-name ] [ [ method-return-type ] [ method-arg-types ] bi 2array ] bi - [ cache-stubs ] [ swap objc-methods get set-at ] 2bi ; + [ nip cache-stubs ] [ swap objc-methods get set-at ] 2bi ; : each-method-in-class ( class quot -- ) [ { uint } [ class_copyMethodList ] with-out-parameters ] dip diff --git a/basis/cocoa/nibs/nibs-docs.factor b/basis/cocoa/nibs/nibs-docs.factor index ff53cb0b58..b1c3f2a04e 100644 --- a/basis/cocoa/nibs/nibs-docs.factor +++ b/basis/cocoa/nibs/nibs-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax strings ; +USING: help.markup help.syntax sequences strings ; IN: cocoa.nibs HELP: load-nib @@ -11,6 +11,6 @@ HELP: nib-named { $see-also nib-objects } ; HELP: nib-objects -{ $values { "anNSNib" "an instance of NSNib" } { "objects/f" "a sequence" } } +{ $values { "anNSNib" "an instance of NSNib" } { "objects/f" { $maybe sequence } } } { $description "Instantiates the top-level objects of the " { $snippet ".nib" } " file loaded by anNSNib. First create an NSNib instance using " { $link nib-named } "." } -{ $see-also nib-named } ; \ No newline at end of file +{ $see-also nib-named } ; diff --git a/basis/cocoa/pasteboard/pasteboard-docs.factor b/basis/cocoa/pasteboard/pasteboard-docs.factor index f63bc0ec47..e6af5ab6b6 100644 --- a/basis/cocoa/pasteboard/pasteboard-docs.factor +++ b/basis/cocoa/pasteboard/pasteboard-docs.factor @@ -1,8 +1,8 @@ -USING: help.markup help.syntax strings ; +USING: help.markup help.syntax kernel strings ; IN: cocoa.pasteboard HELP: pasteboard-string? -{ $values { "pasteboard" "an " { $snippet "NSPasteBoard" } } { "?" "a boolean" } } +{ $values { "pasteboard" "an " { $snippet "NSPasteBoard" } } { "?" boolean } } { $description "Tests if the pasteboard holds a string." } ; HELP: pasteboard-string diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index 0ac7a43229..63662d5489 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -30,8 +30,8 @@ DEFER: plist> [ plist> ] NSFastEnumeration-map ; : (plist-NSDictionary>) ( NSDictionary -- hashtable ) - dup [ [ nip ] [ -> valueForKey: ] 2bi [ plist> ] bi@ 2array ] with - NSFastEnumeration-map >hashtable ; + dup [ [ nip ] [ -> valueForKey: ] 2bi [ plist> ] bi@ ] with + NSFastEnumeration>hashtable ; : (read-plist) ( NSData -- id ) NSPropertyListSerialization swap kCFPropertyListImmutable f diff --git a/basis/colors/colors.factor b/basis/colors/colors.factor index 5932d0ff15..9e5fef1134 100644 --- a/basis/colors/colors.factor +++ b/basis/colors/colors.factor @@ -16,11 +16,11 @@ C: rgba GENERIC: >rgba ( color -- rgba ) -M: rgba >rgba ( rgba -- rgba ) ; inline +M: rgba >rgba ; inline -M: color red>> ( color -- red ) >rgba red>> ; -M: color green>> ( color -- green ) >rgba green>> ; -M: color blue>> ( color -- blue ) >rgba blue>> ; +M: color red>> >rgba red>> ; +M: color green>> >rgba green>> ; +M: color blue>> >rgba blue>> ; : >rgba-components ( object -- r g b a ) >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline diff --git a/basis/colors/gray/gray.factor b/basis/colors/gray/gray.factor index 532a091c07..c6f576f58c 100644 --- a/basis/colors/gray/gray.factor +++ b/basis/colors/gray/gray.factor @@ -16,7 +16,11 @@ M: gray green>> gray>> ; M: gray blue>> gray>> ; -: rgba>gray ( rgba -- gray ) +GENERIC: >gray ( color -- gray ) + +M: object >gray >rgba >gray ; + +M: rgba >gray >rgba-components [ [ 0.3 * ] [ 0.59 * ] [ 0.11 * ] tri* + + ] dip ; diff --git a/basis/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor index d00df1a8f1..194845efd1 100644 --- a/basis/colors/hsv/hsv.factor +++ b/basis/colors/hsv/hsv.factor @@ -49,7 +49,13 @@ M: hsva >rgba ( hsva -- rgba ) PRIVATE> -:: rgba>hsva ( rgba -- hsva ) +GENERIC: >hsva ( color -- hsva ) + +M: object >hsva >rgba >hsva ; + +M: hsva >hsva ; inline + +M:: rgba >hsva ( rgba -- hsva ) rgba >rgba-components :> ( r g b a ) r g b sort-triple :> ( z y x ) x z = x zero? or [ 0 0 x a ] [ @@ -64,7 +70,7 @@ PRIVATE> ] if ; : complimentary-color ( color -- color' ) - dup hsva? [ >rgba rgba>hsva ] unless + dup hsva? [ >hsva ] unless { [ hue>> 180 + 360 mod ] [ saturation>> ] diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index f775c2f24c..9e59d5ee9e 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -29,8 +29,8 @@ PRIVATE> : 0&& ( quots -- ? ) [ ] unoptimized-&& ; : 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ; -: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ; -: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ; +: 2&& ( obj1 obj2 quots -- ? ) [ 2with ] unoptimized-&& ; +: 3&& ( obj1 obj2 obj3 quots -- ? ) [ 3 nwith ] unoptimized-&& ; MACRO: n|| ( quots n -- quot ) [ @@ -51,5 +51,5 @@ PRIVATE> : 0|| ( quots -- ? ) [ ] unoptimized-|| ; : 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ; -: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ; -: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ; +: 2|| ( obj1 obj2 quots -- ? ) [ 2with ] unoptimized-|| ; +: 3|| ( obj1 obj2 obj3 quots -- ? ) [ 3 nwith ] unoptimized-|| ; diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index cab79ad675..a92067d34d 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -228,7 +228,7 @@ HELP: smart-when* HELP: smart-with { $values - { "param" object } { "obj" object } { "quot" { $quotation "( param ..a -- ..b" } } { "curry" curry } } + { "param" object } { "obj" object } { "quot" { $quotation "( param ..a -- ..b )" } } { "curry" curry } } { $description "A version of " { $link with } " that puts the parameter before any inputs the quotation uses." } ; HELP: smart-reduce diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index 493b39a9eb..e97c65038c 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -67,7 +67,7 @@ M: object infer-known* drop f ; : output>array ( quot -- array ) { } output>sequence ; inline -: cleave>array ( x seq -- array ) +: cleave>array ( obj quots -- array ) '[ _ cleave ] output>array ; inline : cleave>sequence ( x seq exemplar -- array ) diff --git a/basis/command-line/command-line-tests.factor b/basis/command-line/command-line-tests.factor new file mode 100644 index 0000000000..01099ae19d --- /dev/null +++ b/basis/command-line/command-line-tests.factor @@ -0,0 +1,32 @@ +USING: namespaces splitting tools.test ; +IN: command-line + +{ f { "a" "b" "c" } } [ + { "-run=test-voc" "a" "b" "c" } parse-command-line + script get command-line get +] unit-test + +{ f { "-a" "b" "c" } } [ + { "-run=test-voc" "-a" "b" "c" } parse-command-line + script get command-line get +] unit-test + +{ f { "a" "-b" "c" } } [ + { "-run=test-voc" "a" "-b" "c" } parse-command-line + script get command-line get +] unit-test + +{ f { "a" "b" "-c" } } [ + { "-run=test-voc" "a" "b" "-c" } parse-command-line + script get command-line get +] unit-test + +{ "a" { "b" "c" } } [ + { "a" "b" "c" } parse-command-line + script get command-line get +] unit-test + +{ "a" { "b" "c" } } [ + { "-foo" "a" "b" "c" } parse-command-line + script get command-line get +] unit-test diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 8f38208c89..37511dae90 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -62,18 +62,21 @@ SYMBOL: command-line [ source-file main>> [ execute( -- ) ] when* ] bi ] with-variable ; -: (parse-command-line) ( run? args -- ) - [ command-line off script off drop ] [ - unclip "-" ?head - [ param (parse-command-line) ] - [ - rot [ prefix f ] when +: (parse-command-line) ( args -- ) + [ + unclip "-" ?head [ + [ param ] [ "run=" head? ] bi + [ command-line set ] + [ (parse-command-line) ] if + ] [ script set command-line set ] if - ] if-empty ; + ] unless-empty ; : parse-command-line ( args -- ) - [ [ "-run=" head? ] any? ] keep (parse-command-line) ; + command-line off + script off + (parse-command-line) ; SYMBOL: main-vocab-hook diff --git a/basis/compiler/cfg/block-joining/block-joining-docs.factor b/basis/compiler/cfg/block-joining/block-joining-docs.factor new file mode 100644 index 0000000000..c16e6b46fa --- /dev/null +++ b/basis/compiler/cfg/block-joining/block-joining-docs.factor @@ -0,0 +1,6 @@ +USING: compiler.cfg help.markup help.syntax ; +IN: compiler.cfg.block-joining + +HELP: join-block? +{ $values { "bb" basic-block } { "?" "a boolean" } } +{ $description "Whether the block can be joined with its predecessor or not." } ; diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 0222df9ad0..157fd355cd 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -44,7 +44,7 @@ IN: compiler.cfg.branch-splitting : update-successor-predecessors ( copies old-bb -- ) dup successors>> - [ update-successor-predecessor ] with with each ; + [ update-successor-predecessor ] 2with each ; : split-branch ( bb -- ) [ new-blocks ] keep diff --git a/basis/compiler/cfg/builder/alien/alien-docs.factor b/basis/compiler/cfg/builder/alien/alien-docs.factor new file mode 100644 index 0000000000..0899fd4918 --- /dev/null +++ b/basis/compiler/cfg/builder/alien/alien-docs.factor @@ -0,0 +1,21 @@ +USING: help.markup help.syntax literals make multiline stack-checker.alien ; +IN: compiler.cfg.builder.alien + +<< +STRING: ex-caller-return +USING: compiler.cfg.builder.alien make prettyprint ; +[ + T{ ##alien-invoke { reg-outputs { { 1 int-rep RAX } } } } , + T{ alien-invoke-params { return pointer: void } } caller-return +] { } make . +{ + T{ ##alien-invoke { reg-outputs { { 1 int-rep RAX } } } } + T{ ##box-alien { dst 116 } { src 1 } { temp 115 } } +} +; +>> + +HELP: caller-return +{ $values { "params" alien-node-params } } +{ $description "If the last alien call returns a value, then this word will emit an instruction to the current sequence being constructed by " { $link make } " that boxes it." } +{ $examples { $unchecked-example $[ ex-caller-return ] } } ; diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing-docs.factor b/basis/compiler/cfg/builder/alien/boxing/boxing-docs.factor new file mode 100644 index 0000000000..742ed07f6e --- /dev/null +++ b/basis/compiler/cfg/builder/alien/boxing/boxing-docs.factor @@ -0,0 +1,52 @@ +USING: alien.c-types compiler.cfg.instructions help.markup help.syntax make +math ; +IN: compiler.cfg.builder.alien.boxing + +HELP: box +{ $values + { "vregs" "a one-element sequence containing a virtual register indentifier" } + { "reps" "a one-element sequence containing a representation symbol" } + { "c-type" c-type } + { "dst" "box" } +} +{ $description "Emits a " { $link ##box-alien } " instruction which boxes an alien value contained in the given register." } +{ $examples + { $unchecked-example + "USING: compiler.cfg.builder.alien.boxing make prettyprint ;" + "{ 71 } { int-rep } void* base-type [ box ] { } make nip ." + "{ T{ ##box-alien { dst 105 } { src 71 } { temp 104 } } }" + } +} +{ $see-also ##box-alien } ; + +HELP: box-return +{ $values + { "vregs" "vregs that contains the return value of the alien call" } + { "reps" "representations of the vregs" } + { "c-type" abstract-c-type } + { "dst" "vreg in which the boxed value, or a reference to it, will be placed" } +} +{ $description "Emits instructions for boxing the return value from an alien function call." } +{ $examples + { $unchecked-example + "USING: compiler.cfg.builder.alien.boxing kernel make prettyprint ;" + "[ { 10 } { tagged-rep } int base-type box-return drop ] { } make ." + "{ T{ ##convert-integer { dst 118 } { src 10 } { c-type int } } }" + } +} +{ $see-also ##box-alien } ; + +HELP: stack-size +{ $values + { "c-type" c-type } + { "n" number } +} +{ $description "Calculates how many bytes of stack space an instance of the C type requires." } +{ $examples + { $unchecked-example + "USING: compiler.cfg.builder.alien.boxing prettyprint vm ;" + "context base-type stack-size ." + "144" + } +} +{ $see-also heap-size } ; diff --git a/basis/compiler/cfg/builder/alien/params/params-docs.factor b/basis/compiler/cfg/builder/alien/params/params-docs.factor new file mode 100644 index 0000000000..f6599ebc11 --- /dev/null +++ b/basis/compiler/cfg/builder/alien/params/params-docs.factor @@ -0,0 +1,17 @@ +USING: cpu.architecture help.markup help.syntax math ; +IN: compiler.cfg.builder.alien.params + +HELP: stack-params +{ $var-description "Count of the number of bytes of stack allocation required to store the current call frames parameters." } ; + +HELP: alloc-stack-param +{ $values { "rep" representation } { "n" integer } } +{ $description "Allocates space for a stack parameter value of the given representation and returns the previous stack parameter offset." } +{ $examples + "On 32-bit architectures, the offsets will be aligned to four byte boundaries." + { $unchecked-example + "0 stack-params set float-rep alloc-stack-param stack-params get . ." + "4" + "0" + } +} ; diff --git a/basis/compiler/cfg/builder/alien/params/params.factor b/basis/compiler/cfg/builder/alien/params/params.factor index ff7d11b4e3..7b45d247c7 100644 --- a/basis/compiler/cfg/builder/alien/params/params.factor +++ b/basis/compiler/cfg/builder/alien/params/params.factor @@ -6,7 +6,7 @@ IN: compiler.cfg.builder.alien.params SYMBOL: stack-params -GENERIC: alloc-stack-param ( reg -- n ) +GENERIC: alloc-stack-param ( rep -- n ) M: object alloc-stack-param ( rep -- n ) stack-params get diff --git a/basis/compiler/cfg/builder/blocks/blocks-docs.factor b/basis/compiler/cfg/builder/blocks/blocks-docs.factor new file mode 100644 index 0000000000..b8cb49a224 --- /dev/null +++ b/basis/compiler/cfg/builder/blocks/blocks-docs.factor @@ -0,0 +1,55 @@ +USING: compiler.cfg compiler.tree help.markup help.syntax literals math +multiline quotations ; +IN: compiler.cfg.builder.blocks + +<< +STRING: ex-emit-trivial-block +USING: compiler.cfg.builder.blocks prettyprint ; +initial-basic-block [ [ gensym ##call, ] emit-trivial-block ] { } make drop +basic-block get . +T{ basic-block + { id 2040412 } + { successors + V{ + T{ basic-block + { id 2040413 } + { instructions + V{ + T{ ##call { word ( gensym ) } } + T{ ##branch } + } + } + { successors + V{ T{ basic-block { id 2040414 } } } + } + } + } + } +} +; +>> + +HELP: begin-basic-block +{ $description "Terminates the current block and initializes a new " { $link basic-block } " to begin outputting instructions to. The new block is included in the old blocks " { $slot "successors" } "." } ; + +HELP: call-height +{ $values { "#call" #call } { "n" number } } +{ $description "Calculates how many items a " { $link #call } " will add or remove from the data stack." } +{ $examples + { $example + "USING: compiler.cfg.builder.blocks compiler.tree.builder prettyprint sequences ;" + "[ 3append ] build-tree second call-height ." + "-2" + } +} ; + +HELP: emit-trivial-block +{ $values { "quot" quotation } } +{ $description "Combinator that emits a trivial block, constructed by calling the supplied quotation." } +{ $examples { $unchecked-example $[ ex-emit-trivial-block ] } } ; + +HELP: initial-basic-block +{ $description "Creates an initial empty " { $link basic-block } " and stores it in the basic-block dynamic variable." } ; + +HELP: make-kill-block +{ $description "Marks the current " { $link basic-block } " being processed as a kill block." } ; diff --git a/basis/compiler/cfg/builder/builder-docs.factor b/basis/compiler/cfg/builder/builder-docs.factor new file mode 100644 index 0000000000..9f0671388b --- /dev/null +++ b/basis/compiler/cfg/builder/builder-docs.factor @@ -0,0 +1,82 @@ +USING: assocs compiler.cfg compiler.cfg.builder.blocks +compiler.cfg.stacks.local compiler.tree help.markup help.syntax literals math +multiline sequences words ; +IN: compiler.cfg.builder + +<< +STRING: ex-emit-call +USING: compiler.cfg.builder compiler.cfg.builder.blocks compiler.cfg.stacks +kernel make prettyprint ; +begin-stack-analysis initial-basic-block \ dummy 3 [ emit-call ] { } make drop +current-height basic-block [ get . ] bi@ . +T{ current-height { d 3 } } +T{ basic-block + { id 134 } + { successors + V{ + T{ basic-block + { id 135 } + { instructions + V{ + T{ ##call { word dummy } } + T{ ##branch } + } + } + { successors V{ T{ basic-block { id 136 } } } } + { kill-block? t } + } + } + } +} +; + +STRING: ex-make-input-map +USING: compiler.cfg.builder prettyprint ; +T{ #shuffle { in-d { 37 81 92 } } } make-input-map . +H{ + { 81 T{ ds-loc { n 1 } } } + { 37 T{ ds-loc { n 2 } } } + { 92 T{ ds-loc } } +} +; +>> + +HELP: procedures +{ $var-description "Used as a temporary storage for the current cfg during construction of all cfgs." } ; + +HELP: make-input-map +{ $values { "#shuffle" #shuffle } { "assoc" assoc } } +{ $description "Creates an " { $link assoc } " that maps input values to the shuffle operation to stack locations." } +{ $examples { $unchecked-example $[ ex-make-input-map ] } } ; + +HELP: emit-call +{ $values { "word" word } { "height" number } } +{ $description "Emits a call to the given word to the " { $link cfg } " being constructed. \"height\" is the number of items being added to or removed from the data stack. Side effects of the word is that it modifies the \"basic-block\" and " { $link current-height } " variables." } +{ $examples + "In this example, a call to a dummy word is emitted which pushes three items onto the stack." + { $unchecked-example $[ ex-emit-call ] } +} +{ $see-also call-height } ; + +HELP: emit-node +{ $values { "node" node } } +{ $description "Emits CFG instructions for the given SSA node." } ; + +HELP: trivial-branch? +{ $values + { "nodes" "a " { $link sequence } " of " { $link node } " instances" } + { "value" "the pushed value or " { $link f } } + { "?" "a boolean" } +} +{ $description "Checks whether nodes is a trivial branch or not. The branch is counted as trivial if all it does is push a literal value on the stack." } +{ $examples + { $example + "USING: compiler.cfg.builder compiler.tree prettyprint ;" + "{ T{ #push { literal 25 } } } trivial-branch? . ." + "t\n25" + } +} ; + +HELP: build-cfg +{ $values { "nodes" sequence } { "word" word } { "procedures" sequence } } +{ $description "Builds one or more cfgs from the given word." } ; diff --git a/basis/compiler/cfg/cfg-docs.factor b/basis/compiler/cfg/cfg-docs.factor new file mode 100644 index 0000000000..67e3a81254 --- /dev/null +++ b/basis/compiler/cfg/cfg-docs.factor @@ -0,0 +1,36 @@ +USING: compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.stack-frame compiler.tree help.markup help.syntax namespaces +sequences vectors words ; +IN: compiler.cfg + +HELP: basic-block +{ $class-description + "Factors representation of a basic block in the Call Flow Graph (CFG). A basic block is a sequence of instructions that always are executed sequentially and doesn't contain any branching. It has the following slots:" + { $table + { { $slot "successors" } { "A " { $link vector } " of basic blocks that may be executed directly after this block. Most blocks only have one successor but a block that checks where an if-condition should branch to would have two for example." } } + { { $slot "predecessors" } { "The opposite of successors -- a " { $link vector } " of basic blocks from which the execution may have arrived into this block." } } + { { $slot "instructions" } { "A " { $link vector } " of " { $link insn } " tuples which form the instructions of the basic block." } } + { { $slot "unlikely?" } { "Unused boolean slot." } } + } +} ; + +HELP: +{ $values { "bb" basic-block } } +{ $description "Creates a new empty basic block. The " { $slot "id" } " slot is initialized with the value of the basic-block " { $link counter } "." } ; + +HELP: cfg +{ $class-description + "Call flow graph. It has the following slots:" + { $table + { { $slot "entry" } { "Root " { $link basic-block } " of the graph." } } + { { $slot "word" } { "The " { $link word } " the cfg is produced from." } } + { { $slot "post-order" } { "The blocks of the cfg in a post order traversal " { $link sequence } "." } } + { { $slot "stack-frame" } { { $link stack-frame } " of the cfg." } } + { { $slot "frame-pointer?" } { "Whether the cfg needs a frame pointer. Only cfgs generated for " { $link #alien-callback } " nodes does need it." } } + } +} +{ $see-also post-order } ; + +HELP: cfg-changed +{ $values { "cfg" cfg } } +{ $description "Resets all \"calculated\" slots in the cfg which forces them to be recalculated." } ; diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis-docs.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis-docs.factor new file mode 100644 index 0000000000..4f7081b4da --- /dev/null +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis-docs.factor @@ -0,0 +1,52 @@ +USING: classes compiler.cfg help.markup help.syntax sequences ; +IN: compiler.cfg.dataflow-analysis + +HELP: predecessors +{ $values { "bb" basic-block } { "dfa" "a dataflow analysis symbol" } { "seq" sequence } } +{ $description "Generic word that returns the predecessors for a block. It's purpose is to facilitate backward analysis in which the blocks successors are seen as the predecessors." } ; + +HELP: successors +{ $values { "bb" basic-block } { "dfa" "a dataflow analysis symbol" } { "seq" sequence } } +{ $description "Generic word that returns the successors for a block. It's purpose is to facilitate backward analysis in which the blocks predecessors are seen as the successors." } ; + +HELP: transfer-set +{ $values + { "in-set" "input state" } + { "bb" basic-block } + { "dfa" class } + { "out-set" "output state" } +} +{ $description "Generic word which is called during the dataflow analysis to process each basic block in the cfg. It is supposed to be implemented by all forward and backward dataflow analysis subclasses to perform analysis." } ; + +HELP: join-sets +{ $values + { "sets" "input states" } + { "bb" basic-block } + { "dfa" class } + { "set" "merged state" } +} +{ $description "Generic word which merges multiple states into one. A block in the cfg might have multiple predecessors and then this word is used to compute the merged input state to use to analyze the block." } ; + + + + +HELP: FORWARD-ANALYSIS: +{ $syntax "FORWARD-ANALYSIS: word" } +{ $values { "word" "name of the compiler pass" } } +{ $description "Syntax word for defining a forward analysis compiler pass." } ; + +HELP: BACKWARD-ANALYSIS: +{ $syntax "BACKWARD-ANALYSIS: word" } +{ $values { "word" "name of the compiler pass" } } +{ $description "Syntax word for defining a backward analysis compiler pass." } ; diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index b5e9535d97..30017f87ec 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -10,6 +10,7 @@ GENERIC: transfer-set ( in-set bb dfa -- out-set ) GENERIC: block-order ( cfg dfa -- bbs ) GENERIC: successors ( bb dfa -- seq ) GENERIC: predecessors ( bb dfa -- seq ) +GENERIC: ignore-block? ( bb dfa -- ? ) > [ f ] [ + bb dfa ignore-block? [ f ] [ bb dfa predecessors [ out-sets key? ] filter [ out-sets at ] map @@ -32,7 +33,7 @@ MIXIN: dataflow-analysis bb in-sets maybe-set-at ; inline :: compute-out-set ( bb in-sets dfa -- set ) - bb kill-block?>> [ f ] [ bb in-sets at bb dfa transfer-set ] if ; + bb dfa ignore-block? [ f ] [ bb in-sets at bb dfa transfer-set ] if ; :: update-out-set ( bb in-sets out-sets dfa -- ? ) bb in-sets dfa compute-out-set @@ -55,6 +56,7 @@ MIXIN: dataflow-analysis out-sets ; inline M: dataflow-analysis join-sets 2drop assoc-refine ; +M: dataflow-analysis ignore-block? drop kill-block?>> ; FUNCTOR: define-analysis ( name -- ) diff --git a/basis/compiler/cfg/def-use/def-use-docs.factor b/basis/compiler/cfg/def-use/def-use-docs.factor new file mode 100644 index 0000000000..cfcfe601b7 --- /dev/null +++ b/basis/compiler/cfg/def-use/def-use-docs.factor @@ -0,0 +1,24 @@ +USING: compiler.cfg.instructions help.markup help.syntax sequences ; +IN: compiler.cfg.def-use + +HELP: defs-vregs +{ $values { "insn" insn } { "seq" sequence } } +{ $description "Returns the sequence of vregs defined, or introduced, by this instruction." } +{ $examples + { $example + "USING: compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers prettyprint ;" + "T{ ##peek f 37 D 0 0 } defs-vregs ." + "{ 37 }" + } +} ; + +HELP: uses-vregs +{ $values { "insn" insn } { "seq" sequence } } +{ $description "Returns the sequence of vregs used by this instruction." } +{ $examples + { $example + "USING: compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers prettyprint ;" + "T{ ##replace f 37 D 1 6 } uses-vregs ." + "{ 37 }" + } +} ; diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 36e6bdd46e..9f750f16dc 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -109,7 +109,7 @@ SYMBOLS: defs insns ; : insn-of ( vreg -- insn ) insns get at ; : set-def-of ( obj insn assoc -- ) - swap defs-vregs [ swap set-at ] with with each ; + swap defs-vregs [ swap set-at ] 2with each ; : compute-defs ( cfg -- ) H{ } clone [ diff --git a/basis/compiler/cfg/dependence/dependence-docs.factor b/basis/compiler/cfg/dependence/dependence-docs.factor new file mode 100644 index 0000000000..cc9cdbd47c --- /dev/null +++ b/basis/compiler/cfg/dependence/dependence-docs.factor @@ -0,0 +1,6 @@ +USING: compiler.cfg.instructions help.markup help.syntax sequences ; +IN: compiler.cfg.dependence + +HELP: +{ $values { "insn" insn } { "node" node } } +{ $description "Creates a new dependency graph node from an CFG instruction." } ; diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor index a0bb29cdf0..2e904464c6 100644 --- a/basis/compiler/cfg/finalization/finalization.factor +++ b/basis/compiler/cfg/finalization/finalization.factor @@ -4,7 +4,7 @@ USING: kernel compiler.cfg.representations compiler.cfg.scheduling compiler.cfg.gc-checks compiler.cfg.write-barrier compiler.cfg.save-contexts compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame -compiler.cfg.linear-scan compiler.cfg.stacks.uninitialized ; +compiler.cfg.linear-scan compiler.cfg.stacks.vacant ; IN: compiler.cfg.finalization : finalize-cfg ( cfg -- cfg' ) @@ -12,7 +12,7 @@ IN: compiler.cfg.finalization schedule-instructions insert-gc-checks eliminate-write-barriers - dup compute-uninitialized-sets + dup compute-vacant-sets insert-save-contexts destruct-ssa linear-scan diff --git a/basis/compiler/cfg/gc-checks/gc-checks-docs.factor b/basis/compiler/cfg/gc-checks/gc-checks-docs.factor new file mode 100644 index 0000000000..eaf21a39b8 --- /dev/null +++ b/basis/compiler/cfg/gc-checks/gc-checks-docs.factor @@ -0,0 +1,41 @@ +USING: compiler.cfg compiler.cfg.instructions help.markup help.syntax kernel +layouts math sequences slots.private ; +IN: compiler.cfg.gc-checks + +> successors>> first instructions>> allocation-size ." + "32 ! 16 on 32-bit" + } +} ; + +PRIVATE> + +ARTICLE: "compiler.cfg.gc-checks" "Garbage collection check insertion" +"This pass runs after representation selection, since it needs to know which vregs can contain tagged pointers." ; + +HELP: process-block +{ $values { "bb" basic-block } } +{ $description "Process a block that needs a gc check. New blocks are allocated and connected for the gc branches." } ; diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index c7f79b5ef5..42b32dbb28 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -12,10 +12,6 @@ compiler.cfg.instructions compiler.cfg.predecessors ; IN: compiler.cfg.gc-checks -! Garbage collection check insertion. This pass runs after -! representation selection, since it needs to know which vregs -! can contain tagged pointers. - ( -- gc-map ) gc-map new ; diff --git a/basis/compiler/cfg/instructions/syntax/syntax-docs.factor b/basis/compiler/cfg/instructions/syntax/syntax-docs.factor new file mode 100644 index 0000000000..856b927bb0 --- /dev/null +++ b/basis/compiler/cfg/instructions/syntax/syntax-docs.factor @@ -0,0 +1,34 @@ +USING: help.markup help.syntax literals multiline sequences splitting ; +IN: compiler.cfg.instructions.syntax + +<< +STRING: parse-insn-slot-specs-code +USING: compiler.cfg.instructions.syntax prettyprint splitting ; +"use: src/int-rep temp: temp/int-rep" " " split parse-insn-slot-specs . +; + +STRING: parse-insn-slot-specs-result +{ + T{ insn-slot-spec + { type use } + { name "src" } + { rep int-rep } + } + T{ insn-slot-spec + { type temp } + { name "temp" } + { rep int-rep } + } +} +; +>> + +HELP: parse-insn-slot-specs +{ $values + { "seq" "a " { $link sequence } " of tokens" } + { "specs" "a " { $link sequence } " of " { $link insn-slot-spec } " items." } +} +{ $description "Parses a sequence of tokens into a sequence of instruction slot specifiers." } +{ $examples + { $example $[ parse-insn-slot-specs-code parse-insn-slot-specs-result ] } +} ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics-docs.factor b/basis/compiler/cfg/intrinsics/intrinsics-docs.factor new file mode 100644 index 0000000000..53d268d216 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/intrinsics-docs.factor @@ -0,0 +1,5 @@ +USING: compiler.tree help.markup help.syntax words ; +IN: compiler.cfg.intrinsics +HELP: emit-intrinsic +{ $values { "node" node } { "word" word } } +{ $description "Emit optimized intrinsic code for a word instead of merely calling it. The \"intrinsic\" property of the word (which is expected to be a quotation) is called with the node as input." } ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index b35efc0d97..06b8dfbfb9 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -164,7 +164,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep : ^(sum-vector-2) ( src rep -- dst ) { [ dupd ^^horizontal-add-vector ] - [| src rep | + [| src rep | src src rep ^^merge-vector-head :> head src src rep ^^merge-vector-tail :> tail head tail rep ^^add-vector @@ -177,7 +177,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep [ dupd ^^horizontal-add-vector ] [ dupd ^^horizontal-add-vector ] bi ] - [| src rep | + [| src rep | src src rep ^^merge-vector-head :> head src src rep ^^merge-vector-tail :> tail head tail rep ^^add-vector :> src' @@ -196,7 +196,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep [ dupd ^^horizontal-add-vector ] [ dupd ^^horizontal-add-vector ] tri ] - [| src rep | + [| src rep | src src rep ^^merge-vector-head :> head src src rep ^^merge-vector-tail :> tail head tail rep ^^add-vector :> src' @@ -223,7 +223,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep [ dupd ^^horizontal-add-vector ] } cleave ] - [| src rep | + [| src rep | src src rep ^^merge-vector-head :> head src src rep ^^merge-vector-tail :> tail head tail rep ^^add-vector :> src' diff --git a/basis/compiler/cfg/intrinsics/slots/slots-docs.factor b/basis/compiler/cfg/intrinsics/slots/slots-docs.factor new file mode 100644 index 0000000000..95b1cd4cc4 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/slots/slots-docs.factor @@ -0,0 +1,41 @@ +USING: classes classes.builtin compiler.cfg.instructions compiler.tree +compiler.tree.propagation.info help.markup help.syntax math layouts sequences +slots.private words ; +IN: compiler.cfg.intrinsics.slots + +HELP: class-tag +{ $values { "class" class } { "tag/f" "a number or f" } } +{ $description "Finds the class number for this class if it is a subclass of a builtin class, or " { $link f } " if it isn't." } +{ $examples + { $example + "USING: compiler.cfg.intrinsics.slots math prettyprint ;" + "complex class-tag ." + "7" + } +} ; + +HELP: immediate-slot-offset? +{ $values { "value-info" value-info-state } { "?" "true or false" } } +{ $description + { $link t } " if the value info is a literal " { $link fixnum } " that is small enough to fit into a machine register." } +{ $examples + { $example + "USING: compiler.cfg.intrinsics.slots compiler.tree.propagation.info prettyprint ;" + "33 immediate-slot-offset? ." + "t" + } +} ; + +HELP: value-tag +{ $values { "info" value-info-state } { "n" number } } +{ $description "Finds the class number for this value-info-states class (an index in the " { $link builtins } " list), or " { $link f } " if it hasn't one." } ; + +HELP: emit-write-barrier? +{ $values { "infos" "a " { $link sequence } " of " { $link value-info-state } " tuples." } { "?" "true or false" } } +{ $description + "Whether a given call to " { $link set-slot } " requires a write barrier to be emitted or not. Write barriers are always needed except when the element to set in the slot is known by the compiler to be " { $link immediate } "." } +{ $see-also ##write-barrier } ; + +HELP: emit-set-slot +{ $values { "node" node } } +{ $description "Emits intrinsic code for a " { $link set-slot } " call." } ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-docs.factor b/basis/compiler/cfg/linear-scan/linear-scan-docs.factor new file mode 100644 index 0000000000..5cb837a72a --- /dev/null +++ b/basis/compiler/cfg/linear-scan/linear-scan-docs.factor @@ -0,0 +1,6 @@ +USING: assocs compiler.cfg help.markup help.syntax ; +IN: compiler.cfg.linear-scan + +HELP: admissible-registers +{ $values { "cfg" cfg } { "regs" assoc } } +{ $description "Lists all registers usable by the cfg by register class. In general, that's all registers except the frame pointer register that might be used by the cfg for other purposes." } ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index c24b52b310..ad97fd48c2 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -779,3 +779,12 @@ H{ } register-status ] unit-test + +{ t } [ + T{ cfg { frame-pointer? f } } admissible-registers machine-registers = +] unit-test + +{ f } [ + T{ cfg { frame-pointer? t } } admissible-registers + int-regs of frame-reg swap member? +] unit-test diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index d3ee2f6fbb..684c232564 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -39,10 +39,8 @@ IN: compiler.cfg.linear-scan cfg check-numbering ; : admissible-registers ( cfg -- regs ) - [ machine-registers ] dip - frame-pointer?>> [ - [ int-regs ] dip [ clone ] map - [ [ [ frame-reg ] dip remove ] change-at ] keep + machine-registers swap frame-pointer?>> [ + [ [ frame-reg = not ] filter ] assoc-map ] when ; : linear-scan ( cfg -- cfg' ) diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals-docs.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals-docs.factor new file mode 100644 index 0000000000..3b0f0fc5d8 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals-docs.factor @@ -0,0 +1,10 @@ +USING: help.markup help.syntax ; +IN: compiler.cfg.linear-scan.live-intervals + +HELP: +{ $values + { "vreg" "virtual register" } + { "reg-class" "register class" } + { "live-interval" live-interval-state } +} +{ $description "Creates a new live interval for a virtual register. Initially the range is empty." } ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 5a9da37d03..ad4ab4fe16 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -162,7 +162,7 @@ M: hairy-clobber-insn compute-live-intervals* ( insn -- ) : handle-live-out ( bb -- ) live-out dup assoc-empty? [ drop ] [ [ from get to get ] dip keys - [ live-interval add-range ] with with each + [ live-interval add-range ] 2with each ] if ; ! A location where all registers have to be spilled diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-docs.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-docs.factor new file mode 100644 index 0000000000..624c13b039 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-docs.factor @@ -0,0 +1,5 @@ +USING: help.markup help.syntax ; +IN: compiler.cfg.linear-scan.resolve + +HELP: location +{ $class-description "Represents an abstract location such as a cpu register or a spill slot." } ; diff --git a/basis/compiler/cfg/linearization/linearization-docs.factor b/basis/compiler/cfg/linearization/linearization-docs.factor new file mode 100644 index 0000000000..934a574978 --- /dev/null +++ b/basis/compiler/cfg/linearization/linearization-docs.factor @@ -0,0 +1,19 @@ +USING: compiler.cfg compiler.cfg.linearization compiler.codegen help.markup +help.syntax kernel macros math sequences ; +IN: compiler.cfg.linearization + +HELP: linearization-order +{ $values + { "cfg" cfg } + { "bbs" sequence } +} +{ $description "Lists the basic blocks in linearization order. That is, the order in which they will be written in the generated assembly code." } +{ $see-also generate } ; + +HELP: block-number +{ $values { "bb" basic-block } { "n" integer } } +{ $description "Retrieves this blocks block number. Must not be called before " { $link number-blocks } "." } ; + +HELP: number-blocks +{ $values { "bbs" sequence } } +{ $description "Associate each block with a block number and save the result in the " { $link numbers } " map." } ; diff --git a/basis/compiler/cfg/predecessors/predecessors-docs.factor b/basis/compiler/cfg/predecessors/predecessors-docs.factor new file mode 100644 index 0000000000..1977d727fb --- /dev/null +++ b/basis/compiler/cfg/predecessors/predecessors-docs.factor @@ -0,0 +1,6 @@ +USING: compiler.cfg help.markup help.syntax kernel ; +IN: compiler.cfg.predecessors + +HELP: needs-predecessors +{ $values { "cfg" cfg } { "cfg'" cfg } } +{ $description "Computes predecessor info for the cfg unless it already is up-to-date." } ; diff --git a/basis/compiler/cfg/registers/registers-docs.factor b/basis/compiler/cfg/registers/registers-docs.factor new file mode 100644 index 0000000000..dddba48334 --- /dev/null +++ b/basis/compiler/cfg/registers/registers-docs.factor @@ -0,0 +1,25 @@ +USING: compiler.cfg.instructions cpu.architecture help.markup help.syntax +math ; +IN: compiler.cfg.registers + +HELP: next-vreg +{ $values { "vreg" number } } +{ $description "Creates a new virtual register identifier." } +{ $notes "This word cannot be called after representation selection has run; use " { $link next-vreg-rep } " in that case." } ; + +HELP: rep-of +{ $values { "vreg" number } { "rep" representation } } +{ $description "Gets the representation for a virtual register. This word cannot be called before representation selection has run; use any-rep for " { $link ##copy } " instructions and so on." } +{ $notes "Throws " { $link bad-vreg } " if the representation for the vreg isn't known." } ; + +HELP: set-rep-of +{ $values { "rep" representation } { "vreg" number } } +{ $description "Sets the representation for a virtual register." } ; + +HELP: next-vreg-rep +{ $values { "rep" representation } { "vreg" number } } +{ $description "Creates a new virtual register identifier and sets its representation." } +{ $notes "This word cannot be called before representation selection has run; use " { $link next-vreg } " in that case." } ; + +HELP: loc +{ $class-description "Represents a location on the stack. 'n' is an index starting from the top of the stack going down. So 0 is the top of the stack, 1 is what would be the top of the stack after a 'drop', and so on. It has two subclasses, " { $link ds-loc } " for data stack location and " { $link rs-loc } " for locations on the retain stack." } ; diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index d70d9316a2..6b93b46be6 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -7,8 +7,6 @@ IN: compiler.cfg.registers SYMBOL: vreg-counter : next-vreg ( -- vreg ) - ! This word cannot be called AFTER representation selection has run; - ! use next-vreg-rep in that case vreg-counter counter ; SYMBOL: representations @@ -16,22 +14,14 @@ SYMBOL: representations ERROR: bad-vreg vreg ; : rep-of ( vreg -- rep ) - ! This word cannot be called BEFORE representation selection has run; - ! use any-rep for ##copy instructions and so on representations get ?at [ bad-vreg ] unless ; : set-rep-of ( rep vreg -- ) representations get set-at ; : next-vreg-rep ( rep -- vreg ) - ! This word cannot be called BEFORE representation selection has run; - ! use next-vreg in that case next-vreg [ set-rep-of ] keep ; -! Stack locations -- 'n' is an index starting from the top of the stack -! going down. So 0 is the top of the stack, 1 is what would be the top -! of the stack after a 'drop', and so on. - ! ##inc-d and ##inc-r affect locations as follows. Location D 0 before ! an ##inc-d 1 becomes D 1 after ##inc-d 1. TUPLE: loc { n integer read-only } ; diff --git a/basis/compiler/cfg/rpo/rpo-docs.factor b/basis/compiler/cfg/rpo/rpo-docs.factor new file mode 100644 index 0000000000..22f91bdc50 --- /dev/null +++ b/basis/compiler/cfg/rpo/rpo-docs.factor @@ -0,0 +1,25 @@ +USING: compiler.cfg help.markup help.syntax quotations sequences ; +IN: compiler.cfg.rpo + +HELP: number-blocks +{ $values { "blocks" sequence } } +{ $description "Initializes the " { $slot "number" } " slot of each " { $link basic-block } "." } +{ $examples + { $example + "USING: accessors compiler.cfg compiler.cfg.rpo kernel prettyprint sequences ;" + "10 [ ] replicate dup number-blocks [ number>> ] map ." + "{ 9 8 7 6 5 4 3 2 1 0 }" + } +} ; + +HELP: post-order +{ $values { "cfg" cfg } { "blocks" sequence } } +{ $description "Lists the blocks in the cfg sorted in descending order on the " { $slot "number" } " slot. The blocks are first numbered if they haven't already been." } ; + +HELP: each-basic-block +{ $values { "cfg" cfg } { "quot" quotation } } +{ $description "Applies a quotation to each basic block in the cfg." } ; + +HELP: optimize-basic-block +{ $values { "bb" basic-block } { "quot" quotation } } +{ $description "Performs one " { $link simple-optimization } " step. The quotation takes the instructions of the basic block and returns them back in an optimized form." } ; diff --git a/basis/compiler/cfg/save-contexts/save-contexts-docs.factor b/basis/compiler/cfg/save-contexts/save-contexts-docs.factor new file mode 100644 index 0000000000..e66bf53554 --- /dev/null +++ b/basis/compiler/cfg/save-contexts/save-contexts-docs.factor @@ -0,0 +1,17 @@ +USING: compiler.cfg compiler.cfg.instructions help.markup help.syntax ; +IN: compiler.cfg.save-contexts + +HELP: insert-save-contexts +{ $values { "cfg" cfg } { "cfg'" cfg } } +{ $description "Inserts " { $link ##save-context } " instructions in each " { $link basic-block } " in the cfg that needs them. Save contexts are needed after instructions that modify the context, or instructions that read parameter registers." } +{ $see-also needs-save-context? } ; + +HELP: bb-needs-save-context? +{ $values { "bb" basic-block } { "?" "a boolean" } } +{ $description "Whether to insert a " { $link ##save-context } " instruction in the block or not." } +{ $see-also needs-save-context? } ; + +HELP: needs-save-context? +{ $values { "insn" "an instruction" } { "?" "a boolean" } } +{ $description "Whether the given instruction needs to be preceeded by a " { $link ##save-context } " instruction or not. Only instructions that can allocate memory mandates save contexts." } +{ $see-also gc-map-insn } ; diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor index f51499d791..0622ca7201 100644 --- a/basis/compiler/cfg/save-contexts/save-contexts.factor +++ b/basis/compiler/cfg/save-contexts/save-contexts.factor @@ -12,7 +12,7 @@ GENERIC: needs-save-context? ( insn -- ? ) M: gc-map-insn needs-save-context? drop t ; M: insn needs-save-context? drop f ; -: bb-needs-save-context? ( insn -- ? ) +: bb-needs-save-context? ( bb -- ? ) { [ kill-block?>> not ] [ instructions>> [ needs-save-context? ] any? ] diff --git a/basis/compiler/cfg/scheduling/scheduling-docs.factor b/basis/compiler/cfg/scheduling/scheduling-docs.factor new file mode 100644 index 0000000000..5a61168c86 --- /dev/null +++ b/basis/compiler/cfg/scheduling/scheduling-docs.factor @@ -0,0 +1,10 @@ +USING: compiler.cfg compiler.cfg.height help.markup help.syntax sequences ; +IN: compiler.cfg.scheduling + +HELP: number-insns +{ $values { "insns" sequence } } +{ $description "Assigns a sequence number to the " { $slot "insn#" } " slot of each instruction in the sequence." } ; + +HELP: schedule-instructions +{ $values { "cfg" cfg } { "cfg'" cfg } } +{ $description "Performs a instruction scheduling optimization pass over the CFG to attempt to reduce the number of spills. The step must be performed after " { $link normalize-height } " or else invalid peeks might be inserted into the CFG." } ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame-docs.factor b/basis/compiler/cfg/stack-frame/stack-frame-docs.factor new file mode 100644 index 0000000000..f284ce2b7c --- /dev/null +++ b/basis/compiler/cfg/stack-frame/stack-frame-docs.factor @@ -0,0 +1,10 @@ +USING: help.markup help.syntax ; +IN: compiler.cfg.stack-frame + +HELP: stack-frame +{ $class-description "Counts of, among other things, how much stack a compiled word needs. It has the following slots:" + { $table + { { $slot "total-size" } { "Total size of the stack frame." } } + { { $slot "spill-area-size" } { "Number of bytes requires for all spill slots." } } + } +} ; diff --git a/basis/compiler/cfg/stacks/height/height-docs.factor b/basis/compiler/cfg/stacks/height/height-docs.factor new file mode 100644 index 0000000000..59f53706b6 --- /dev/null +++ b/basis/compiler/cfg/stacks/height/height-docs.factor @@ -0,0 +1,12 @@ +USING: compiler.cfg compiler.cfg.registers help.markup help.syntax math ; +IN: compiler.cfg.stacks.height + +HELP: record-stack-heights +{ $values { "ds-height" number } { "rs-height" number } { "bb" basic-block } } +{ $description "Does something." } ; + +HELP: ds-heights +{ $var-description "Assoc that records the data stacks height at the entry of each " { $link basic-block } "." } ; + +HELP: rs-heights +{ $var-description "Assoc that records the retain stacks height at the entry of each " { $link basic-block } "." } ; diff --git a/basis/compiler/cfg/stacks/local/local-docs.factor b/basis/compiler/cfg/stacks/local/local-docs.factor new file mode 100644 index 0000000000..c24da16e78 --- /dev/null +++ b/basis/compiler/cfg/stacks/local/local-docs.factor @@ -0,0 +1,33 @@ +USING: compiler.cfg compiler.cfg.registers help.markup help.syntax ; +IN: compiler.cfg.stacks.local + +HELP: current-height +{ $class-description "A tuple used to keep track of the heights of the data and retain stacks in a " { $link basic-block } " The idea is that if the stack change instructions are tracked, then multiple changes can be folded into one. It has the following slots:" + { $table + { { $slot "d" } { "Current datastack height." } } + { { $slot "r" } { "Current retainstack height." } } + { { $slot "emit-d" } { "Queued up datastack height change." } } + { { $slot "emit-r" } { "Queued up retainstack height change." } } + } +} ; + +HELP: translate-local-loc +{ $values { "loc" loc } { "loc'" loc } } +{ $description "Translates an absolute stack location to one that is relative to the current stacks height as given in " { $link current-height } "." } +{ $examples + { $example + "USING: compiler.cfg.stacks.local compiler.cfg.registers compiler.cfg.debugger namespaces prettyprint ;" + "T{ current-height { d 3 } } current-height set D 7 translate-local-loc ." + "D 4" + } +} ; + +HELP: emit-height-changes +{ $description "Emits stack height change instructions to the CFG being built. This is done when a " { $link basic-block } " is begun or ended." } +{ $examples + { $example + "USING: compiler.cfg.stacks.local make namespaces prettyprint ;" + "T{ current-height { emit-d 4 } { emit-r -2 } } current-height set [ emit-height-changes ] { } make ." + "{ T{ ##inc-d { n 4 } } T{ ##inc-r { n -2 } } }" + } +} ; diff --git a/basis/compiler/cfg/stacks/stacks-docs.factor b/basis/compiler/cfg/stacks/stacks-docs.factor new file mode 100644 index 0000000000..9baf0de036 --- /dev/null +++ b/basis/compiler/cfg/stacks/stacks-docs.factor @@ -0,0 +1,22 @@ +USING: compiler.cfg.stacks.local help.markup help.syntax math sequences ; +IN: compiler.cfg.stacks + +HELP: begin-stack-analysis +{ $description "Initializes a set of variables related to stack analysis of Factor words." } +{ $see-also current-height } ; + +HELP: adjust-d +{ $values { "n" number } } +{ $description "Changes the height of the current data stack." } ; + +HELP: rs-store +{ $values { "vregs" "a " { $link sequence } " of vregs." } } +{ $description "Stores one or more virtual register values on the retain stack. This modifies the " { $link current-height } " dynamic variable." } ; + +HELP: 2inputs +{ $values { "vreg1" "a vreg" } { "vreg2" "a vreg" } } +{ $description "Lifts the two topmost values from the datastack and stores them in virtual registers. The datastacks height is adjusted afterwards." } ; + +HELP: 3inputs +{ $values { "vreg1" "a vreg" } { "vreg2" "a vreg" } { "vreg3" "a vreg" } } +{ $description "Lifts the three topmost values from the datastack and stores them in virtual registers. The datastacks height is adjusted afterwards." } ; diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized-docs.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized-docs.factor new file mode 100644 index 0000000000..a39d4cfdc9 --- /dev/null +++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized-docs.factor @@ -0,0 +1,6 @@ +USING: compiler.cfg compiler.cfg.instructions help.markup help.syntax ; +IN: compiler.cfg.stacks.uninitialized + +HELP: compute-uninitialized-sets +{ $values { "cfg" cfg } } +{ $description "Runs the uninitialized compiler pass. The pass serves two purposes; if a " { $link ##peek } " reads an uninitialized stack location, then an error is thrown. Second, it assigns the " { $slot "scrub-d" } " and " { $slot "scrub-r" } " slots of all " { $link gc-map } " instances in the cfg." } ; diff --git a/basis/compiler/cfg/stacks/vacant/vacant-docs.factor b/basis/compiler/cfg/stacks/vacant/vacant-docs.factor new file mode 100644 index 0000000000..1bab1d594a --- /dev/null +++ b/basis/compiler/cfg/stacks/vacant/vacant-docs.factor @@ -0,0 +1,39 @@ +USING: compiler.cfg.instructions help.markup help.syntax sequences strings ; +IN: compiler.cfg.stacks.vacant + +ARTICLE: "compiler.cfg.stacks.vacant" "Uninitialized/overinitialized stack location analysis" +"Consider the following sequence of instructions:" +{ $code + "##inc-d 2" + "..." + "##allot" + "##replace ... D 0" + "##replace ... D 1" +} +"The GC check runs before stack locations 0 and 1 have been initialized, and so the GC needs to scrub them so that they don't get traced. This is achieved by computing uninitialized locations with a dataflow analysis, and recording the information in GC maps. The call_frame_slot_visitor object in vm/slot_visitor.hpp reads this information from GC maps and performs the scrubbing." ; + +HELP: initial-state +{ $description "Initially the stack bottom is at 0 for both the data and retain stacks and no replaces have been registered." } ; + +HELP: vacant>bits +{ $values + { "vacant" "sequence of uninitialized stack locations" } + { "bits" "sequence of 1:s and 0:s" } +} +{ $description "Converts a sequence of uninitialized stack locations to the pattern of 1:s and 0:s that can be put in the " { $slot "scrub-d" } " and " { $slot "scrub-r" } " slots of a " { $link gc-map } ". 0:s are uninitialized locations and 1:s are initialized." } +{ $examples + { $example + "USING: compiler.cfg.stacks.vacant prettyprint ;" + "{ 0 1 3 } vacant>bits ." + "{ 0 0 1 0 }" + } +} ; + +HELP: overinitialized>bits +{ $values + { "overinitialized" "sequence of overinitialized stack locations" } + { "bits" "sequence of 1:s and 0:s" } +} +{ $description "Converts a sequence of overinitialized stack locations to the pattern of 1:s and 0:s that can be put in the " { $slot "check-d" } " and " { $slot "check-r" } " slots of a " { $link gc-map } ". 0:s are initialized locations and 0:s are empty ones. First element is stack location -1,second -2 and so on." } ; + +ABOUT: "compiler.cfg.stacks.vacant" diff --git a/basis/compiler/cfg/stacks/vacant/vacant-tests.factor b/basis/compiler/cfg/stacks/vacant/vacant-tests.factor new file mode 100644 index 0000000000..b15ebedda3 --- /dev/null +++ b/basis/compiler/cfg/stacks/vacant/vacant-tests.factor @@ -0,0 +1,246 @@ +USING: accessors arrays assocs compiler.cfg +compiler.cfg.dataflow-analysis.private compiler.cfg.instructions +compiler.cfg.linearization compiler.cfg.registers compiler.cfg.stacks.vacant +kernel math sequences sorting tools.test vectors ; +IN: compiler.cfg.stacks.vacant.tests + +! Utils +: create-block ( insns n -- bb ) + swap >>number swap >>instructions ; + +: block>cfg ( bb -- cfg ) + cfg new swap >>entry ; + +: create-cfg ( insns -- cfg ) + 0 create-block block>cfg ; + +: output-stack-map ( cfg -- map ) + vacant-analysis run-dataflow-analysis + nip [ [ number>> ] dip ] assoc-map >alist natural-sort last second ; + +! Initially both the d and r stacks are empty. +{ + { { 0 { } } { 0 { } } } +} [ V{ } create-cfg output-stack-map ] unit-test + +! Raise d stack. +{ + { { 1 { } } { 0 { } } } +} [ V{ T{ ##inc-d f 1 } } create-cfg output-stack-map ] unit-test + +! Raise r stack. +{ + { { 0 { } } { 1 { } } } +} [ V{ T{ ##inc-r f 1 } } create-cfg output-stack-map ] unit-test + +! Uninitialized peeks +[ + V{ + T{ ##inc-d f 1 } + T{ ##peek { dst 0 } { loc D 0 } } + } create-cfg + compute-vacant-sets +] [ vacant-peek? ] must-fail-with + +[ + V{ + T{ ##inc-r f 1 } + T{ ##peek { dst 0 } { loc R 0 } } + } create-cfg + compute-vacant-sets +] [ vacant-peek? ] must-fail-with + + +! Here the peek refers to a parameter of the word. +[ ] [ + V{ + T{ ##peek { dst 0 } { loc D 0 } } + } create-cfg + compute-vacant-sets +] unit-test + +! Replace -1 then peek is ok. +[ ] [ + V{ + T{ ##replace { src 10 } { loc D -1 } } + T{ ##peek { dst 0 } { loc D -1 } } + } create-cfg + compute-vacant-sets +] unit-test + +! Replace -1, then gc. Peek is ok here because the -1 should be +! checked. +{ { 0 } } [ + V{ + T{ ##replace { src 10 } { loc D -1 } } + T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } } + T{ ##peek { dst 0 } { loc D -1 } } + } + [ create-cfg compute-vacant-sets ] + [ second gc-map>> check-d>> ] bi +] unit-test + +! Should be ok because the value was at 0 when the gc ran. +{ { -1 { -1 } } } [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } } + T{ ##inc-d f -1 } + T{ ##peek { dst 0 } { loc D -1 } } + } create-cfg output-stack-map first +] unit-test + +! Should not be ok because the value wasn't initialized when gc ran. +[ + V{ + T{ ##inc-d f 1 } + T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } } + T{ ##peek { dst 0 } { loc D 0 } } + } create-cfg + compute-vacant-sets +] [ vacant-peek? ] must-fail-with + +! visit-insn should set the gc info. +{ { 0 0 } { } } [ + { { 2 { } } { 0 { } } } + T{ ##alien-invoke { gc-map T{ gc-map } } } + [ visit-insn drop ] keep gc-map>> [ scrub-d>> ] [ scrub-r>> ] bi +] unit-test + +{ + { { 0 { } } { 0 { } } } +} [ + V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } } + create-cfg output-stack-map +] unit-test + +{ + { { 0 { 0 1 2 } } { 0 { } } } +} [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##replace { src 10 } { loc D 1 } } + T{ ##replace { src 10 } { loc D 2 } } + } create-cfg output-stack-map +] unit-test + +{ + { { 1 { 1 0 } } { 0 { } } } +} [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc-d f 1 } + T{ ##replace { src 10 } { loc D 0 } } + } create-cfg output-stack-map +] unit-test + +{ + { 0 { 0 -1 } } +} [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc-d f 1 } + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc-d f -1 } + } create-cfg output-stack-map first +] unit-test + +{ + { 0 { -1 } } +} [ + V{ + T{ ##inc-d f 1 } + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc-d f -1 } + } create-cfg output-stack-map first +] unit-test + +{ + { { { } { 0 0 0 } } { { } { 0 } } } +} [ + { { 4 { 3 2 1 -3 0 -2 -1 } } { 0 { -1 } } } state>gc-data +] unit-test + +! ##call clears the overinitialized slots. +{ + { -1 { } } +} [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc-d f -1 } + T{ ##call } + } create-cfg output-stack-map first +] unit-test + +: cfg1 ( -- cfg ) + V{ + T{ ##inc-d f 1 } + T{ ##replace { src 10 } { loc D 0 } } + } 0 create-block + V{ + T{ ##peek { dst 37 } { loc D 0 } } + T{ ##inc-d f -1 } + } 1 create-block + 1vector >>successors block>cfg ; + +{ { 0 { -1 } } } [ cfg1 output-stack-map first ] unit-test + +: connect-bbs ( from to -- ) + [ [ successors>> ] dip suffix! drop ] + [ predecessors>> swap suffix! drop ] 2bi ; + +: make-edges ( block-map edgelist -- ) + [ [ of ] with map first2 connect-bbs ] with each ; + +! Same cfg structure as the bug1021:run-test word but with +! non-datastack instructions mostly omitted. +: bug1021-cfg ( -- cfg ) + { + { 0 V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } } } + { + 1 V{ + T{ ##inc-d f 2 } + T{ ##replace { src 0 } { loc D 1 } } + T{ ##replace { src 0 } { loc D 0 } } + } + } + { + 2 V{ + T{ ##call { word } } + } + } + { + 3 V{ + T{ ##inc-d f 2 } + T{ ##peek { dst 0 } { loc D 2 } } + T{ ##peek { dst 0 } { loc D 3 } } + T{ ##replace { src 0 } { loc D 2 } } + T{ ##replace { src 0 } { loc D 3 } } + T{ ##replace { src 0 } { loc D 1 } } + } + } + { + 8 V{ + T{ ##inc-d f 3 } + T{ ##peek { dst 0 } { loc D 5 } } + T{ ##replace { src 0 } { loc D 0 } } + T{ ##replace { src 0 } { loc D 3 } } + T{ ##peek { dst 0 } { loc D 4 } } + T{ ##replace { src 0 } { loc D 1 } } + T{ ##replace { src 0 } { loc D 2 } } + } + } + { + 10 V{ + + T{ ##inc-d f -3 } + T{ ##peek { dst 0 } { loc D -3 } } + T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } } + } + } + } [ over create-block ] assoc-map dup + { { 0 1 } { 1 2 } { 2 3 } { 3 8 } { 8 10 } } make-edges 0 of block>cfg ; + +{ { 4 { 3 2 1 -3 0 -2 -1 } } } [ + bug1021-cfg output-stack-map first +] unit-test diff --git a/basis/compiler/cfg/stacks/vacant/vacant.factor b/basis/compiler/cfg/stacks/vacant/vacant.factor new file mode 100644 index 0000000000..6a6e859acc --- /dev/null +++ b/basis/compiler/cfg/stacks/vacant/vacant.factor @@ -0,0 +1,96 @@ +USING: accessors arrays assocs classes.tuple compiler.cfg.dataflow-analysis +compiler.cfg.instructions compiler.cfg.registers fry kernel math math.order +sequences sets ; +IN: compiler.cfg.stacks.vacant + +! Utils +: write-slots ( tuple values slots -- ) + [ execute( x y -- z ) ] 2each drop ; + +! Operations on the stack info +: register-write ( n stack -- stack' ) + first2 rot suffix members 2array ; + +: adjust-stack ( n stack -- stack' ) + first2 pick '[ _ + ] map [ + ] dip 2array ; + +: read-ok? ( n stack -- ? ) + [ first >= ] [ second in? ] 2bi or ; + +: stack>vacant ( stack -- seq ) + first2 [ 0 max iota ] dip diff ; + +: vacant>bits ( vacant -- bits ) + [ { } ] [ + dup supremum 1 + 1 + [ '[ _ 0 -rot set-nth ] each ] keep + ] if-empty ; + +: stack>overinitialized ( stack -- seq ) + second [ 0 < ] filter ; + +: overinitialized>bits ( overinitialized -- bits ) + [ neg 1 - ] map vacant>bits ; + +: stack>scrub-and-check ( stack -- pair ) + [ stack>vacant vacant>bits ] + [ stack>overinitialized overinitialized>bits ] bi 2array ; + +! Operations on the analysis state +: state>gc-data ( state -- gc-data ) + [ stack>scrub-and-check ] map ; + +CONSTANT: initial-state { { 0 { } } { 0 { } } } + +: insn>location ( insn -- n ds? ) + loc>> [ n>> ] [ ds-loc? ] bi ; + +: visit-replace ( state insn -- state' ) + [ first2 ] dip insn>location + [ rot register-write swap ] [ swap register-write ] if 2array ; + +ERROR: vacant-peek insn ; + +: peek-loc-ok? ( state insn -- ? ) + insn>location 0 1 ? rot nth read-ok? ; + +GENERIC: visit-insn ( state insn -- state' ) + +M: ##inc-d visit-insn ( state insn -- state' ) + n>> swap first2 [ adjust-stack ] dip 2array ; + +M: ##inc-r visit-insn ( state insn -- state' ) + n>> swap first2 swapd adjust-stack 2array ; + +M: ##replace-imm visit-insn visit-replace ; +M: ##replace visit-insn visit-replace ; + +M: ##peek visit-insn ( state insn -- state' ) + 2dup peek-loc-ok? [ drop ] [ vacant-peek ] if ; + +M: ##call visit-insn ( state insn -- state' ) + ! After a word call, we can't trust any overinitialized locations + ! to contain valid pointers anymore. + drop [ first2 [ 0 >= ] filter 2array ] map ; + +: set-gc-map ( state gc-map -- ) + swap state>gc-data concat + { >>scrub-d >>check-d >>scrub-r >>check-r } write-slots ; + +M: gc-map-insn visit-insn ( state insn -- state' ) + dupd gc-map>> set-gc-map ; + +M: insn visit-insn ( state insn -- state' ) + drop ; + +FORWARD-ANALYSIS: vacant + +M: vacant-analysis transfer-set ( in-set bb dfa -- out-set ) + drop instructions>> swap [ visit-insn ] reduce ; + +M: vacant-analysis ignore-block? ( bb dfa -- ? ) + 2drop f ; + +! Picking the first means that a block will only be analyzed once. +M: vacant-analysis join-sets ( sets bb dfa -- set ) + 2drop [ initial-state ] [ first ] if-empty ; diff --git a/basis/compiler/codegen/codegen-docs.factor b/basis/compiler/codegen/codegen-docs.factor new file mode 100644 index 0000000000..15e47ceb22 --- /dev/null +++ b/basis/compiler/codegen/codegen-docs.factor @@ -0,0 +1,97 @@ +USING: alien byte-arrays compiler.cfg compiler.codegen.labels +compiler.codegen.relocation hashtables help.markup help.syntax literals make +multiline sequences ; +IN: compiler.codegen + +<< +STRING: generate-ex +USING: compiler.cfg.debugger io prettyprint ; +[ "hello\n" write ] test-regs first dup cfg set generate [ . ] [ 4 swap nth disassemble ] bi +; + +STRING: generate-ex-answer +{ + { } + { "hello\n" output-stream assoc-stack stream-write } + B{ + 6 0 0 242 24 0 0 96 49 0 0 96 58 0 0 34 64 0 0 242 80 0 + 0 50 + } + { } + B{ + 137 5 0 0 0 0 72 131 236 8 73 131 198 24 72 185 0 0 0 0 + 0 0 0 0 73 137 78 240 73 139 77 0 72 139 73 64 73 137 14 + 72 185 0 0 0 0 0 0 0 0 73 137 78 248 232 0 0 0 0 137 5 0 + 0 0 0 72 131 196 8 72 141 29 5 0 0 0 233 0 0 0 0 0 0 0 0 + 0 0 0 0 0 0 0 0 0 0 0 0 + } + 16 +} +0000000001cc4ca0: 890500000000 mov [rip], eax +0000000001cc4ca6: 4883ec08 sub rsp, 0x8 +0000000001cc4caa: 4983c618 add r14, 0x18 +0000000001cc4cae: 48b90000000000000000 mov rcx, 0x0 +0000000001cc4cb8: 49894ef0 mov [r14-0x10], rcx +0000000001cc4cbc: 498b4d00 mov rcx, [r13] +0000000001cc4cc0: 488b4940 mov rcx, [rcx+0x40] +0000000001cc4cc4: 49890e mov [r14], rcx +0000000001cc4cc7: 48b90000000000000000 mov rcx, 0x0 +0000000001cc4cd1: 49894ef8 mov [r14-0x8], rcx +0000000001cc4cd5: e800000000 call 0x1cc4cda +0000000001cc4cda: 890500000000 mov [rip], eax +0000000001cc4ce0: 4883c408 add rsp, 0x8 +0000000001cc4ce4: 488d1d05000000 lea rbx, [rip+0x5] +0000000001cc4ceb: e900000000 jmp 0x1cc4cf0 +0000000001cc4cf0: 0000 add [rax], al +0000000001cc4cf2: 0000 add [rax], al +0000000001cc4cf4: 0000 add [rax], al +0000000001cc4cf6: 0000 add [rax], al +0000000001cc4cf8: 0000 add [rax], al +0000000001cc4cfa: 0000 add [rax], al +0000000001cc4cfc: 0000 add [rax], al +0000000001cc4cfe: 0000 add [rax], al +; +>> + +HELP: labels +{ $description { $link hashtable } " of mappings from " { $link basic-block } " to " { $link label } "." } ; + +HELP: lookup-label +{ $values { "bb" basic-block } { "label" label } } +{ $description "Sets and gets a " { $link label } " for the " { $link basic-block } ". The labels are used to generate branch instructions from one block to another." } ; + +HELP: generate-block +{ $values { "bb" basic-block } } +{ $description "Emits machine code to the current " { $link make } " sequence for one basic block." } ; + +HELP: generate +{ $values { "cfg" cfg } { "code" sequence } } +{ $description "Generates assembly code for the given cfg. The output " { $link sequence } " has six items with the following interpretations:" + { $list + { "The first element is a sequence of alien function symbols and " { $link dll } "s used by the cfg interleaved. That is, the " { $link parameter-table } "." } + { "The second item is the " { $link literal-table } "." } + { "The third item is the relocation table as a " { $link byte-array } "." } + { "The fourth item is the " { $link label-table } "." } + { "The fifth item is the generated assembly code as a " { $link byte-array } ". It still contains unresolved crossreferences." } + "The sixth item is the size of the stack frame in bytes." + } +} +{ $examples + "A small quotation is compiled and then disassembled:" + { $unchecked-example $[ generate-ex generate-ex-answer ] } +} ; + +HELP: useless-branch? +{ $values + { "bb" basic-block } + { "successor" "The successor block of bb" } + { "?" "A boolean value" } +} +{ $description "If successor immediately follows bb in the linearization order, then a branch is is not needed." } ; + +HELP: init-fixup +{ $description "Initializes variables needed for fixup." } ; + +HELP: check-fixup +{ $values { "seq" "a " { $link sequence } " of generated machine code." } } +{ $description "Used by " { $link with-fixup } " to ensure that the generated machine code is properly aligned." } ; diff --git a/basis/compiler/codegen/gc-maps/gc-maps-docs.factor b/basis/compiler/codegen/gc-maps/gc-maps-docs.factor new file mode 100644 index 0000000000..bd1d3ec0aa --- /dev/null +++ b/basis/compiler/codegen/gc-maps/gc-maps-docs.factor @@ -0,0 +1,73 @@ +USING: bit-arrays byte-arrays compiler.cfg.instructions help.markup help.syntax +kernel math ; +IN: compiler.codegen.gc-maps + +ARTICLE: "compiler.codegen.gc-maps" "GC maps" +"The " { $vocab-link "compiler.codegen.gc-maps" } " handles generating code for keeping track of garbage collection maps. Every code block either ends with:" +{ $list "uint 0" } +"or" +{ $list + { + "bitmap, byte aligned, five subsequences:" + { $list + "scrubbed data stack locations" + "scrubbed retain stack locations" + "checked data stack locations" + "checked retain stack locations" + "GC root spill slots" + } + } + "uint[] base pointers" + "uint[] return addresses" + "uint largest scrubbed data stack location" + "uint largest scrubbed retain stack location" + "uint largest checked data stack location" + "uint largest checked retain stack location" + "uint largest GC root spill slot" + "uint largest derived root spill slot" + "int number of return addresses" +} ; + +HELP: emit-gc-info-bitmaps +{ $values { "scrub-and-check-counts" "counts of the five different types of gc checks" } } +{ $description "Emits the scrub location data in all gc-maps registered in the " { $link gc-maps } " variable to the make sequence being created. The result is a concatenation of all datastack scrub locations, retainstack scrub locations and gc root locations converted into a byte-array. Given that byte-array and knowledge of the number of scrub locations, the original gc-map can be reconstructed." } ; + +HELP: emit-scrub +{ $values + { "seqs" "a sequence of sequences of 0/1" } + { "n" "length of the longest sequence" } +} +{ $description "Emits a space-efficient " { $link bit-array } " to the make sequence being created. The outputted array will be of length n times the number of sequences given. Each group of n elements in the array contains true values if the stack location should be scrubbed, and false if it shouldn't." } +{ $examples + { $example + "USING: bit-arrays byte-arrays compiler.codegen.gc-maps make prettyprint ;" + "[ { B{ 0 } B{ 0 } B{ 1 1 1 0 } } emit-scrub ] ?{ } make . ." + "?{ t f f f t f f f f f f t }\n4" + } +} ; + +{ emit-gc-info-bitmaps emit-scrub } related-words + +HELP: emit-uint +{ $values { "n" integer } } +{ $description "Emits an unsigned 32 bit integer to the make sequence being created. The word takes care of ensuring that the byte order is correct for the current machine." } +{ $examples + { $example + "USING: compiler.codegen.gc-maps make prettyprint ;" + "[ 0xffff emit-uint ] B{ } make ." + "B{ 255 255 0 0 }" + } +} ; + +HELP: gc-maps +{ $var-description "Variable that holds a sequence of " { $link gc-map } " tuples." } ; + +HELP: gc-map-needed? +{ $values { "gc-map/f" "a " { $link gc-map } " or f" } { "?" "a boolean" } } +{ $description "If all slots in the gc-map are empty, then it doesn't need to be emitted." } ; + +HELP: serialize-gc-maps +{ $values { "byte-array" byte-array } } +{ $description "Serializes the gc-maps that have been registered in the " { $link gc-maps } " variable into a byte-array." } ; + +ABOUT: "compiler.codegen.gc-maps" diff --git a/basis/compiler/codegen/gc-maps/gc-maps-tests.factor b/basis/compiler/codegen/gc-maps/gc-maps-tests.factor index 6f9f799bf7..2dbf5ea3c9 100644 --- a/basis/compiler/codegen/gc-maps/gc-maps-tests.factor +++ b/basis/compiler/codegen/gc-maps/gc-maps-tests.factor @@ -2,78 +2,164 @@ USING: namespaces byte-arrays make compiler.codegen.gc-maps compiler.codegen.relocation bit-arrays accessors classes.struct tools.test kernel math sequences alien.c-types specialized-arrays boxes compiler.cfg.instructions system -cpu.architecture ; +cpu.architecture vm ; SPECIALIZED-ARRAY: uint IN: compiler.codegen.gc-maps.tests -STRUCT: gc-info -{ scrub-d-count uint } -{ scrub-r-count uint } -{ gc-root-count uint } -{ derived-root-count uint } -{ return-address-count uint } ; - SINGLETON: fake-cpu fake-cpu \ cpu set M: fake-cpu gc-root-offset ; -[ ] [ - [ - init-relocation - init-gc-maps +[ + init-relocation + init-gc-maps - 50 % + 50 % - T{ gc-map f B{ } B{ } V{ } } gc-map-here + gc-map-here - 50 % + 50 % - T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } V{ { 2 4 } } } gc-map-here - - emit-gc-maps - ] B{ } make - "result" set -] unit-test + T{ gc-map + { scrub-d { 0 1 1 1 0 } } + { scrub-r { 1 0 } } + { gc-roots V{ 1 3 } } + { derived-roots V{ { 2 4 } } } + } gc-map-here + emit-gc-maps +] B{ } make +"result" set [ 0 ] [ "result" get length 16 mod ] unit-test -[ ] [ - [ - 100 % +[ + 100 % - ! The below data is 22 bytes -- 6 bytes padding needed to - ! align - 6 % + ! The below data is 46 bytes -- 14 bytes padding needed to + ! align + 14 % - ! Bitmap - 2 bytes - ?{ - ! scrub-d - t f f f t - ! scrub-r - f t - ! gc-roots - f t f t - } underlying>> % + ! Bitmap - 2 bytes + ?{ + ! scrub-d + t f f f t + ! scrub-r + f t + ! gc-roots + f t f t + } underlying>> % - ! Derived pointers - uint-array{ -1 -1 4 } underlying>> % + ! Derived pointers + uint-array{ -1 -1 4 } underlying>> % - ! Return addresses - uint-array{ 100 } underlying>> % + ! Return addresses + uint-array{ 100 } underlying>> % - ! GC info footer - 16 bytes - S{ gc-info - { scrub-d-count 5 } - { scrub-r-count 2 } - { gc-root-count 4 } - { derived-root-count 3 } - { return-address-count 1 } - } (underlying)>> % - ] B{ } make - "expect" set + ! GC info footer - 28 bytes + S{ gc-info + { scrub-d-count 5 } + { scrub-r-count 2 } + { check-d-count 0 } + { check-r-count 0 } + { gc-root-count 4 } + { derived-root-count 3 } + { return-address-count 1 } + } (underlying)>> % +] B{ } make +"expect" set + +[ t ] [ "result" get length "expect" get length = ] unit-test +[ t ] [ "result" get "expect" get = ] unit-test + +! gc-map-needed? +{ t t } [ + T{ gc-map { scrub-d { 0 1 1 1 0 } } { scrub-r { 1 0 } } } gc-map-needed? + T{ gc-map { check-d { 0 1 1 1 } } } gc-map-needed? ] unit-test -[ ] [ "result" get length "expect" get length assert= ] unit-test -[ ] [ "result" get "expect" get assert= ] unit-test +! emit-scrub +{ 3 V{ t t t f f f } } [ + [ { { 0 0 0 } { 1 1 1 } } emit-scrub ] V{ } make +] unit-test + +! emit-gc-info-bitmaps +{ + { 4 2 0 0 0 } + V{ 1 } +} [ + { T{ gc-map { scrub-d { 0 1 1 1 } } { scrub-r { 1 1 } } } } gc-maps set + [ emit-gc-info-bitmaps ] V{ } make +] unit-test + +{ + { 1 0 1 0 0 } + V{ 3 } +} [ + { T{ gc-map { scrub-d { 0 } } { check-d { 0 } } } } gc-maps set + [ emit-gc-info-bitmaps ] V{ } make +] unit-test + +! derived-root-offsets +USING: present prettyprint ; +{ + V{ { 2 4 } } +} [ + T{ gc-map { derived-roots V{ { 2 4 } } } } + derived-root-offsets +] unit-test + +! emit-base-tables +{ + 3 B{ 255 255 255 255 255 255 255 255 4 0 0 0 } +} [ + { T{ gc-map { derived-roots V{ { 2 4 } } } } } gc-maps set + [ emit-base-tables ] B{ } make +] unit-test + + +! serialize-gc-maps +{ + B{ 0 0 0 0 } +} [ + { } return-addresses set serialize-gc-maps +] unit-test + +{ + B{ + 17 123 0 0 0 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 + 1 0 0 0 + } +} [ + { 123 } return-addresses set + { T{ gc-map { scrub-d { 0 1 1 1 0 } } } } gc-maps set + serialize-gc-maps +] unit-test + +! gc-info + ret-addr + 9bits (5+2+2) = 28 + 4 + 2 = 34 +{ 34 } [ + { + T{ gc-map + { scrub-d { 0 1 1 1 0 } } + { scrub-r { 1 0 } } + { gc-roots V{ 1 3 } } + } + } gc-maps set + { 123 } return-addresses set + serialize-gc-maps length +] unit-test + +! gc-info + ret-addr + 3 base-pointers + 9bits = 28 + 4 + 12 + 2 = 46 +{ 46 } [ + { + T{ gc-map + { scrub-d { 0 1 1 1 0 } } + { scrub-r { 1 0 } } + { gc-roots V{ 1 3 } } + { derived-roots V{ { 2 4 } } } + } + } gc-maps set + { 123 } return-addresses set + serialize-gc-maps length +] unit-test diff --git a/basis/compiler/codegen/gc-maps/gc-maps.factor b/basis/compiler/codegen/gc-maps/gc-maps.factor index 474781ea95..d5a9c0fe8c 100644 --- a/basis/compiler/codegen/gc-maps/gc-maps.factor +++ b/basis/compiler/codegen/gc-maps/gc-maps.factor @@ -1,44 +1,17 @@ ! Copyright (C) 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs bit-arrays combinators +USING: accessors arrays assocs bit-arrays classes.tuple combinators combinators.short-circuit compiler.cfg.instructions compiler.codegen.relocation cpu.architecture fry kernel layouts -make math math.order namespaces sequences ; +make math math.order namespaces sequences sequences.generalizations ; IN: compiler.codegen.gc-maps -! GC maps - -! Every code block either ends with -! -! uint 0 -! -! or -! -! bitmap, byte aligned, three subsequences: -! - -! - -! - -! uint[] -! uint[] -! uint -! uint -! uint -! uint -! int - SYMBOLS: return-addresses gc-maps ; -: gc-map-needed? ( gc-map -- ? ) - ! If there are no stack locations to scrub and no GC roots, - ! there's no point storing the GC map. - dup [ - { - [ scrub-d>> empty? ] - [ scrub-r>> empty? ] - [ gc-roots>> empty? ] - [ derived-roots>> empty? ] - } 1&& not - ] when ; +: gc-map-needed? ( gc-map/f -- ? ) + ! If there are no stack locations to scrub or check, and no GC + ! roots, there's no point storing the GC map. + dup [ tuple-slots [ empty? ] all? not ] when ; : gc-map-here ( gc-map -- ) dup gc-map-needed? [ @@ -71,13 +44,15 @@ SYMBOLS: return-addresses gc-maps ; : gc-root-offsets ( gc-map -- offsets ) gc-roots>> [ gc-root-offset ] map ; -: emit-gc-info-bitmaps ( -- scrub-d-count scrub-r-count gc-root-count ) +: emit-gc-info-bitmaps ( -- scrub-and-check-counts ) [ gc-maps get { [ [ scrub-d>> ] map emit-scrub ] [ [ scrub-r>> ] map emit-scrub ] + [ [ check-d>> ] map emit-scrub ] + [ [ check-r>> ] map emit-scrub ] [ [ gc-root-offsets ] map emit-gc-roots ] - } cleave + } cleave 5 narray ] ?{ } make underlying>> % ; : emit-base-table ( alist longest -- ) @@ -98,9 +73,9 @@ SYMBOLS: return-addresses gc-maps ; [ return-addresses get empty? [ 0 emit-uint ] [ emit-gc-info-bitmaps - emit-base-tables + emit-base-tables suffix emit-return-addresses - 4array emit-uints + emit-uints return-addresses get length emit-uint ] if ] B{ } make ; diff --git a/basis/compiler/codegen/labels/labels-docs.factor b/basis/compiler/codegen/labels/labels-docs.factor new file mode 100644 index 0000000000..f84978ee0e --- /dev/null +++ b/basis/compiler/codegen/labels/labels-docs.factor @@ -0,0 +1,10 @@ +USING: compiler.codegen.relocation help.markup help.syntax strings ; +IN: compiler.codegen.labels + +HELP: define-label +{ $values { "name" string } } +{ $description "Defines a new label with the given name. The " { $slot "offset" } " slot is filled in later." } ; + +HELP: resolve-label +{ $values { "label/name" { $link label } " or " { $link string } } } +{ $description "Assigns the current " { $link compiled-offset } " to the given label." } ; diff --git a/basis/compiler/codegen/relocation/relocation-docs.factor b/basis/compiler/codegen/relocation/relocation-docs.factor new file mode 100644 index 0000000000..145b1d50c3 --- /dev/null +++ b/basis/compiler/codegen/relocation/relocation-docs.factor @@ -0,0 +1,42 @@ +USING: byte-vectors compiler.codegen.labels compiler.constants cpu.architecture +help.markup help.syntax make strings ; +IN: compiler.codegen.relocation + +HELP: relocation-table +{ $description "A " { $link byte-vector } " holding the relocations for the current compilation. Each sequence of four bytes in the vector represents one relocation." } +{ $see-also init-relocation } ; + +HELP: add-relocation +{ $values + { "class" "a relocation class such as " { $link rc-relative } } + { "type" "a relocation type such as " { $link rt-safepoint } } +} +{ $description "Adds one relocation to the relocation table." } ; + +HELP: add-literal +{ $values { "obj" "a symbol" } } +{ $description "Adds a symbol to the " { $link literal-table } "." } ; + +HELP: init-relocation +{ $description "Initializes the dynamic variables related to code relocation." } ; + +HELP: rel-safepoint +{ $values { "class" "a relocation class" } } +{ $description "Adds a safe point to the " { $link relocation-table } " for the current code offset. This word is used by the " { $link %safepoint } " generator." } ; + +HELP: compiled-offset +{ $values { "n" "offset of the code being constructed in the current " { $link make } " sequence." } } +{ $description "The current compiled code offset. Used for (among other things) calculating jump labels." } +{ $examples + { $example + "USING: compiler.codegen.relocation cpu.x86.assembler" + "cpu.x86.assembler.operands kernel layouts make prettyprint ;" + "[ init-relocation RAX 0 MOV compiled-offset ] B{ } make" + "cell-bits 64 = [" + " [ 10 = ] [ B{ 72 184 0 0 0 0 0 0 0 0 } = ] bi*" + "] [" + " [ 6 = ] [ B{ 72 184 0 0 0 0 } = ] bi*" + "] if . ." + "t\nt" + } +} ; diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 76c93a8422..d961674282 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -1,4 +1,4 @@ -USING: assocs compiler.cfg.builder compiler.cfg.optimizer +USING: assocs compiler.cfg compiler.cfg.builder compiler.cfg.optimizer compiler.errors compiler.tree.builder compiler.tree.optimizer compiler.units compiler.codegen help.markup help.syntax io parser quotations sequences words ; @@ -19,7 +19,7 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler" "More 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." +"The " { $vocab-link "compiler" } " vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop." $nl "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 @@ -54,6 +54,18 @@ $nl ABOUT: "compiler" +HELP: frontend +{ $values { "word" word } { "tree" sequence } } +{ $description "First step of the compilation process. It outputs a high-level tree in SSA form." } ; + +HELP: backend +{ $values { "tree" "a " { $link sequence } " of SSA nodes" } { "word" word } } +{ $description "The second last step of the compilation process. A word and its SSA tree is taken as input and a " { $link cfg } " is built from which assembly code is generated." } +{ $see-also generate } ; + +HELP: compiled +{ $var-description { "An " { $link assoc } " used by the optimizing compiler for intermediate storage of generated code. The keys are the labels to the CFG:s and the values the generated code as given by the " { $link generate } " word." } } ; + HELP: compile-word { $values { "word" word } } { $description "Compile a single word." } diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 10be5ff8f9..1760318432 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -1,12 +1,13 @@ USING: accessors alien alien.c-types alien.libraries alien.syntax arrays classes.struct combinators -compiler continuations effects generalizations io +compiler continuations destructors effects generalizations io io.backend io.pathnames io.streams.string kernel math memory namespaces namespaces.private parser quotations sequences specialized-arrays stack-checker stack-checker.errors system threads tools.test words alien.complex concurrency.promises alien.data -byte-arrays classes compiler.test libc ; +byte-arrays classes compiler.test libc layouts +math.bitwise ; FROM: alien.c-types => float short ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: char @@ -337,28 +338,30 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; : callback-throws ( -- x ) int { } cdecl [ "Hi" throw ] alien-callback ; -[ t ] [ callback-throws alien? ] unit-test +{ t } [ + callback-throws [ alien? ] with-callback +] unit-test : callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ; [ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test -[ t ] [ callback-1 alien? ] unit-test +{ t } [ callback-1 [ alien? ] with-callback ] unit-test : callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ; -[ ] [ callback-1 callback_test_1 ] unit-test +{ } [ callback-1 [ callback_test_1 ] with-callback ] unit-test : callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ; -[ ] [ callback-2 callback_test_1 ] unit-test +{ } [ callback-2 [ callback_test_1 ] with-callback ] unit-test : callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ; -[ t 3 5 ] [ +{ t 3 5 } [ [ namestack* - 3 "x" set callback-3 callback_test_1 + 3 "x" set callback-3 [ callback_test_1 ] with-callback namestack* eq? "x" get "x" get-global ] with-scope @@ -367,33 +370,35 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; : callback-5 ( -- callback ) void { } cdecl [ gc ] alien-callback ; -[ "testing" ] [ - "testing" callback-5 callback_test_1 +{ "testing" } [ + "testing" callback-5 [ callback_test_1 ] with-callback ] unit-test : callback-5b ( -- callback ) void { } cdecl [ compact-gc ] alien-callback ; [ "testing" ] [ - "testing" callback-5b callback_test_1 + "testing" callback-5b [ callback_test_1 ] with-callback ] unit-test : callback-6 ( -- callback ) void { } cdecl [ [ continue ] callcc0 ] alien-callback ; -[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test +[ 1 2 3 ] [ + callback-6 [ callback_test_1 1 2 3 ] with-callback +] unit-test : callback-7 ( -- callback ) void { } cdecl [ 1000000 sleep ] alien-callback ; -[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test +[ 1 2 3 ] [ callback-7 [ callback_test_1 1 2 3 ] with-callback ] unit-test [ f ] [ namespace global eq? ] unit-test : callback-8 ( -- callback ) void { } cdecl [ [ ] in-thread yield ] alien-callback ; -[ ] [ callback-8 callback_test_1 ] unit-test +[ ] [ callback-8 [ callback_test_1 ] with-callback ] unit-test : callback-9 ( -- callback ) int { int int int } cdecl [ @@ -406,9 +411,9 @@ FUNCTION: void ffi_test_36_point_5 ( ) ; FUNCTION: int ffi_test_37 ( void* func ) ; -[ 1 ] [ callback-9 ffi_test_37 ] unit-test +[ 1 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test -[ 7 ] [ callback-9 ffi_test_37 ] unit-test +[ 7 ] [ callback-9 [ ffi_test_37 ] with-callback ] unit-test STRUCT: test_struct_13 { x1 float } @@ -462,11 +467,12 @@ STRUCT: double-rect void { void* void* double-rect } cdecl alien-indirect "example" get-global ; -[ byte-array 1.0 2.0 3.0 4.0 ] -[ +{ byte-array 1.0 2.0 3.0 4.0 } [ 1.0 2.0 3.0 4.0 - double-rect-callback double-rect-test - [ >c-ptr class-of ] [ >double-rect< ] bi + double-rect-callback [ + double-rect-test + [ >c-ptr class-of ] [ >double-rect< ] bi + ] with-callback ] unit-test STRUCT: test_struct_14 @@ -490,9 +496,10 @@ FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ; : callback-10-test ( x1 x2 callback -- result ) test_struct_14 { double double } cdecl alien-indirect ; -[ 1.0 2.0 ] [ - 1.0 2.0 callback-10 callback-10-test - [ x1>> ] [ x2>> ] bi +{ 1.0 2.0 } [ + 1.0 2.0 callback-10 [ + callback-10-test [ x1>> ] [ x2>> ] bi + ] with-callback ] unit-test FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; @@ -513,9 +520,10 @@ FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ; : callback-11-test ( x1 x2 callback -- result ) test-struct-12 { int double } cdecl alien-indirect ; -[ 1 2.0 ] [ - 1 2.0 callback-11 callback-11-test - [ a>> ] [ x>> ] bi +{ 1 2.0 } [ + 1 2.0 callback-11 [ + callback-11-test [ a>> ] [ x>> ] bi + ] with-callback ] unit-test STRUCT: test_struct_15 @@ -538,7 +546,9 @@ FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ; test_struct_15 { float float } cdecl alien-indirect ; [ 1.0 2.0 ] [ - 1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi + 1.0 2.0 callback-12 [ + callback-12-test [ x>> ] [ y>> ] bi + ] with-callback ] unit-test STRUCT: test_struct_16 @@ -560,9 +570,10 @@ FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ; : callback-13-test ( x1 x2 callback -- result ) test_struct_16 { float int } cdecl alien-indirect ; -[ 1.0 2 ] [ - 1.0 2 callback-13 callback-13-test - [ x>> ] [ a>> ] bi +{ 1.0 2 } [ + 1.0 2 callback-13 [ + callback-13-test [ x>> ] [ a>> ] bi + ] with-callback ] unit-test FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline @@ -618,8 +629,14 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; int { } cdecl alien-indirect ; "p" set -[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread -[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test +[ + thread-callback-1 [ + thread-callback-invoker + ] with-callback "p" get fulfill +] in-thread +{ 200 } [ + thread-callback-2 [ thread-callback-invoker ] with-callback +] unit-test [ 100 ] [ "p" get ?promise ] unit-test ! More alien-assembly tests are in cpu.* vocabs @@ -643,7 +660,7 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ] 3dip int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ; - + [ 4 ] [ 3 ffi_test_49 ] unit-test [ 8 ] [ 3 4 ffi_test_50 ] unit-test [ 13 ] [ 3 4 5 ffi_test_51 ] unit-test @@ -662,6 +679,18 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ; test-struct-11 "f-fastcall" "ffi_test_58" { int int int } alien-invoke gc ; +! Make sure that large longlong/ulonglong are correctly dealt with +FUNCTION: longlong ffi_test_59 ( longlong x ) ; +FUNCTION: ulonglong ffi_test_60 ( ulonglong x ) ; + +[ t ] [ most-positive-fixnum 1 + [ ffi_test_59 ] keep = ] unit-test +[ t ] [ most-positive-fixnum 1 + [ ffi_test_60 ] keep = ] unit-test + +[ -1 ] [ -1 ffi_test_59 ] unit-test +[ -1 ] [ 0xffffffffffffffff ffi_test_59 ] unit-test +[ 0xffffffffffffffff ] [ -1 ffi_test_60 ] unit-test +[ 0xffffffffffffffff ] [ 0xffffffffffffffff ffi_test_60 ] unit-test + ! GCC bugs mingw? [ [ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test @@ -755,19 +784,33 @@ mingw? [ test-struct-11 { int int int } fastcall [ [ drop + ] [ - nip ] 3bi test-struct-11 ] alien-callback ; -[ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test +{ 8 } [ + 3 4 fastcall-ii-callback [ fastcall-ii-indirect ] with-callback +] unit-test -[ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test +[ 13 ] [ + 3 4 5 fastcall-iii-callback [ fastcall-iii-indirect ] with-callback +] unit-test -[ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test +[ 13 ] [ + 3 4.0 5 fastcall-ifi-callback [ fastcall-ifi-indirect ] with-callback +] unit-test -[ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test +[ 19 ] [ + 3 4.0 5 6 fastcall-ifii-callback [ fastcall-ifii-indirect ] with-callback +] unit-test -[ S{ test-struct-11 f 7 -1 } ] -[ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test +[ S{ test-struct-11 f 7 -1 } ] [ + 3 4 fastcall-struct-return-ii-callback [ + fastcall-struct-return-ii-indirect + ] with-callback +] unit-test -[ S{ test-struct-11 f 7 -3 } ] -[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test +[ S{ test-struct-11 f 7 -3 } ] [ + 3 4 7 fastcall-struct-return-iii-callback [ + fastcall-struct-return-iii-indirect + ] with-callback +] unit-test : x64-regression-1 ( -- c ) int { int int int int int } cdecl [ + + + + ] alien-callback ; @@ -775,10 +818,14 @@ mingw? [ : x64-regression-2 ( x x x x x c -- y ) int { int int int int int } cdecl alien-indirect ; inline -[ 661 ] [ 100 500 50 10 1 x64-regression-1 x64-regression-2 ] unit-test +[ 661 ] [ + 100 500 50 10 1 x64-regression-1 [ x64-regression-2 ] with-callback +] unit-test ! Stack allocation -: blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ; +: blah ( -- x ) { RECT } [ + 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum +] with-scoped-allocation ; [ 3 ] [ blah ] unit-test @@ -809,7 +856,9 @@ mingw? [ alien-indirect ] with-out-parameters ; -[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test +[ 12 ] [ + 6 out-param-callback [ out-param-indirect ] with-callback +] unit-test ! Alias analysis regression : aa-callback-1 ( -- c ) @@ -823,8 +872,9 @@ TUPLE: some-tuple x ; [ T{ some-tuple f 5.0 } ] [ [ some-tuple new - aa-callback-1 - aa-indirect-1 >>x + aa-callback-1 [ + aa-indirect-1 + ] with-callback >>x ] compile-call ] unit-test diff --git a/basis/compiler/tests/linkage-errors.factor b/basis/compiler/tests/linkage-errors.factor index 98a07899f3..b622ccc09d 100644 --- a/basis/compiler/tests/linkage-errors.factor +++ b/basis/compiler/tests/linkage-errors.factor @@ -1,48 +1,48 @@ -USING: tools.test namespaces assocs alien.syntax kernel -compiler.errors accessors alien alien.c-types alien.strings -debugger literals ; -FROM: alien.libraries => add-library load-library ; -IN: compiler.tests.linkage-errors - -! Regression: calling an undefined function would raise a protection fault -FUNCTION: void this_does_not_exist ( ) ; - -[ this_does_not_exist ] try - -[ this_does_not_exist ] [ - { "kernel-error" 9 $[ "this_does_not_exist" string>symbol ] f } - = -] must-fail-with - -[ T{ no-such-symbol { name "this_does_not_exist" } } ] -[ - \ this_does_not_exist linkage-errors get at error>> - ! We don't care about the error message from dlerror, just - ! wipe it out - clone f >>message -] unit-test - -<< "no_such_library" "no_such_library" cdecl add-library >> - -LIBRARY: no_such_library - -FUNCTION: void no_such_function ( ) ; - -[ no_such_function ] try - -[ no_such_function ] [ - { - "kernel-error" 9 - $[ "no_such_function" string>symbol ] - $[ "no_such_library" load-library ] - } - = -] must-fail-with - -[ T{ no-such-library { name "no_such_library" } } ] -[ - \ no_such_function linkage-errors get at error>> - ! We don't care about the error message from dlerror, just - ! wipe it out - clone f >>message -] unit-test +USING: tools.test namespaces assocs alien.syntax kernel +compiler.errors accessors alien alien.c-types alien.strings +debugger literals kernel.private ; +FROM: alien.libraries => add-library load-library ; +IN: compiler.tests.linkage-errors + +! Regression: calling an undefined function would raise a protection fault +FUNCTION: void this_does_not_exist ( ) ; + +[ this_does_not_exist ] try + +[ this_does_not_exist ] [ + ${ "kernel-error" ERROR-UNDEFINED-SYMBOL "this_does_not_exist" string>symbol f } + = +] must-fail-with + +[ T{ no-such-symbol { name "this_does_not_exist" } } ] +[ + \ this_does_not_exist linkage-errors get at error>> + ! We don't care about the error message from dlerror, just + ! wipe it out + clone f >>message +] unit-test + +<< "no_such_library" "no_such_library" cdecl add-library >> + +LIBRARY: no_such_library + +FUNCTION: void no_such_function ( ) ; + +[ no_such_function ] try + +[ no_such_function ] [ + ${ + "kernel-error" ERROR-UNDEFINED-SYMBOL + "no_such_function" string>symbol + "no_such_library" load-library + } + = +] must-fail-with + +[ T{ no-such-library { name "no_such_library" } } ] +[ + \ no_such_function linkage-errors get at error>> + ! We don't care about the error message from dlerror, just + ! wipe it out + clone f >>message +] unit-test diff --git a/basis/compiler/tree/builder/builder-docs.factor b/basis/compiler/tree/builder/builder-docs.factor index 83093470c9..5f761be681 100644 --- a/basis/compiler/tree/builder/builder-docs.factor +++ b/basis/compiler/tree/builder/builder-docs.factor @@ -1,5 +1,5 @@ -USING: help.markup help.syntax sequences quotations words -compiler.tree stack-checker.errors ; +USING: compiler.tree help.markup help.syntax literals quotations sequences +stack-checker.errors words ; IN: compiler.tree.builder HELP: build-tree @@ -10,4 +10,20 @@ HELP: build-tree HELP: build-sub-tree { $values { "in-d" "a sequence of values" } { "out-d" "a sequence of values" } { "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." } ; +{ $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." } +{ $examples + { $unchecked-example + ! The out-d numbers are unpredicable. + "USING: compiler.tree.builder math prettyprint ;" + "{ \"x\" } { \"y\" } [ 4 * ] build-sub-tree ." + $[ + { + "V{" + " T{ #push { literal 4 } { out-d { 1 } } }" + " T{ #call { word * } { in-d V{ \"x\" 1 } } { out-d { 2 } } }" + " T{ #copy { in-d V{ 2 } } { out-d { \"y\" } } }" + "}" + } "\n" join + ] + } +} ; diff --git a/basis/compiler/tree/cleanup/cleanup-docs.factor b/basis/compiler/tree/cleanup/cleanup-docs.factor new file mode 100644 index 0000000000..73ca20baa2 --- /dev/null +++ b/basis/compiler/tree/cleanup/cleanup-docs.factor @@ -0,0 +1,9 @@ +USING: help.markup help.syntax sequences ; +IN: compiler.tree.cleanup + +ARTICLE: "compiler.tree.cleanup" "Cleanup Phase" +"A phase run after propagation to finish the job, so to speak. Codifies speculative inlining decisions, deletes branches marked as never taken, and flattens local recursive blocks that do not call themselves." ; + +HELP: cleanup +{ $values { "nodes" sequence } { "nodes'" sequence } } +{ $description "Main entry point for the cleanup optimization phase." } ; diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 5cf2a4f469..6c9d846da8 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -12,11 +12,6 @@ compiler.tree.propagation.info compiler.tree.propagation.branches ; IN: compiler.tree.cleanup -! A phase run after propagation to finish the job, so to speak. -! Codifies speculative inlining decisions, deletes branches -! marked as never taken, and flattens local recursive blocks -! that do not call themselves. - GENERIC: delete-node ( node -- ) M: #call-recursive delete-node diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 8b7c3a57f5..7369c0dced 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -23,7 +23,11 @@ TUPLE: declared-fixnum { x fixnum } ; [ t ] [ [ { declared-fixnum } declare [ 1 + ] change-x ] - { + fixnum+ >fixnum } inlined? + { + } inlined? + ! XXX: As of .97, we do a bounds check and throw an error on + ! overflow, so we no longer convert fixnum+ to fixnum+fast. + ! If this is too big a regression, we can revert it. + ! { + fixnum+ >fixnum } inlined? ] unit-test [ t ] [ diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index 65a7e889ee..135a63692d 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -39,7 +39,7 @@ IN: compiler.tree.modular-arithmetic ! is a modular arithmetic word, then the input can be converted into ! a form that is cheaper to compute. { - >fixnum bignum>fixnum integer>fixnum integer>fixnum-strict + >fixnum bignum>fixnum integer>fixnum float>fixnum set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2 set-alien-signed-2 diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index aae41f9c2d..29fb38005e 100644 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/basis/compiler/tree/propagation/branches/branches.factor @@ -57,6 +57,8 @@ SYMBOL: infer-children-data value-infos off constraints off ; +DEFER: collect-variables + : infer-children ( node -- ) [ live-children ] [ child-constraints ] bi [ [ @@ -64,7 +66,8 @@ SYMBOL: infer-children-data [ copy-value-info assume (propagate) ] [ 2drop no-value-info ] if - ] H{ } make-assoc + collect-variables + ] with-scope ] 2map infer-children-data set ; : compute-phi-input-infos ( phi-in -- phi-info ) @@ -86,6 +89,14 @@ SYMBOL: infer-children-data SYMBOL: condition-value +: collect-variables ( -- hash ) + { + condition-value + constraints + infer-children-data + value-infos + } [ dup get ] H{ } map>assoc ; + M: #phi propagate-before ( #phi -- ) [ annotate-phi-inputs ] [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ] diff --git a/basis/compiler/tree/propagation/info/info-docs.factor b/basis/compiler/tree/propagation/info/info-docs.factor new file mode 100644 index 0000000000..4e11f5bacc --- /dev/null +++ b/basis/compiler/tree/propagation/info/info-docs.factor @@ -0,0 +1,21 @@ +USING: compiler.tree help.markup help.syntax sequences ; +IN: compiler.tree.propagation.info + +HELP: value-info-state +{ $class-description "Represents constraints the compiler knows about the input and output variables to an SSA tree node. It has the following slots:" + { $table + { { $slot "class" } { "Class of values the variable can take." } } + { { $slot "interval" } { "Range of values the variable can take." } } + { { $slot "literal" } { "Literal value, if present." } } + { { $slot "literal?" } { "Whether the value of the variable is known at compile-time or not." } } + { { $slot "slots" } { "If the value is a literal tuple or fixed length type, then slots is a " { $link sequence } " of " { $link value-info-state } " encoding what is known about its slots at compile-time." } } + } +} ; + +HELP: node-input-infos +{ $values { "node" node } { "seq" sequence } } +{ $description "Lists the value infos for the input variables of an SSA tree node." } ; + +HELP: node-output-infos +{ $values { "node" node } { "seq" sequence } } +{ $description "Lists the value infos for the output variables of an SSA tree node." } ; diff --git a/basis/compiler/tree/propagation/known-words/known-words-docs.factor b/basis/compiler/tree/propagation/known-words/known-words-docs.factor new file mode 100644 index 0000000000..9a981d46cd --- /dev/null +++ b/basis/compiler/tree/propagation/known-words/known-words-docs.factor @@ -0,0 +1,38 @@ +USING: classes compiler.tree.propagation.info help.markup +help.syntax kernel math math.intervals ; +IN: compiler.tree.propagation.known-words + +HELP: binary-op-class +{ $values { "info1" value-info-state } { "info2" value-info-state } { "newclass" class } } +{ $description "Given two value infos return the math class which is large enough for both of them." } +{ $examples + { $example + "USING: compiler.tree.propagation.known-words compiler.tree.propagation.info" + "kernel math prettyprint ;" + "bignum real [ ] bi@ binary-op-class ." + "real" + } +} ; + +HELP: unary-op-class +{ $values { "info" value-info-state } { "newclass" class } } +{ $description "Returns the smallest math class large enough to hold values of the value infos class." } +{ $see-also binary-op-class } ; + +HELP: number-valued +{ $values + { "class" class } { "interval" interval } + { "class'" class } { "interval'" interval } +} +{ $description "Ensure that the class is a subclass of " { $link number } "." } ; + +HELP: fits-in-fixnum? +{ $values { "interval" interval } { "?" boolean } } +{ $description "Checks if the interval is a subset of the " { $link fixnum } " interval. Used to see if arithmetic may overflow." } +{ $examples + { $example + "USING: compiler.tree.propagation.known-words math.intervals prettyprint ;" + "full-interval fits-in-fixnum? ." + "f" + } +} ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index d158c931b3..206ad633a9 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -225,6 +225,7 @@ generic-comparison-ops [ { { >fixnum fixnum } { bignum>fixnum fixnum } + { bignum>fixnum-strict fixnum } { integer>fixnum fixnum } { integer>fixnum-strict fixnum } diff --git a/basis/compiler/tree/propagation/nodes/nodes-docs.factor b/basis/compiler/tree/propagation/nodes/nodes-docs.factor new file mode 100644 index 0000000000..92886f45a8 --- /dev/null +++ b/basis/compiler/tree/propagation/nodes/nodes-docs.factor @@ -0,0 +1,6 @@ +USING: compiler.tree help.markup help.syntax ; +IN: compiler.tree.propagation.nodes + +HELP: annotate-node +{ $values { "node" node } } +{ $description "Initializes the info slot for SSA tree nodes that have it." } ; diff --git a/basis/compiler/tree/propagation/propagation-docs.factor b/basis/compiler/tree/propagation/propagation-docs.factor new file mode 100644 index 0000000000..039ea44692 --- /dev/null +++ b/basis/compiler/tree/propagation/propagation-docs.factor @@ -0,0 +1,52 @@ +USING: help.markup help.syntax literals multiline ; +IN: compiler.tree.propagation + +<< +STRING: propagate-ex +USING: compiler.tree.builder compiler.tree.propagation math prettyprint ; +[ 3 + ] build-tree propagate third . +T{ #call + { word + } + { in-d V{ 9450187 9450186 } } + { out-d { 9450188 } } + { info + H{ + { + 9450186 + T{ value-info-state + { class fixnum } + { interval + T{ interval + { from ~array~ } + { to ~array~ } + } + } + { literal 3 } + { literal? t } + } + } + { + 9450187 + T{ value-info-state + { class object } + { interval full-interval } + } + } + { + 9450188 + T{ value-info-state + { class number } + { interval full-interval } + } + } + } + } +} +; +>> + +HELP: propagate +{ $values { "nodes" "a sequence of nodes" } } +{ $description "Performs the propagation pass of the AST optimization. All nodes info slots are initialized here." } +{ $examples { $unchecked-example $[ propagate-ex ] } +} ; diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index a11264fb7f..81309088c4 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -15,7 +15,7 @@ IN: compiler.tree.propagation ! This pass must run after normalization -: propagate ( node -- node ) +: propagate ( nodes -- nodes ) H{ } clone copies set H{ } clone 1array value-infos set H{ } clone 1array constraints set diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index c9148e2f18..b07e8d4bca 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -74,9 +74,17 @@ M: #declare propagate-before ] [ 2drop ] if ] if* ; +ERROR: invalid-outputs #call infos ; + +: check-outputs ( #call infos -- infos ) + over out-d>> over [ length ] bi@ = + [ nip ] [ invalid-outputs ] if ; + : call-outputs-quot ( #call word -- infos ) - [ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi* - with-datastack ; + dupd + [ in-d>> [ value-info ] map ] + [ "outputs" word-prop ] bi* + with-datastack check-outputs ; : literal-inputs? ( #call -- ? ) in-d>> [ value-info literal?>> ] all? ; diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index 6fc10b797b..689ae20202 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -9,7 +9,7 @@ math.integers.private layouts math.order vectors hashtables combinators effects generalizations sequences.generalizations assocs sets combinators.short-circuit sequences.private locals growable stack-checker namespaces compiler.tree.propagation.info -hash-sets ; +hash-sets arrays hashtables.private ; FROM: math => float ; FROM: sets => set members ; IN: compiler.tree.propagation.transforms @@ -45,11 +45,11 @@ IN: compiler.tree.propagation.transforms in-d>> rem-custom-inlining ] "custom-inlining" set-word-prop -: positive-fixnum? ( obj -- ? ) +: non-negative-fixnum? ( obj -- ? ) { [ fixnum? ] [ 0 >= ] } 1&& ; : simplify-bitand? ( value1 value2 -- ? ) - [ literal>> positive-fixnum? ] + [ literal>> non-negative-fixnum? ] [ class>> fixnum swap class<= ] bi* and ; @@ -318,7 +318,7 @@ M\ set intersects? [ intersects?-quot ] 1 define-partial-eval : bit-quot ( #call -- quot/f ) in-d>> second value-info interval>> 0 fixnum-bits [a,b] interval-subset? - [ [ >fixnum ] dip fixnum-bit? ] f ? ; + [ [ integer>fixnum ] dip fixnum-bit? ] f ? ; \ bit? [ bit-quot ] "custom-inlining" set-word-prop diff --git a/basis/compiler/tree/tree-docs.factor b/basis/compiler/tree/tree-docs.factor new file mode 100644 index 0000000000..3d15f35de4 --- /dev/null +++ b/basis/compiler/tree/tree-docs.factor @@ -0,0 +1,52 @@ +USING: assocs help.markup help.syntax kernel sequences stack-checker.alien +stack-checker.visitor words ; +IN: compiler.tree + +HELP: node +{ $class-description "Base class for all SSA tree nodes." } ; + +HELP: #alien-node +{ $class-description "Base class for alien nodes. Its " { $snippet "params" } " slot holds an instance of the " { $link alien-node-params } " class." } ; + +HELP: #alien-invoke +{ $class-description "SSA tree node that calls a function in a dynamically linked library." } ; + +HELP: #alien-callback +{ $class-description "SSA tree node that constructs an alien callback." } ; + +HELP: #call +{ $class-description "SSA tree node that calls a word. It has the following slots:" + { $table + { { $slot "word" } { "The " { $link word } " to call." } } + { { $slot "in-d" } { "Sequence of input variables to the call. The items are ordered from top to bottom of the stack." } } + { { $slot "out-d" } { "Output values of the call." } } + { { $slot "info" } { "An assoc that contains various annotations for the words input and output values. It is set during the propagation pass of the optimizer." } } + } +} ; + +HELP: #introduce +{ $class-description "SSA tree node that puts an input value from the \"outside\" on the stack." } ; + +HELP: #push +{ $class-description "SSA tree node that puts a literal value on the stack." } +{ $notes "A quotation is also a literal." } ; + +HELP: #shuffle +{ $class-description "SSA tree node that represents a stack shuffling operation such as " { $link swap } ". It has the following slots:" + { $table + { { $slot "mapping" } { "An " { $link assoc } " that shows how the shuffle output values (the keys) correspond to their inputs (the values)." } } + } +} ; + +HELP: #if +{ $class-description "SSA tree node that implements conditional branching. It has the following slots:" + { $table + { { $slot "children" } + { "A two item " { $link sequence } ". The first item holds the instructions executed if the condition is true and the second those that are executed if it is not true." } + } + } +} ; + +HELP: node, +{ $values { "node" node } } +{ $description "Emits a node to the " { $link stack-visitor } " variable." } ; diff --git a/basis/compression/snappy/authors.txt b/basis/compression/snappy/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/compression/snappy/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/compression/snappy/ffi/authors.txt b/basis/compression/snappy/ffi/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/compression/snappy/ffi/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/compression/snappy/ffi/ffi.factor b/basis/compression/snappy/ffi/ffi.factor new file mode 100644 index 0000000000..5cdad5bd35 --- /dev/null +++ b/basis/compression/snappy/ffi/ffi.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2014 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.libraries +alien.libraries.finder alien.syntax classes.struct ; +USE: nested-comments +IN: compression.snappy.ffi + +<< "snappy" "snappy" find-library cdecl add-library >> + +LIBRARY: snappy + +ENUM: snappy_status SNAPPY_OK SNAPPY_INVALID_INPUT SNAPPY_BUFFER_TOO_SMALL ; + +FUNCTION: snappy_status snappy_compress ( char* input, + size_t input_length, + char* compressed, + size_t* compressed_length ) ; + +FUNCTION: snappy_status snappy_uncompress ( char* compressed, + size_t compressed_length, + char* uncompressed, + size_t* uncompressed_length ) ; + +FUNCTION: size_t snappy_max_compressed_length ( size_t source_length ) ; + +FUNCTION: snappy_status snappy_uncompressed_length ( char* compressed, + size_t compressed_length, + size_t* result ) ; + +FUNCTION: snappy_status snappy_validate_compressed_buffer ( char* compressed, + size_t compressed_length ) ; + diff --git a/basis/compression/snappy/snappy-tests.factor b/basis/compression/snappy/snappy-tests.factor new file mode 100644 index 0000000000..9411ac0f1f --- /dev/null +++ b/basis/compression/snappy/snappy-tests.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2014 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays byte-arrays compression.snappy kernel tools.test ; +IN: compression.snappy.tests + +[ t ] [ + 1000 2 >byte-array [ snappy-compress snappy-uncompress ] keep = +] unit-test + +[ t ] [ + B{ } [ snappy-compress snappy-uncompress ] keep = +] unit-test + +[ t ] [ + B{ 1 } [ snappy-compress snappy-uncompress ] keep = +] unit-test + +[ t ] [ + B{ 1 2 } [ snappy-compress snappy-uncompress ] keep = +] unit-test + +[ t ] [ + B{ 1 2 3 } [ snappy-compress snappy-uncompress ] keep = +] unit-test diff --git a/basis/compression/snappy/snappy.factor b/basis/compression/snappy/snappy.factor new file mode 100644 index 0000000000..10bd78f8c3 --- /dev/null +++ b/basis/compression/snappy/snappy.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2014 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types alien.data byte-arrays compression.snappy.ffi +kernel sequences ; +IN: compression.snappy + +ERROR: snappy-error error ; + +outs ( n -- byte-array size_t* ) + [ ] [ size_t ] bi ; + +PRIVATE> + +: snappy-compress ( byte-array -- compressed ) + dup length + dup snappy_max_compressed_length + n>outs + [ snappy_compress check-snappy ] 2keep size_t deref head ; + +: snappy-uncompress ( compressed -- byte-array ) + dup length + over + dup length 0 size_t + [ snappy_uncompressed_length check-snappy ] keep + size_t deref + n>outs + [ snappy_uncompress check-snappy ] 2keep drop >byte-array ; + diff --git a/basis/concurrency/combinators/combinators-docs.factor b/basis/concurrency/combinators/combinators-docs.factor index c3389a1aec..28d6d11bd5 100644 --- a/basis/concurrency/combinators/combinators-docs.factor +++ b/basis/concurrency/combinators/combinators-docs.factor @@ -2,27 +2,27 @@ USING: help.markup help.syntax sequences ; IN: concurrency.combinators HELP: parallel-map -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } } +{ $values { "seq" sequence } { "quot" { $quotation ( elt -- newelt ) } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: 2parallel-map -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- newelt )" } } { "newseq" sequence } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- newelt ) } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: parallel-each -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- )" } } } +{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ) } } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: 2parallel-each -{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt -- )" } } } +{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- ) } } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." } { $errors "Throws an error if one of the iterations throws an error." } ; HELP: parallel-filter -{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "newseq" sequence } } +{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ? ) } } { "newseq" sequence } } { $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." } { $errors "Throws an error if one of the iterations throws an error." } ; @@ -37,6 +37,13 @@ $nl 2parallel-map parallel-filter } +"Concurrent product sequence combinators:" +{ $subsections + parallel-product-each + parallel-cartesian-each + parallel-product-map + parallel-cartesian-map +} "Concurrent cleave combinators:" { $subsections parallel-cleave diff --git a/basis/concurrency/combinators/combinators-tests.factor b/basis/concurrency/combinators/combinators-tests.factor index f33f6513a9..74363e6af0 100644 --- a/basis/concurrency/combinators/combinators-tests.factor +++ b/basis/concurrency/combinators/combinators-tests.factor @@ -53,3 +53,9 @@ IN: concurrency.combinators.tests [ number>string ] 3 parallel-napply { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread ] unit-test + +{ H{ { 0 4 } { 2 6 } { 4 8 } } } [ + H{ { 1 2 } { 3 4 } { 5 6 } } [ + [ 1 - ] [ 2 + ] bi* + ] parallel-assoc-map +] unit-test diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor index 306242d3ac..e7c42bc644 100644 --- a/basis/concurrency/combinators/combinators.factor +++ b/basis/concurrency/combinators/combinators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.futures concurrency.count-downs sequences -kernel macros fry combinators generalizations ; +USING: arrays assocs combinators concurrency.count-downs +concurrency.futures fry generalizations kernel macros sequences +sequences.private sequences.product ; IN: concurrency.combinators -: parallel-each ( seq quot -- ) +: parallel-each ( seq quot: ( elt -- ) -- ) over length [ '[ _ curry _ spawn-stage ] each ] (parallel-each) ; inline -: 2parallel-each ( seq1 seq2 quot -- ) +: 2parallel-each ( seq1 seq2 quot: ( elt1 elt2 -- ) -- ) 2over min-length [ '[ _ 2curry _ spawn-stage ] 2each ] (parallel-each) ; inline -: parallel-filter ( seq quot -- newseq ) +: parallel-product-each ( seq quot: ( elt -- ) -- ) + [ ] dip parallel-each ; + +: parallel-cartesian-each ( seq1 seq2 quot: ( elt1 elt2 -- ) -- ) + [ 2array ] dip [ first2-unsafe ] prepose parallel-product-each ; + +: parallel-filter ( seq quot: ( elt -- ? ) -- newseq ) over [ selector [ parallel-each ] dip ] dip like ; inline PRIVATE> -: parallel-map ( seq quot -- newseq ) +: parallel-map ( seq quot: ( elt -- newelt ) -- newseq ) [future] map future-values ; inline -: 2parallel-map ( seq1 seq2 quot -- newseq ) +: parallel-assoc-map-as ( assoc quot: ( key value -- newkey newvalue ) exemplar -- newassoc ) + [ + [ 2array ] compose '[ _ 2curry future ] { } assoc>map future-values + ] dip assoc-like ; + +: parallel-assoc-map ( assoc quot: ( key value -- newkey newvalue ) -- newassoc ) + over parallel-assoc-map-as ; + +: 2parallel-map ( seq1 seq2 quot: ( elt1 elt2 -- newelt ) -- newseq ) '[ _ 2curry future ] 2map future-values ; +: parallel-product-map ( seq quot: ( elt -- newelt ) -- newseq ) + [ ] dip parallel-map ; + +: parallel-cartesian-map ( seq1 seq2 quot: ( elt1 elt2 -- newelt ) -- newseq ) + [ 2array ] dip [ first2-unsafe ] prepose parallel-product-map ; + { $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ; HELP: mailbox-empty? -{ $values { "mailbox" mailbox } - { "bool" "a boolean" } +{ $values { "mailbox" mailbox } + { "bool" boolean } } { $description "Return true if the mailbox is empty." } ; HELP: mailbox-put -{ $values { "obj" object } - { "mailbox" mailbox } +{ $values { "obj" object } + { "mailbox" mailbox } } { $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ; HELP: block-unless-pred { $values { "mailbox" mailbox } - { "timeout" "a " { $link duration } " or " { $link f } } - { "pred" { $quotation "( ... message -- ... ? )" } } + { "timeout" { $maybe duration } } + { "pred" { $quotation ( ... message -- ... ? ) } } } { $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ; HELP: block-if-empty -{ $values { "mailbox" mailbox } - { "timeout" "a " { $link duration } " or " { $link f } } +{ $values { "mailbox" mailbox } + { "timeout" { $maybe duration } } } { $description "Block the thread if the mailbox is empty." } ; @@ -40,14 +40,14 @@ HELP: mailbox-get-all { $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ; HELP: while-mailbox-empty -{ $values { "mailbox" mailbox } - { "quot" { $quotation "( -- )" } } +{ $values { "mailbox" mailbox } + { "quot" { $quotation ( -- ) } } } { $description "Repeatedly call the quotation while there are no items in the mailbox." } ; HELP: mailbox-get? -{ $values { "mailbox" mailbox } - { "pred" { $quotation "( obj -- ? )" } } +{ $values { "mailbox" mailbox } + { "pred" { $quotation ( obj -- ? ) } } { "obj" object } } { $description "Get the first item in the mailbox which satisfies the predicate. When the predicate returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ; diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor index 87a4c3cdba..9acce4971a 100644 --- a/basis/concurrency/mailboxes/mailboxes-tests.factor +++ b/basis/concurrency/mailboxes/mailboxes-tests.factor @@ -51,4 +51,4 @@ IN: concurrency.mailboxes.tests [ 1 seconds mailbox-get-timeout -] [ wait-timeout? ] must-fail-with +] [ timed-out-error? ] must-fail-with diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor index 3d7390ae28..9760d842dc 100644 --- a/basis/concurrency/promises/promises-docs.factor +++ b/basis/concurrency/promises/promises-docs.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.messaging kernel arrays -continuations help.markup help.syntax quotations calendar ; +USING: calendar help.markup help.syntax kernel ; IN: concurrency.promises HELP: promise @@ -12,7 +11,7 @@ HELP: { $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ; HELP: promise-fulfilled? -{ $values { "promise" promise } { "?" "a boolean" } } +{ $values { "promise" promise } { "?" boolean } } { $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ; HELP: ?promise-timeout diff --git a/basis/concurrency/semaphores/semaphores-docs.factor b/basis/concurrency/semaphores/semaphores-docs.factor index a922431d48..06c951f586 100644 --- a/basis/concurrency/semaphores/semaphores-docs.factor +++ b/basis/concurrency/semaphores/semaphores-docs.factor @@ -53,9 +53,7 @@ fry http.client kernel urls ; URL" http://www.oracle.com" } 2 '[ - _ [ - http-get nip - ] with-semaphore + _ [ http-get nip ] with-semaphore ] parallel-map""" } ; diff --git a/basis/core-foundation/file-descriptors/file-descriptors.factor b/basis/core-foundation/file-descriptors/file-descriptors.factor index f3f2b577c1..28b8b681f3 100644 --- a/basis/core-foundation/file-descriptors/file-descriptors.factor +++ b/basis/core-foundation/file-descriptors/file-descriptors.factor @@ -1,12 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax kernel math.bitwise core-foundation +USING: alien.c-types alien.syntax core-foundation kernel literals ; IN: core-foundation.file-descriptors TYPEDEF: void* CFFileDescriptorRef TYPEDEF: int CFFileDescriptorNativeDescriptor -TYPEDEF: void* CFFileDescriptorCallBack + +CALLBACK: void CFFileDescriptorCallBack ( + CFFileDescriptorRef f, + CFOptionFlags callBackTypes, + void *info +) ; + C-TYPE: CFFileDescriptorContext FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( @@ -19,16 +25,18 @@ FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( CONSTANT: kCFFileDescriptorReadCallBack 1 CONSTANT: kCFFileDescriptorWriteCallBack 2 - + FUNCTION: void CFFileDescriptorEnableCallBacks ( CFFileDescriptorRef f, CFOptionFlags callBackTypes ) ; : enable-all-callbacks ( fd -- ) - flags{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } - CFFileDescriptorEnableCallBacks ; inline + flags{ + kCFFileDescriptorReadCallBack + kCFFileDescriptorWriteCallBack + } CFFileDescriptorEnableCallBacks ; inline : ( fd callback -- handle ) - [ f swap ] [ t swap ] bi* f CFFileDescriptorCreate + [ f ] 2dip [ t ] dip f CFFileDescriptorCreate [ "CFFileDescriptorCreate failed" throw ] unless* ; diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index cbd2fca5e4..da45e0cde2 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -27,7 +27,7 @@ CONSTANT: kFSEventStreamEventFlagUnmount 128 TYPEDEF: int FSEventStreamCreateFlags TYPEDEF: int FSEventStreamEventFlags -TYPEDEF: longlong FSEventStreamEventId +TYPEDEF: ulonglong FSEventStreamEventId TYPEDEF: void* FSEventStreamRef STRUCT: FSEventStreamContext diff --git a/basis/core-foundation/launch-services/launch-services.factor b/basis/core-foundation/launch-services/launch-services.factor index 88a5dc9843..c021b36693 100644 --- a/basis/core-foundation/launch-services/launch-services.factor +++ b/basis/core-foundation/launch-services/launch-services.factor @@ -21,7 +21,94 @@ FUNCTION: OSStatus FSRefMakePath ( UInt32 maxPathSize ) ; -CONSTANT: kCFAllocatorDefault f +! Abstract base types +CFSTRING: kUTTypeItem "public.item" +CFSTRING: kUTTypeContent "public.content" +CFSTRING: kUTTypeCompositeContent "public.composite-content" +CFSTRING: kUTTypeApplication "com.apple.application" +CFSTRING: kUTTypeMessage "public.message" +CFSTRING: kUTTypeContact "public.contact" +CFSTRING: kUTTypeArchive "public.archive" +CFSTRING: kUTTypeDiskImage "public.disk-image" + +! Concrete base types +CFSTRING: kUTTypeData "public.data" +CFSTRING: kUTTypeDirectory "public.directory" +CFSTRING: kUTTypeResolvable "com.apple.resolvable" +CFSTRING: kUTTypeSymLink "public.symlink" +CFSTRING: kUTTypeMountPoint "com.apple.mount-point" +CFSTRING: kUTTypeAliasFile "com.apple.alias-file" +CFSTRING: kUTTypeAliasRecord "com.apple.alias-record" +CFSTRING: kUTTypeURL "public.url" +CFSTRING: kUTTypeFileURL "public.file-url" + +! Text types +CFSTRING: kUTTypeText "public.text" +CFSTRING: kUTTypePlainText "public.plain-text" +CFSTRING: kUTTypeUTF8PlainText "public.utf8-plain-text" +CFSTRING: kUTTypeUTF16ExternalPlainText "public.utf16-external-plain-text" +CFSTRING: kUTTypeUTF16PlainText "public.utf16-plain-text" +CFSTRING: kUTTypeRTF "public.rtf" +CFSTRING: kUTTypeHTML "public.html" +CFSTRING: kUTTypeXML "public.xml" +CFSTRING: kUTTypeSourceCode "public.source-code" +CFSTRING: kUTTypeCSource "public.c-source" +CFSTRING: kUTTypeObjectiveCSource "public.objective-c-source" +CFSTRING: kUTTypeCPlusPlusSource "public.c-plus-plus-source" +CFSTRING: kUTTypeObjectiveCPlusPlusSource "public.objective-c-plus-plus-source" +CFSTRING: kUTTypeCHeader "public.c-header" +CFSTRING: kUTTypeCPlusPlusHeader "public.c-plus-plus-header" +CFSTRING: kUTTypeJavaSource "com.sun.java-source" + +! Composite content types +CFSTRING: kUTTypePDF "com.adobe.pdf" +CFSTRING: kUTTypeRTFD "com.apple.rtfd" +CFSTRING: kUTTypeFlatRTFD "com.apple.flat-rtfd" +CFSTRING: kUTTypeTXNTextAndMultimediaData "com.apple.txn.text-multimedia-data" +CFSTRING: kUTTypeWebArchive "com.apple.webarchive" + +! Image content types +CFSTRING: kUTTypeImage "public.image" +CFSTRING: kUTTypeJPEG "public.jpeg" +CFSTRING: kUTTypeJPEG2000 "public.jpeg-2000" +CFSTRING: kUTTypeTIFF "public.tiff" +CFSTRING: kUTTypePICT "com.apple.pict" +CFSTRING: kUTTypeGIF "com.compuserve.gif" +CFSTRING: kUTTypePNG "public.png" +CFSTRING: kUTTypeQuickTimeImage "com.apple.quicktime-image" +CFSTRING: kUTTypeAppleICNS "com.apple.icns" +CFSTRING: kUTTypeBMP "com.microsoft.bmp" +CFSTRING: kUTTypeICO "com.microsoft.ico" + +! Audiovisual content types +CFSTRING: kUTTypeAudiovisualContent "public.audiovisual-content" +CFSTRING: kUTTypeMovie "public.movie" +CFSTRING: kUTTypeVideo "public.video" +CFSTRING: kUTTypeAudio "public.audio" +CFSTRING: kUTTypeQuickTimeMovie "com.apple.quicktime-movie" +CFSTRING: kUTTypeMPEG "public.mpeg" +CFSTRING: kUTTypeMPEG4 "public.mpeg-4" +CFSTRING: kUTTypeMP3 "public.mp3" +CFSTRING: kUTTypeMPEG4Audio "public.mpeg-4-audio" +CFSTRING: kUTTypeAppleProtectedMPEG4Audio "com.apple.protected-mpeg-4-audio" + +! Directory types +CFSTRING: kUTTypeFolder "public.folder" +CFSTRING: kUTTypeVolume "public.volume" +CFSTRING: kUTTypePackage "com.apple.package" +CFSTRING: kUTTypeBundle "com.apple.bundle" +CFSTRING: kUTTypeFramework "com.apple.framework" + +! Application types +CFSTRING: kUTTypeApplicationBundle "com.apple.application-bundle" +CFSTRING: kUTTypeApplicationFile "com.apple.application-file" + +! Contact types +CFSTRING: kUTTypeVCard "public.vcard" + +! Misc. types +CFSTRING: kUTTypeInkText "com.apple.ink.inktext" + CONSTANT: kLSUnknownCreator f ERROR: core-foundation-error n ; @@ -46,4 +133,3 @@ ERROR: core-foundation-error n ; : launch-services-path ( string -- path/f ) [ (launch-services-path) ] [ 2drop f ] recover ; - diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 2e09c52215..724812d3c2 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -60,14 +60,16 @@ CFSTRING: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" TUPLE: run-loop-state fds sources timers ; +SYMBOL: run-loop + : ( -- run-loop ) V{ } clone V{ } clone V{ } clone \ run-loop-state boa ; -: run-loop ( -- run-loop ) - \ run-loop-state [ ] initialize-alien ; +: get-run-loop ( -- run-loop ) + \ run-loop [ ] initialize-alien ; : add-source-to-run-loop ( source -- ) - [ run-loop sources>> push ] + [ get-run-loop sources>> push ] [ CFRunLoopGetMain swap CFRunLoopDefaultMode @@ -81,7 +83,7 @@ TUPLE: run-loop-state fds sources timers ; [ |CFRelease [ enable-all-callbacks ] - [ run-loop fds>> push ] + [ get-run-loop fds>> push ] [ create-fd-source |CFRelease add-source-to-run-loop ] tri ] with-destructors ; @@ -100,7 +102,7 @@ PRIVATE> : add-timer-to-run-loop ( timer -- ) [ reset-timer ] - [ run-loop timers>> push ] + [ get-run-loop timers>> push ] [ CFRunLoopGetMain swap CFRunLoopDefaultMode @@ -108,19 +110,18 @@ PRIVATE> ] tri ; : invalidate-run-loop-timers ( -- ) - run-loop [ + get-run-loop [ [ [ CFRunLoopTimerInvalidate ] [ CFRelease ] bi ] each V{ } clone ] change-timers drop ; : reset-run-loop ( -- ) - run-loop + get-run-loop [ timers>> [ reset-timer ] each ] [ fds>> [ enable-all-callbacks ] each ] bi ; : timer-callback ( -- callback ) - void { CFRunLoopTimerRef void* } cdecl - [ drop reset-timer yield ] alien-callback ; + [ drop reset-timer yield ] CFRunLoopTimerCallBack ; : init-thread-timer ( -- ) 60 timer-callback add-timer-to-run-loop ; diff --git a/basis/core-foundation/time/time.factor b/basis/core-foundation/time/time.factor index 37c4ff5d0e..9d22e4752d 100644 --- a/basis/core-foundation/time/time.factor +++ b/basis/core-foundation/time/time.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: calendar math alien.c-types alien.syntax memoize system ; +USING: alien.c-types alien.syntax calendar literals math ; IN: core-foundation.time TYPEDEF: double CFTimeInterval @@ -8,8 +8,10 @@ TYPEDEF: double CFAbsoluteTime ALIAS: >CFTimeInterval duration>seconds -MEMO: epoch ( -- micros ) - T{ timestamp { year 2001 } { month 1 } { day 1 } } timestamp>micros ; +CONSTANT: epoch $[ + T{ timestamp { year 2001 } { month 1 } { day 1 } } + timestamp>micros +] : >CFAbsoluteTime ( micros -- time ) epoch - 1,000,000 /f ; inline diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index adf4e8a1c6..595b68df88 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/basis/core-foundation/timers/timers.factor @@ -5,7 +5,12 @@ core-foundation.time calendar.unix kernel locals math system ; IN: core-foundation.timers TYPEDEF: void* CFRunLoopTimerRef -TYPEDEF: void* CFRunLoopTimerCallBack + +CALLBACK: void CFRunLoopTimerCallBack ( + CFRunLoopTimerRef timer, + void *info +) ; + TYPEDEF: void* CFRunLoopTimerContext FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate ( diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 3e4a17c020..cf04630748 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -1,9 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.data alien.destructors -alien.syntax accessors destructors fry kernel math math.bitwise -sequences libc colors images images.memory core-graphics.types -core-foundation.utilities opengl.gl literals ; + +USING: accessors alien alien.c-types alien.data +alien.destructors alien.syntax colors +core-foundation.dictionaries core-foundation.strings +core-foundation.urls core-foundation.utilities +core-graphics.types destructors fry images images.memory kernel +libc math opengl.gl sequences ; + IN: core-graphics TYPEDEF: int CGImageAlphaInfo @@ -59,6 +63,10 @@ FUNCTION: CGContextRef CGBitmapContextCreate ( CGBitmapInfo bitmapInfo ) ; +FUNCTION: CGImageRef CGBitmapContextCreateImage + CGContextRef c +) ; + FUNCTION: void CGColorSpaceRelease ( CGColorSpaceRef ref ) ; DESTRUCTOR: CGColorSpaceRelease @@ -74,7 +82,7 @@ FUNCTION: void CGContextSetRGBStrokeColor ( CGFloat blue, CGFloat alpha ) ; - + FUNCTION: void CGContextSetRGBFillColor ( CGContextRef c, CGFloat red, @@ -113,6 +121,23 @@ FUNCTION: size_t CGImageGetHeight ( CGImageRef image ) ; +FUNCTION: CGImageDestinationRef CGImageDestinationCreateWithURL ( + CFURLRef url, + CFStringRef type, + size_t count, + CFDictionaryRef options +) ; + +FUNCTION: void CGImageDestinationAddImage ( + CGImageDestinationRef idst, + CGImageRef image, + CFDictionaryRef properties +) ; + +FUNCTION: bool CGImageDestinationFinalize ( + CGImageDestinationRef idst +) ; + FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ; CONSTANT: kCGLRendererGenericFloatID 0x00020400 diff --git a/basis/core-graphics/types/types.factor b/basis/core-graphics/types/types.factor index d6df20de90..13dc128f4b 100644 --- a/basis/core-graphics/types/types.factor +++ b/basis/core-graphics/types/types.factor @@ -77,6 +77,7 @@ TYPEDEF: void* CGColorRef TYPEDEF: void* CGColorSpaceRef TYPEDEF: void* CGContextRef TYPEDEF: void* CGImageRef +TYPEDEF: void* CGImageDestinationRef TYPEDEF: uint CGBitmapInfo diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor index 43a527de0b..0ebc40f523 100644 --- a/basis/core-text/fonts/fonts.factor +++ b/basis/core-text/fonts/fonts.factor @@ -78,7 +78,7 @@ FUNCTION: CGFloat CTFontGetXHeight ( CTFontRef font ) ; CONSTANT: font-names H{ { "monospace" "Monaco" } - { "sans-serif" "Lucida Grande" } + { "sans-serif" "LucidaGrande" } { "serif" "Times" } } diff --git a/basis/cpu/architecture/architecture-docs.factor b/basis/cpu/architecture/architecture-docs.factor new file mode 100644 index 0000000000..34df497020 --- /dev/null +++ b/basis/cpu/architecture/architecture-docs.factor @@ -0,0 +1,168 @@ +USING: assocs alien compiler.cfg.instructions cpu.x86.assembler +cpu.x86.assembler.operands help.markup help.syntax kernel +layouts literals math multiline system words ; +IN: cpu.architecture + +<< +STRING: ex-%box-alien +USING: compiler.codegen compiler.codegen.relocation cpu.architecture make ; +init-fixup init-relocation [ RAX RBX RCX %box-alien ] B{ } make disassemble +000000e9fcc720a0: 48b80100000000000000 mov rax, 0x1 +000000e9fcc720aa: 4885db test rbx, rbx +000000e9fcc720ad: 0f8400000000 jz dword 0xe9fcc720b3 +000000e9fcc720b3: 498d4d10 lea rcx, [r13+0x10] +000000e9fcc720b7: 488b01 mov rax, [rcx] +000000e9fcc720ba: 48c70018000000 mov qword [rax], 0x18 +000000e9fcc720c1: 4883c806 or rax, 0x6 +000000e9fcc720c5: 48830130 add qword [rcx], 0x30 +000000e9fcc720c9: 48c7400201000000 mov qword [rax+0x2], 0x1 +000000e9fcc720d1: 48c7400a01000000 mov qword [rax+0xa], 0x1 +000000e9fcc720d9: 48895812 mov [rax+0x12], rbx +000000e9fcc720dd: 4889581a mov [rax+0x1a], rbx +; + +STRING: ex-%allot +USING: cpu.architecture make ; +[ RAX 40 tuple RCX %allot ] B{ } make disassemble +0000000002270cc0: 498d4d10 lea rcx, [r13+0x10] +0000000002270cc4: 488b01 mov rax, [rcx] +0000000002270cc7: 48c7001c000000 mov qword [rax], 0x1c +0000000002270cce: 4883c807 or rax, 0x7 +0000000002270cd2: 48830130 add qword [rcx], 0x30 +; + +STRING: ex-%context +USING: cpu.architecture make ; +[ EAX %context ] B{ } make disassemble +00000000010f5ed0: 418b4500 mov eax, [r13] +; + +STRING: ex-%safepoint +USING: cpu.architecture make ; +init-relocation [ %safepoint ] B{ } make disassemble +00000000010b05a0: 890500000000 mov [rip], eax +; + +STRING: ex-%save-context +USING: cpu.architecture make ; +[ RAX RBX %save-context ] B{ } make disassemble +0000000000e63ab0: 498b4500 mov rax, [r13] +0000000000e63ab4: 488d5c24f8 lea rbx, [rsp-0x8] +0000000000e63ab9: 488918 mov [rax], rbx +0000000000e63abc: 4c897010 mov [rax+0x10], r14 +0000000000e63ac0: 4c897818 mov [rax+0x18], r15 +; +>> + +HELP: signed-rep +{ $values { "rep" representation } { "rep'" representation } } +{ $description "Maps any representation to its signed counterpart, if it has one." } ; + +HELP: immediate-arithmetic? +{ $values { "n" number } { "?" boolean } } +{ $description + "Can this value be an immediate operand for " { $link %add-imm } ", " + { $link %sub-imm } ", or " { $link %mul-imm } "?" +} ; + +HELP: machine-registers +{ $values { "assoc" assoc } } +{ $description "Mapping from register class to machine registers. Only registers not reserved by the Factor VM are included." } ; + +HELP: vm-stack-space +{ $values { "n" number } } +{ $description "Parameter space to reserve in anything making VM calls." } ; + +HELP: complex-addressing? +{ $values { "?" boolean } } +{ $description "Specifies if " { $link %slot } ", " { $link %set-slot } " and " { $link %write-barrier } " accept the 'scale' and 'tag' parameters, and if %load-memory and %store-memory work." } ; + +HELP: param-regs +{ $values { "abi" "a calling convention symbol" } { "regs" assoc } } +{ $description "Retrieves the order in which machine registers are used for parameters for the given calling convention." } ; + +HELP: %load-immediate +{ $values { "reg" "a register symbol" } { "val" "a value" } } +{ $description "Emits code for loading an immediate value into a register. On " { $link x86 } ", if val is 0, then an " { $link XOR } " instruction is emitted instead of " { $link MOV } "." } ; + +HELP: %call +{ $values { "word" word } } +{ $description "Emits code for calling a word in Factor." } ; + +HELP: %box-alien +{ $values { "dst" "destination register" } { "src" "source register" } { "temp" "temporary register" } } +{ $description "Emits machine code for boxing an alien value. If the alien is not a NULL pointer, then five " { $link cells } " will be allocated in the nursery space to wrap the object. See vm/layouts.hpp for details." } +{ $examples { $unchecked-example $[ ex-%box-alien ] } } +{ $see-also ##box-alien %allot } ; + +HELP: %context +{ $values { "dst" "a register symbol" } } +{ $description "Emits machine code for putting a pointer to the context field of the " { $link vm } " in a register." } +{ $examples { $unchecked-example $[ ex-%context ] } } ; + +HELP: %safepoint +{ $description "Emits a safe point to the current code sequence being generated." } +{ $examples { $unchecked-example $[ ex-%safepoint ] } } ; + +HELP: %save-context +{ $values { "temp1" "a register symbol" } { "temp2" "a register symbol" } } +{ $description "Emits machine code for saving pointers to the callstack, datastack and retainstack in the current context field struct." } +{ $examples { $unchecked-example $[ ex-%save-context ] } } ; + + +HELP: %allot +{ $values + { "dst" "destination register symbol" } + { "size" "number of bytes to allocate" } + { "class" "one of the built-in classes listed in " { $link type-numbers } } + { "temp" "temporary register symbol" } +} +{ $description "Emits machine code for allocating memory." } +{ $examples + "In this example 40 bytes is allocated and a tagged pointer to the memory is put in " { $link RAX } ":" + { $unchecked-example $[ ex-%allot ] } +} ; + +HELP: test-instruction? +{ $values { "?" "a boolean" } } +{ $description "Does the current architecture have a test instruction? Used on x86 to rewrite some " { $link CMP } " instructions to less expensive " { $link TEST } "s." } ; + +HELP: fused-unboxing? +{ $values { "?" boolean } } +{ $description "Whether this architecture support " { $link %load-float } ", " { $link %load-double } ", and " { $link %load-vector } "." } ; + +HELP: return-regs +{ $values { "regs" assoc } } +{ $description "What registers that will be used for function return values of which class." } ; + +HELP: stack-cleanup +{ $values + { "stack-size" integer } + { "return" "a c type" } + { "abi" abi } + { "n" integer } +} +{ $description "Calculates how many bytes of stack space the caller of the procedure being constructed need to cleanup. For modern abi's the value is almost always 0." } +{ $examples + { $unchecked-example + "USING: cpu.architecture prettyprint ;" + "20 void stdcall stack-cleanup ." + "20" + } +} ; + +ARTICLE: "cpu.architecture" "CPU architecture description model" +"The " { $vocab-link "cpu.architecture" } " vocab contains generic words and hooks that serves as an api for the compiler towards the cpu architecture." +$nl +"Register categories:" +{ $subsections machine-registers param-regs return-regs } +"Architecture support checks:" +{ $subsections + complex-addressing? + float-on-stack? + float-right-align-on-stack? + fused-unboxing? + test-instruction? +} +"Control flow code emitters:" +{ $subsections %call %jump %jump-label %return } ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 272e08ab80..af55954540 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -209,20 +209,15 @@ M: uint-4-rep scalar-rep-of drop uint-scalar-rep ; M: longlong-2-rep scalar-rep-of drop longlong-scalar-rep ; M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ; -! Mapping from register class to machine registers HOOK: machine-registers cpu ( -- assoc ) ! Callbacks are not allowed to clobber this HOOK: frame-reg cpu ( -- reg ) -! Parameter space to reserve in anything making VM calls HOOK: vm-stack-space cpu ( -- n ) M: object vm-stack-space 0 ; -! Specifies if %slot, %set-slot and %write-barrier accept the -! 'scale' and 'tag' parameters, and if %load-memory and -! %store-memory work HOOK: complex-addressing? cpu ( -- ? ) HOOK: gc-root-offset cpu ( spill-slot -- n ) @@ -524,12 +519,8 @@ HOOK: %reload cpu ( dst rep src -- ) HOOK: %loop-entry cpu ( -- ) -! Does this architecture support %load-float, %load-double, -! and %load-vector? HOOK: fused-unboxing? cpu ( -- ? ) -! Can this value be an immediate operand for %add-imm, %sub-imm, -! or %mul-imm? HOOK: immediate-arithmetic? cpu ( n -- ? ) ! Can this value be an immediate operand for %and-imm, %or-imm, @@ -555,7 +546,6 @@ M: object immediate-comparand? ( n -- ? ) ! FFI stuff -! Return values of this class go here HOOK: return-regs cpu ( -- regs ) ! Registers used for parameter passing diff --git a/basis/cpu/x86/64/64-docs.factor b/basis/cpu/x86/64/64-docs.factor new file mode 100644 index 0000000000..cd58ecfb69 --- /dev/null +++ b/basis/cpu/x86/64/64-docs.factor @@ -0,0 +1,13 @@ +USING: help.markup help.syntax math vm ; +IN: cpu.x86.64 + +HELP: vm-reg +{ $values { "reg" "a register symbol" } } +{ $description + "Symbol of the machine register that holds the address of the virtual machine." +} +{ $see-also vm } ; + +HELP: param-reg +{ $values { "n" number } { "reg" "a register symbol" } } +{ $description "Symbol of the machine register for the nth function parameter (0-based)." } ; diff --git a/basis/cpu/x86/assembler/assembler-docs.factor b/basis/cpu/x86/assembler/assembler-docs.factor new file mode 100644 index 0000000000..e922e8e4f4 --- /dev/null +++ b/basis/cpu/x86/assembler/assembler-docs.factor @@ -0,0 +1,13 @@ +USING: compiler.codegen.labels cpu.x86.assembler help.markup help.syntax ; +IN: cpu.x86.assembler + +HELP: JE +{ $values { "dst" "destination address or " { $link label } } } +{ $description "Emits a conditional jump instruction to the given address relative to the current code offset." } +{ $examples + { $unchecked-example + "USING: cpu.x86.assembler make ;" + "[ 0x0 JE ] B{ } make disassemble" + "000000e9fcc71fe0: 0f8400000000 jz dword 0xe9fcc71fe6" + } +} ; diff --git a/basis/cpu/x86/assembler/operands/operands-docs.factor b/basis/cpu/x86/assembler/operands/operands-docs.factor new file mode 100644 index 0000000000..18906a3fe4 --- /dev/null +++ b/basis/cpu/x86/assembler/operands/operands-docs.factor @@ -0,0 +1,42 @@ +USING: cpu.x86.assembler.operands.private help.markup help.syntax math ; +IN: cpu.x86.assembler.operands + +HELP: indirect +{ $class-description "Tuple that represents an indirect addressing operand. It has the following slots:" + { $table + { { $slot "index" } { "Register for the index value. It must not be " { $link ESP } " or " { $link RSP } "." } } + { { $slot "displacement" } { "An integer offset." } } + } +} ; + +HELP: [RIP+] +{ $values { "displacement" number } { "indirect" indirect } } +{ $description "Creates an indirect operand relative to the RIP register." } +{ $examples + { $unchecked-example + "USING: cpu.x86.assembler cpu.x86.assembler.operands make tools.disassembler ;" + "[ 0x1234 [RIP+] EAX MOV ] B{ } make disassemble" + "00000000015cef50: 890534120000 mov [rip+0x1234], eax" + } +} ; + +HELP: [] +{ $values { "base/displacement" "register or an integer" } { "indirect" indirect } } +{ $description "Creates an indirect operand from a given address or " { $link register } "." } ; + +HELP: n-bit-version-of +{ $values { "register" register } { "n" integer } { "register'" register } } +{ $description "Returns a less wide version of the given register." } ; + +ARTICLE: "cpu.x86.assembler.operands" "CPU x86 registers and memory operands" +"Indirect operand constructors for various addressing formats:" +{ $subsections [] [RIP+] [+] [++] [+*2+] [+*4+] [+*8+] } +"Register correspondances:" +{ $subsections + 8-bit-version-of + 16-bit-version-of + 32-bit-version-of + 64-bit-version-of + n-bit-version-of + native-version-of +} ; diff --git a/basis/cpu/x86/assembler/operands/operands-tests.factor b/basis/cpu/x86/assembler/operands/operands-tests.factor new file mode 100644 index 0000000000..4325011c58 --- /dev/null +++ b/basis/cpu/x86/assembler/operands/operands-tests.factor @@ -0,0 +1,14 @@ +USING: cpu.x86.assembler cpu.x86.assembler.operands +cpu.x86.assembler.operands.private make tools.test ; +IN: cpu.x86.assembler.operands.tests + +[ RCX RSP 2 0 ] [ bad-index? ] must-fail-with + +{ B{ 72 137 12 153 } } [ + [ RCX RBX 2 0 RCX MOV ] B{ } make +] unit-test + +! No specific encoding for RBP and R13 +{ B{ 73 137 76 157 0 } } [ + [ R13 RBX 2 f RCX MOV ] B{ } make +] unit-test diff --git a/basis/cpu/x86/x86-docs.factor b/basis/cpu/x86/x86-docs.factor new file mode 100644 index 0000000000..9e904eac7a --- /dev/null +++ b/basis/cpu/x86/x86-docs.factor @@ -0,0 +1,88 @@ +USING: help.markup help.syntax math ; +IN: cpu.x86 + +HELP: stack-reg +{ $values { "reg" "a register symbol" } } +{ $description + "Symbol of the machine register that holds the (cpu) stack address." +} ; + +HELP: reserved-stack-space +{ $values { "n" integer } } +{ $description "Size in bytes of the register parameter area. It only exists on the windows x86.64 architecture, where it is 32 bytes and allocated by the caller. On all other platforms it is 0." } ; + +HELP: ds-reg +{ $values { "reg" "a register symbol" } } +{ $description + "Symbol of the machine register that holds the address to the data stack's location." +} ; + +HELP: (%inc) +{ $values { "n" number } { "reg" "a register symbol" } } +{ $description + "Emits machine code for increasing or decreasing the given register a number of cell sizes bytes." +} +{ $examples + { $unchecked-example + "USING: cpu.x86 make prettyprint ;" + "[ 8 ECX (%inc) ] B{ } make disassemble" + "00000000615e5140: 83c140 add ecx, 0x40" + } +} ; + +HELP: decr-stack-reg +{ $values { "n" number } } +{ $description "Emits an instruction for decrementing the stack register the given number of bytes." } ; + +HELP: load-zone-offset +{ $values { "nursery-ptr" "a register symbol" } } +{ $description + "Emits machine code for loading the address to the nursery into the machine register." +} +{ $examples + { $unchecked-example + "USING: cpu.x86 make ;" + "[ RCX load-zone-offset ] B{ } make disassemble" + "0000000001b48f80: 498d4d10 lea rcx, [r13+0x10]" + } +} ; + +HELP: store-tagged +{ $values { "dst" "a register symbol" } { "tag" "a builtin class" } } +{ $description "Tags the register with the tag number for the given class." } +{ $examples + { $unchecked-example + "USING: cpu.x86 make ;" + "[ RAX alien store-tagged ] B{ } make disassemble" + "0000000002275f10: 4883c806 or rax, 0x6" + } +} ; + +HELP: copy-register* +{ $values + { "dst" "a register symbol" } + { "src" "a register symbol" } + { "rep" "a value representation singleton" } +} +{ $description + "Emits machine code for copying from a register to another." +} +{ $examples + { $unchecked-example + "USING: cpu.x86 make ;" + "[ XMM1 XMM2 double-rep copy-register* ] B{ } make disassemble" + "0000000533c61fe0: 0f28ca movaps xmm1, xmm2" + } +} ; + +HELP: %mov-vm-ptr +{ $values { "reg" "a register symbol" } } +{ $description + "Emits machine code for moving the vm pointer to a register." } +{ $examples + { $unchecked-example + "USING: cpu.x86.64 make ;" + "[ RAX %mov-vm-ptr ] B{ } make disassemble" + "0000000002290b30: 4c89e8 mov rax, r13" + } +} ; diff --git a/basis/csv/csv-docs.factor b/basis/csv/csv-docs.factor index 96a0575926..1738c2bb59 100644 --- a/basis/csv/csv-docs.factor +++ b/basis/csv/csv-docs.factor @@ -1,5 +1,4 @@ -USING: help.syntax help.markup kernel prettyprint sequences -io.pathnames strings ; +USING: help.markup help.syntax io.pathnames quotations strings ; IN: csv HELP: read-row @@ -48,7 +47,7 @@ HELP: write-csv HELP: with-delimiter { $values { "ch" "field delimiter (e.g. CHAR: \\t)" } - { "quot" "a quotation" } } + { "quot" quotation } } { $description "Sets the field delimiter for read-csv, read-row, write-csv, or write-row words." } ; ARTICLE: "csv" "Comma-separated-values parsing and writing" diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 3c12b14f84..5beefe283c 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -4,11 +4,11 @@ io.directories ; IN: csv.tests ! I like to name my unit tests -: named-unit-test ( name output input -- ) - unit-test drop ; inline +: named-unit-test ( name output input -- ) + unit-test drop ; inline "Fields are separated by commas" -[ { { "1997" "Ford" "E350" } } ] +[ { { "1997" "Ford" "E350" } } ] [ "1997,Ford,E350" string>csv ] named-unit-test "ignores whitespace before and after elements. n.b.specifically prohibited by RFC 4180, which states, 'Spaces are considered part of a field and should not be ignored.'" @@ -21,29 +21,29 @@ IN: csv.tests "double quotes mean escaped in quotes" [ { { "1997" "Ford" "E350" "Super \"luxurious\" truck" } } ] -[ "1997,Ford,E350,\"Super \"\"luxurious\"\" truck\"" - string>csv ] named-unit-test +[ "1997,Ford,E350,\"Super \"\"luxurious\"\" truck\"" + string>csv ] named-unit-test "Fields with embedded line breaks must be delimited by double-quote characters." [ { { "1997" "Ford" "E350" "Go get one now\nthey are going fast" } } ] [ "1997,Ford,E350,\"Go get one now\nthey are going fast\"" - string>csv ] named-unit-test + string>csv ] named-unit-test "Fields with leading or trailing spaces must be delimited by double-quote characters. (See comment about leading and trailing spaces above)" [ { { "1997" "Ford" "E350" " Super luxurious truck " } } ] [ "1997,Ford,E350,\" Super luxurious truck \"" - string>csv ] named-unit-test + string>csv ] named-unit-test "Fields may always be delimited by double-quote characters, whether necessary or not." [ { { "1997" "Ford" "E350" } } ] [ "\"1997\",\"Ford\",\"E350\"" string>csv ] named-unit-test "The first record in a csv file may contain column names in each of the fields." -[ { { "Year" "Make" "Model" } +[ { { "Year" "Make" "Model" } { "1997" "Ford" "E350" } { "2000" "Mercury" "Cougar" } } ] -[ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar" - string>csv ] named-unit-test +[ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar" + string>csv ] named-unit-test ! !!!!!!!! other tests @@ -100,3 +100,12 @@ IN: csv.tests ! FIXME: { { { "as,df" "asdf" } } } [ "\"as,\"df ,asdf" string>csv ] unit-test ! FIXME: { { { "asd\"f\"" "asdf" } } } [ "\"asd\"\"\"f\",asdf" string>csv ] unit-test { { { "as,d\"f" "asdf" } } } [ "\"as,\"d\"\"\"\"f,asdf" string>csv ] unit-test + +[ { } ] [ "" string>csv ] unit-test + +[ + { { "Year" "Make" "Model" } + { "1997" "Ford" "E350" } + } +] +[ "Year,Make,\"Model\"\r\n1997,Ford,E350" string>csv ] unit-test diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor index 27f39190ec..008c0b2e38 100644 --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -12,7 +12,7 @@ CHAR: , delimiter set-global : stream-read-csv ( stream -- rows ) [ (stream-read-csv) ] { } make - dup last { "" } = [ but-last ] when ; inline + dup ?last { "" } = [ but-last ] when ; inline : read-csv ( -- rows ) input-stream get stream-read-csv ; inline @@ -85,7 +86,7 @@ PRIVATE> > swap sql>> PQexec dup postgresql-result-ok? [ @@ -147,7 +148,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) &postgresql-free ] if ] with-out-parameters memory>byte-array - ] with-destructors + ] with-destructors ] [ drop pq-get-is-null nip [ f ] [ B{ } clone ] if ] if ; diff --git a/basis/db/postgresql/postgresql-tests.factor b/basis/db/postgresql/postgresql-tests.factor index eb1370fc74..66e1bd8b64 100644 --- a/basis/db/postgresql/postgresql-tests.factor +++ b/basis/db/postgresql/postgresql-tests.factor @@ -1,89 +1,110 @@ -USING: kernel db.postgresql alien continuations io classes -prettyprint sequences namespaces tools.test db db.private -db.tuples db.types unicode.case accessors system db.tester ; +USING: accessors alien continuations db db.errors db.queries db.postgresql +db.private db.tester db.tuples db.types io classes kernel math namespaces +prettyprint sequences system tools.test unicode.case ; IN: db.postgresql.tests +: nonexistant-db ( -- db ) + + "localhost" >>host + "fake-user" >>username + "no-pass" >>password + "dont-exist" >>database ; -os windows? cpu x86.64? and [ - ! Ensure the table exists - [ ] [ postgresql-test-db [ ] with-db ] unit-test +! Don't leak connections +[ ] [ + 2000 [ [ nonexistant-db [ ] with-db ] ignore-errors ] times +] unit-test - [ ] [ - postgresql-test-db [ - [ "drop table person;" sql-command ] ignore-errors - "create table person (name varchar(30), country varchar(30));" - sql-command +! Ensure the test database exists +postgresql-template1-db [ + postgresql-test-db-name ensure-database +] with-db - "insert into person values('John', 'America');" sql-command - "insert into person values('Jane', 'New Zealand');" sql-command - ] with-db - ] unit-test +! Triggers a two line error message (ERROR + DETAIL) because two +! connections can't simultaneously use the template1 database. +! [ + ! postgresql-template1-db [ + ! postgresql-template1-db [ + ! "will_never_exist" ensure-database + ! ] with-db + ! ] with-db +! ] [ sql-unknown-error? ] must-fail-with - [ - { - { "John" "America" } - { "Jane" "New Zealand" } - } - ] [ - postgresql-test-db [ - "select * from person" sql-query - ] with-db - ] unit-test - - [ - { - { "John" "America" } - { "Jane" "New Zealand" } - } - ] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test - - [ - ] [ - postgresql-test-db [ - "insert into person(name, country) values('Jimmy', 'Canada')" +[ ] [ + postgresql-test-db [ + [ "drop table person;" sql-command ] ignore-errors + "create table person (name varchar(30), country varchar(30));" sql-command - ] with-db - ] unit-test - [ - { - { "John" "America" } - { "Jane" "New Zealand" } - { "Jimmy" "Canada" } - } - ] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test + "insert into person values('John', 'America');" sql-command + "insert into person values('Jane', 'New Zealand');" sql-command + ] with-db +] unit-test - [ - postgresql-test-db [ - [ - "insert into person(name, country) values('Jose', 'Mexico')" sql-command - "insert into person(name, country) values('Jose', 'Mexico')" sql-command - "oops" throw - ] with-transaction - ] with-db - ] must-fail +[ + { + { "John" "America" } + { "Jane" "New Zealand" } + } +] [ + postgresql-test-db [ + "select * from person" sql-query + ] with-db +] unit-test - [ 3 ] [ - postgresql-test-db [ - "select * from person" sql-query length - ] with-db - ] unit-test +[ + { + { "John" "America" } + { "Jane" "New Zealand" } + } +] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test - [ - ] [ - postgresql-test-db [ - [ - "insert into person(name, country) values('Jose', 'Mexico')" - sql-command - "insert into person(name, country) values('Jose', 'Mexico')" - sql-command - ] with-transaction - ] with-db - ] unit-test +[ +] [ + postgresql-test-db [ + "insert into person(name, country) values('Jimmy', 'Canada')" + sql-command + ] with-db +] unit-test - [ 5 ] [ - postgresql-test-db [ - "select * from person" sql-query length - ] with-db - ] unit-test -] unless +[ + { + { "John" "America" } + { "Jane" "New Zealand" } + { "Jimmy" "Canada" } + } +] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test + +[ + postgresql-test-db [ + [ + "insert into person(name, country) values('Jose', 'Mexico')" sql-command + "insert into person(name, country) values('Jose', 'Mexico')" sql-command + "oops" throw + ] with-transaction + ] with-db +] must-fail + +[ 3 ] [ + postgresql-test-db [ + "select * from person" sql-query length + ] with-db +] unit-test + +[ +] [ + postgresql-test-db [ + [ + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command + ] with-transaction + ] with-db +] unit-test + +[ 5 ] [ + postgresql-test-db [ + "select * from person" sql-query length + ] with-db +] unit-test diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index a002175ea8..12acded9c0 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -284,10 +284,10 @@ M: postgresql-db-connection compound ( string object -- string' ) M: postgresql-db-connection parse-db-error "\n" split dup length { { 1 [ first parse-postgresql-sql-error ] } + { 2 [ concat parse-postgresql-sql-error ] } { 3 [ first3 [ parse-postgresql-sql-error ] 2dip postgresql-location >>location ] } } case ; - diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index 7fcb4babf5..6afe4da607 100644 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -2,41 +2,38 @@ ! See http://factorcode.org/license.txt for BSD license. ! An interface to the sqlite database. Tested against sqlite v3.1.3. ! Not all functions have been wrapped. -USING: alien compiler kernel math namespaces sequences strings alien.syntax -system combinators alien.c-types alien.libraries ; +USING: alien alien.libraries alien.libraries.finder compiler kernel +math namespaces sequences strings alien.syntax system combinators +alien.c-types ; IN: db.sqlite.ffi -<< "sqlite" { - { [ os windows? ] [ "sqlite3.dll" ] } - { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } - { [ os unix? ] [ "libsqlite3.so" ] } - } cond cdecl add-library >> +<< "sqlite" "sqlite3" find-library cdecl add-library >> ! Return values from sqlite functions CONSTANT: SQLITE_OK 0 ! Successful result CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database -CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite -CONSTANT: SQLITE_PERM 3 ! Access permission denied -CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort -CONSTANT: SQLITE_BUSY 5 ! The database file is locked -CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked -CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed -CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database -CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt() -CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred -CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed -CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found -CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full -CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file -CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error -CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty -CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed -CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table -CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation -CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch -CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly -CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host -CONSTANT: SQLITE_AUTH 23 ! Authorization denied +CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite +CONSTANT: SQLITE_PERM 3 ! Access permission denied +CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort +CONSTANT: SQLITE_BUSY 5 ! The database file is locked +CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked +CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed +CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database +CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt() +CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred +CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed +CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found +CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full +CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file +CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error +CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty +CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed +CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table +CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation +CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch +CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly +CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host +CONSTANT: SQLITE_AUTH 23 ! Authorization denied CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor index 4471ae4979..b8b00e52c6 100644 --- a/basis/db/tester/tester.factor +++ b/basis/db/tester/tester.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: concurrency.combinators db.pools db.sqlite db.tuples -db.types kernel math random threads tools.test db sequences -io prettyprint db.postgresql accessors io.files.temp +USING: concurrency.combinators db db.pools db.sqlite db.tuples +db.types destructors kernel math random threads tools.test sequences +io io.pools prettyprint db.postgresql accessors io.files.temp namespaces fry system math.parser db.queries assocs ; IN: db.tester @@ -11,24 +11,16 @@ IN: db.tester H{ { CHAR: - CHAR: _ } { CHAR: . CHAR: _ } } substitute ; : postgresql-test-db ( -- postgresql-db ) - - "localhost" >>host - "postgres" >>username - "thepasswordistrust" >>password - postgresql-test-db-name >>database ; + \ postgresql-db get-global clone postgresql-test-db-name >>database ; : postgresql-template1-db ( -- postgresql-db ) - - "localhost" >>host - "postgres" >>username - "thepasswordistrust" >>password - "template1" >>database ; + \ postgresql-db get-global clone "template1" >>database ; : sqlite-test-db ( -- sqlite-db ) cpu name>> "tuples-test." ".db" surround temp-file ; -! These words leak resources, but are useful for interactivel testing +! These words leak resources, but are useful for interactive testing : set-sqlite-db ( -- ) sqlite-db db-open db-connection set ; @@ -100,10 +92,12 @@ test-2 "TEST2" { ] with-db ] [ [ - 10 iota [ - 10 [ - test-1-tuple insert-tuple yield - ] times - ] parallel-each - ] with-pooled-db + [ + 10 iota [ + 10 [ + test-1-tuple insert-tuple yield + ] times + ] parallel-each + ] with-pooled-db + ] with-disposal ] bi ; diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index fcb7df53cc..0bdb2978ee 100644 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -35,9 +35,9 @@ GENERIC: eval-generator ( singleton -- object ) : query-tuples ( exemplar-tuple statement -- seq ) [ out-params>> ] keep query-results [ - [ sql-row-typed swap resulting-tuple ] with with query-map + [ sql-row-typed swap resulting-tuple ] 2with query-map ] with-disposal ; - + : query-modify-tuple ( tuple statement -- ) [ query-results [ sql-row-typed ] with-disposal ] keep out-params>> rot [ diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index 2ac358982e..60b032a02d 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes hashtables help.markup help.syntax io.streams.string -kernel sequences strings math ; +USING: help.markup help.syntax kernel strings ; IN: db.types HELP: +db-assigned-id+ @@ -90,7 +89,7 @@ HELP: VARCHAR HELP: user-assigned-id-spec? { $values { "specs" "a sequence of SQL specs" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests if any of the SQL specs has the type " { $link +user-assigned-id+ } "." } ; HELP: bind# @@ -106,7 +105,7 @@ HELP: bind% HELP: db-assigned-id-spec? { $values { "specs" "a sequence of SQL specs" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests if any of the SQL specs has the type " { $link +db-assigned-id+ } "." } ; HELP: find-primary-key @@ -129,13 +128,13 @@ HELP: normalize-spec HELP: primary-key? { $values { "spec" "a SQL spec" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Returns true if a SQL spec is a primary key." } ; HELP: relation? { $values { "spec" "a SQL spec" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Returns true if a SQL spec is a relation." } ; HELP: unknown-modifier diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index 50461226b5..e673fb0b2f 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -1,7 +1,6 @@ -USING: alien arrays generic generic.math help.markup help.syntax -kernel math memory strings sbufs vectors io io.files classes -help generic.single continuations io.files.private listener -alien.libraries ; +USING: alien alien.libraries arrays continuations generic.math +generic.single help help.markup help.syntax io kernel math +quotations sbufs strings vectors ; IN: debugger ARTICLE: "debugger" "The debugger" @@ -48,7 +47,7 @@ HELP: :c { $description "Prints the call stack at the time of the most recent error. Used for interactive debugging." } ; HELP: :get -{ $values { "variable" "an object" } { "value" "the value, or f" } } +{ $values { "variable" object } { "value" "the value, or f" } } { $description "Looks up the value of a variable at the time of the most recent error." } ; HELP: :res @@ -84,7 +83,7 @@ HELP: restarts. { $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ; HELP: try -{ $values { "quot" "a quotation" } } +{ $values { "quot" quotation } } { $description "Attempts to call a quotation; if it throws an error, the error is printed to " { $link output-stream } ", stacks are restored, and execution continues after the call to " { $link try } "." } { $examples "The following example prints an error and keeps going:" @@ -106,7 +105,7 @@ HELP: type-check-error. { $error-description "Thrown by various primitives if one of the inputs does not have the expected type. Generic words throw " { $link no-method } " and " { $link no-math-method } " errors in such cases instead." } ; HELP: divide-by-zero-error. -{ $error-description "This error is thrown when " { $link / } " or " { $link /i } " is called with with a zero denominator." } +{ $error-description "This error is thrown when " { $link / } " or " { $link /i } " is called with a zero denominator." } { $see-also "division-by-zero" } ; HELP: signal-error. diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor index 6800c83a9c..25b46c2fdb 100644 --- a/basis/debugger/debugger-tests.factor +++ b/basis/debugger/debugger-tests.factor @@ -1,7 +1,40 @@ -USING: debugger kernel continuations tools.test ; +USING: alien.syntax debugger kernel continuations tools.test ; IN: debugger.tests [ ] [ [ drop ] [ error. ] recover ] unit-test [ f ] [ { } vm-error? ] unit-test [ f ] [ { "A" "B" } vm-error? ] unit-test + +[ ] [ +T{ test-failure + { error + { + "kernel-error" + 10 + { + B{ + 88 73 110 112 117 116 69 110 97 98 108 101 0 + } + B{ + 88 73 110 112 117 116 69 110 97 98 108 101 + 64 56 0 + } + B{ + 95 88 73 110 112 117 116 69 110 97 98 108 + 101 64 56 0 + } + B{ + 64 88 73 110 112 117 116 69 110 97 98 108 + 101 64 56 0 + } + } + DLL" xinput1_3.dll" + } + } + { asset { "Unit Test" [ ] [ dup ] } } + { file "resource:basis/game/input/input-tests.factor" } + { line# 6 } + { continuation f } +} error. +] unit-test diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 09d215b136..e1c23923a1 100755 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2004, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.strings 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 source-files.errors grouping ; +USING: accessors alien.strings arrays assocs classes +classes.builtin classes.mixin classes.tuple classes.tuple.parser +combinators combinators.short-circuit compiler.errors +compiler.units continuations definitions destructors +effects.parser fry generic generic.math generic.parser +generic.single grouping io io.encodings io.styles kernel +kernel.private lexer make math math.order math.parser namespaces +parser prettyprint sequences sequences.private slots +source-files.errors strings strings.parser summary system vocabs +vocabs.loader vocabs.parser words ; +FROM: namespaces => change-global ; IN: debugger GENERIC: error-help ( error -- topic ) @@ -43,8 +43,7 @@ M: string error. print ; error-continuation get name>> assoc-stack ; : :res ( n -- * ) - 1 - restarts get-global nth f restarts set-global - continue-restart ; + 1 - restarts [ nth f ] change-global continue-restart ; : :1 ( -- * ) 1 :res ; : :2 ( -- * ) 2 :res ; @@ -102,17 +101,26 @@ HOOK: signal-error. os ( obj -- ) "Invalid array size: " write dup third . "Maximum: " write fourth 1 - . ; +: fixnum-range-error. ( obj -- ) + "Cannot convert to fixnum: " write third . ; + : c-string-error. ( obj -- ) "Cannot convert to C string: " write third . ; : ffi-error. ( obj -- ) "FFI error" print drop ; +: find-ffi-error ( string -- error ) + [ linkage-errors get ] dip + '[ nip asset>> name>> _ = ] assoc-find drop nip + [ error>> message>> ] [ "none" ] if* ; + : undefined-symbol-error. ( obj -- ) "Cannot resolve C library function" print - "Symbol: " write dup third symbol>string print - "Library: " write fourth . - "You are probably missing a library or the library path is wrong." print + "Library: " write dup fourth . + third symbol>string + [ "Symbol: " write print ] + [ "DlError: " write find-ffi-error print ] bi "See http://concatenative.org/wiki/view/Factor/Requirements" print ; : stack-underflow. ( obj name -- ) @@ -131,7 +139,7 @@ HOOK: signal-error. os ( obj -- ) : memory-error. ( error -- ) "Memory protection fault at address " write third .h ; -: primitive-error. ( error -- ) +: primitive-error. ( error -- ) "Unimplemented primitive" print drop ; : fp-trap-error. ( error -- ) @@ -140,41 +148,47 @@ HOOK: signal-error. os ( obj -- ) : interrupt-error. ( error -- ) "Interrupt" print drop ; +: callback-space-overflow. ( error -- ) + "Callback space overflow" print drop ; + PREDICATE: vm-error < array - { - { [ dup empty? ] [ drop f ] } - { [ dup first "kernel-error" = not ] [ drop f ] } - [ second 0 18 between? ] - } cond ; + dup length 2 < [ drop f ] [ + { + [ first-unsafe "kernel-error" = ] + [ second-unsafe 0 kernel-error-count 1 - between? ] + } 1&& + ] if ; : vm-errors ( error -- n errors ) second { - { 0 [ expired-error. ] } - { 1 [ io-error. ] } - { 2 [ primitive-error. ] } - { 3 [ type-check-error. ] } - { 4 [ divide-by-zero-error. ] } - { 5 [ signal-error. ] } - { 6 [ array-size-error. ] } - { 7 [ c-string-error. ] } - { 8 [ ffi-error. ] } - { 9 [ undefined-symbol-error. ] } - { 10 [ datastack-underflow. ] } - { 11 [ datastack-overflow. ] } - { 12 [ retainstack-underflow. ] } - { 13 [ retainstack-overflow. ] } - { 14 [ callstack-underflow. ] } - { 15 [ callstack-overflow. ] } - { 16 [ memory-error. ] } - { 17 [ fp-trap-error. ] } - { 18 [ interrupt-error. ] } + [ expired-error. ] + [ io-error. ] + [ primitive-error. ] + [ type-check-error. ] + [ divide-by-zero-error. ] + [ signal-error. ] + [ array-size-error. ] + [ fixnum-range-error. ] + [ c-string-error. ] + [ ffi-error. ] + [ undefined-symbol-error. ] + [ datastack-underflow. ] + [ datastack-overflow. ] + [ retainstack-underflow. ] + [ retainstack-overflow. ] + [ callstack-underflow. ] + [ callstack-overflow. ] + [ memory-error. ] + [ fp-trap-error. ] + [ interrupt-error. ] + [ callback-space-overflow. ] } ; inline M: vm-error summary drop "VM error" ; -M: vm-error error. dup vm-errors case ; +M: vm-error error. dup vm-errors dispatch ; -M: vm-error error-help vm-errors at first ; +M: vm-error error-help vm-errors nth first ; M: no-method summary drop "No suitable method" ; @@ -351,8 +365,7 @@ M: row-variable-can't-have-type summary drop "Stack effect row variables cannot have a declared type" ; M: bad-escape error. - "Bad escape code: \\" write - char>> 1string print ; + "Bad escape code: \\" write char>> write nl ; M: bad-literal-tuple summary drop "Bad literal tuple" ; diff --git a/basis/deques/deques-docs.factor b/basis/deques/deques-docs.factor index 8b86fd2f3f..3a3e9d11e7 100644 --- a/basis/deques/deques-docs.factor +++ b/basis/deques/deques-docs.factor @@ -3,9 +3,16 @@ quotations ; IN: deques HELP: deque-empty? -{ $values { "deque" deque } { "?" "a boolean" } } +{ $values { "deque" deque } { "?" boolean } } { $contract "Returns true if a deque is empty." } -{ $notes "This operation is O(1)." } ; +{ $notes "This operation is O(1)." } +{ $examples + { $example + "USING: deques prettyprint unrolled-lists ;" + " deque-empty? ." + "t" + } +} ; HELP: clear-deque { $values @@ -15,27 +22,34 @@ HELP: clear-deque HELP: deque-member? { $values { "value" object } { "deque" deque } - { "?" "a boolean" } } + { "?" boolean } } { $description "Returns true if the " { $snippet "value" } " is found in the deque." } ; HELP: push-front { $values { "obj" object } { "deque" deque } } -{ $description "Push the object onto the front of the deque." } +{ $description "Push the object onto the front of the deque." } { $notes "This operation is O(1)." } ; HELP: push-front* { $values { "obj" object } { "deque" deque } { "node" "a node" } } -{ $contract "Push the object onto the front of the deque and return the newly created node." } -{ $notes "This operation is O(1)." } ; +{ $contract "Push the object onto the front of the deque and return the newly created node." } +{ $notes "This operation is O(1)." } +{ $examples + { $example + "USING: deques dlists kernel prettyprint ;" + "33 push-front* node-value ." + "33" + } +} ; HELP: push-back { $values { "obj" object } { "deque" deque } } -{ $description "Push the object onto the back of the deque." } +{ $description "Push the object onto the back of the deque." } { $notes "This operation is O(1)." } ; HELP: push-back* { $values { "obj" object } { "deque" deque } { "node" "a node" } } -{ $contract "Push the object onto the back of the deque and return the newly created node." } +{ $contract "Push the object onto the back of the deque and return the newly created node." } { $notes "This operation is O(1)." } ; HELP: push-all-back @@ -111,7 +125,14 @@ HELP: node-value HELP: slurp-deque { $values { "deque" deque } { "quot" quotation } } -{ $description "Pops off the back element of the deque and calls the quotation in a loop until the deque is empty." } ; +{ $description "Pops off the back element of the deque and calls the quotation in a loop until the deque is empty." } +{ $examples + { $example + "USING: deques dlists io kernel ;" + "{ \"one\" \"two\" \"three\" } [ push-all-front ] keep [ print ] slurp-deque" + "one\ntwo\nthree" + } +} ; ARTICLE: "deques" "Deques" "The " { $vocab-link "deques" } " vocabulary implements the deque data structure which has constant-time insertion and removal of elements at both ends." diff --git a/basis/disjoint-sets/disjoint-sets-docs.factor b/basis/disjoint-sets/disjoint-sets-docs.factor index 589f99f6dc..98ad9f2340 100644 --- a/basis/disjoint-sets/disjoint-sets-docs.factor +++ b/basis/disjoint-sets/disjoint-sets-docs.factor @@ -14,7 +14,7 @@ HELP: equiv-set-size { $description "Outputs the number of elements in the equivalence class of " { $snippet "a" } "." } ; HELP: equiv? -{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } { "?" "a boolean" } } +{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } { "?" boolean } } { $description "Tests if two elements belong to the same equivalence class." } ; HELP: equate diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 5036441f60..8138feee6a 100644 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -40,7 +40,7 @@ HELP: { $description "Creates a new " { $link search-deque } " backed by a " { $link dlist } ", with a " { $link hashtable } " for fast membership tests." } ; HELP: dlist-find -{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" boolean } } { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } { $notes "Returns a boolean to allow dlists to store " { $link f } "." $nl @@ -53,12 +53,12 @@ HELP: dlist-filter { $side-effects { "dlist" } } ; HELP: dlist-any? -{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } } +{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" boolean } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } { $notes "This operation is O(n)." } ; HELP: delete-node-if* -{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" boolean } } { $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." } { $notes "This operation is O(n)." } ; diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index a4879d6ea3..5c650adabe 100644 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -1,5 +1,5 @@ USING: accessors arrays classes deques dlists kernel locals -math tools.test ; +math sequences tools.test ; IN: dlists.tests [ t ] [ deque-empty? ] unit-test @@ -148,3 +148,8 @@ TUPLE: my-node < dlist-link { obj fixnum } ; ] unit-test +{ DL{ 0 1 2 3 4 } } [ + [ + { 3 2 4 1 0 } [ swap push-sorted drop ] with each + ] keep +] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 297e5a5c25..8d1d47f5a4 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman, -! Slava Pestov. +! Slava Pestov, John Benediktsson. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators combinators.short-circuit -deques fry hashtables kernel parser search-deques sequences -summary vocabs.loader ; +deques fry hashtables kernel math.order parser search-deques +sequences summary vocabs.loader ; IN: dlists TUPLE: dlist-link { prev maybe{ dlist-link } } { next maybe{ dlist-link } } ; @@ -192,6 +192,31 @@ M: dlist clear-deque ( dlist -- ) M: dlist clone [ '[ _ push-back ] dlist-each ] keep ; +> ] keep ] keep { + [ prev>> [ next<< ] [ drop ] if* ] + [ prev<< ] + [ drop ] + } 2cleave ; inline + +: push-before-node ( obj dlist-node dlist -- new-dlist-node ) + 2dup front>> eq? [ + nip push-front* + ] [ + drop (push-before-node) + ] if ; inline + +PRIVATE> + +: push-before ( ... obj dlist quot: ( ... obj -- ... ? ) -- ... dlist-node ) + [ obj>> ] prepose over [ dlist-find-node ] dip swap + [ swap push-before-node ] [ push-back* ] if* ; inline + +: push-sorted ( obj dlist -- dlist-node ) + dupd [ before? ] with push-before ; inline + INSTANCE: dlist deque SYNTAX: DL{ \ } [ >dlist ] parse-literal ; diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor index 203a6e3b09..c540a149b3 100644 --- a/basis/documents/documents-docs.factor +++ b/basis/documents/documents-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax math models strings sequences ; +USING: help.markup help.syntax kernel math models sequences +strings ; IN: documents HELP: +col @@ -20,7 +21,7 @@ HELP: =line { $description "Sets the line number of a line/column pair." } ; HELP: lines-equal? -{ $values { "loc1" "a pair of integers" } { "loc2" "a pair of integers" } { "?" "a boolean" } } +{ $values { "loc1" "a pair of integers" } { "loc2" "a pair of integers" } { "?" boolean } } { $description "Tests if both line/column pairs have the same line number." } ; HELP: document @@ -42,7 +43,7 @@ HELP: doc-lines { $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ; HELP: each-line -{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation "( ... line -- ... )" } } } +{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "quot" { $quotation ( ... line -- ... ) } } } { $description "Applies the quotation to each line in the range." } { $notes "The range is created by calling " { $link } "." } { $errors "Throws an error if " { $snippet "from" } " or " { $snippet "to" } " is out of bounds." } ; diff --git a/basis/documents/elements/elements-docs.factor b/basis/documents/elements/elements-docs.factor index 6a3f57c15a..90c4a5f9e3 100644 --- a/basis/documents/elements/elements-docs.factor +++ b/basis/documents/elements/elements-docs.factor @@ -28,7 +28,7 @@ HELP: one-line-elt { one-line-elt line-elt } related-words HELP: line-elt -{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next line from the current location." } ; +{ $description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next line from the current location." } ; HELP: doc-elt { $class-description "An element representing the entire document. The " { $link prev-elt } " word outputs the start of the document and the " { $link next-elt } " word outputs the end of the document." } ; @@ -51,4 +51,4 @@ $nl next-elt } ; -ABOUT: "documents.elements" \ No newline at end of file +ABOUT: "documents.elements" diff --git a/basis/editors/atom/atom.factor b/basis/editors/atom/atom.factor new file mode 100644 index 0000000000..b6e81ed430 --- /dev/null +++ b/basis/editors/atom/atom.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2014 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: editors kernel make math.parser namespaces sequences ; +IN: editors.atom + +SINGLETON: atom-editor +atom-editor \ editor-class set-global + +SYMBOL: atom-path + +M: atom-editor editor-command ( file line -- command ) + [ + atom-path get "atom" or , + number>string ":" glue , + ] { } make ; + diff --git a/basis/editors/atom/authors.txt b/basis/editors/atom/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/editors/atom/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/editors/atom/summary.txt b/basis/editors/atom/summary.txt new file mode 100644 index 0000000000..e29aa24b06 --- /dev/null +++ b/basis/editors/atom/summary.txt @@ -0,0 +1 @@ +Atom editor integration diff --git a/basis/editors/atom/tags.txt b/basis/editors/atom/tags.txt new file mode 100644 index 0000000000..ebb74b4d5f --- /dev/null +++ b/basis/editors/atom/tags.txt @@ -0,0 +1 @@ +not loaded diff --git a/basis/editors/geany/summary.txt b/basis/editors/geany/summary.txt new file mode 100644 index 0000000000..8c602b0534 --- /dev/null +++ b/basis/editors/geany/summary.txt @@ -0,0 +1 @@ +Geany editor integration diff --git a/basis/editors/notepad/summary.txt b/basis/editors/notepad/summary.txt new file mode 100644 index 0000000000..c1575b834f --- /dev/null +++ b/basis/editors/notepad/summary.txt @@ -0,0 +1 @@ +Notepad editor integration diff --git a/basis/editors/sublime/sublime.factor b/basis/editors/sublime/sublime.factor index 11ac974402..ff860bd194 100644 --- a/basis/editors/sublime/sublime.factor +++ b/basis/editors/sublime/sublime.factor @@ -12,7 +12,7 @@ HOOK: find-sublime-path os ( -- path ) M: object find-sublime-path "sublime" ; M: macosx find-sublime-path - "com.sublimetext.2" find-native-bundle [ + { "com.sublimetext.3" "com.sublimetext.2" } [ find-native-bundle ] map-find drop [ "Contents/SharedSupport/bin/subl" append-path ] [ f diff --git a/basis/editors/sublime/summary.txt b/basis/editors/sublime/summary.txt new file mode 100644 index 0000000000..c4f74246b2 --- /dev/null +++ b/basis/editors/sublime/summary.txt @@ -0,0 +1 @@ +Sublime Text editor integration diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor index 4dd5ecf407..4956d341d3 100644 --- a/basis/endian/endian.factor +++ b/basis/endian/endian.factor @@ -7,7 +7,7 @@ IN: endian SINGLETONS: big-endian little-endian ; : compute-native-endianness ( -- class ) - 1 int char deref 0 = big-endian little-endian ? ; + 1 int char deref 0 = big-endian little-endian ? ; foldable SYMBOL: native-endianness native-endianness [ compute-native-endianness ] initialize diff --git a/basis/environment/environment-docs.factor b/basis/environment/environment-docs.factor index 8e5ef8b352..823c9b35a4 100644 --- a/basis/environment/environment-docs.factor +++ b/basis/environment/environment-docs.factor @@ -31,7 +31,7 @@ HELP: os-env } ; HELP: change-os-env -{ $values { "key" string } { "quot" { $quotation "( old -- new )" } } } +{ $values { "key" string } { "quot" { $quotation ( old -- new ) } } } { $description "Applies a quotation to change the value stored in an environment variable." } { $examples "This is an operating system-specific feature. On Unix, you can do:" @@ -81,7 +81,11 @@ HELP: unset-os-env "Names and values of environment variables are operating system-specific." } ; -{ os-env os-envs set-os-env unset-os-env set-os-envs set-os-envs-pointer change-os-env } related-words +HELP: with-os-env +{ $values { "value" string } { "key" string } { "quot" "quotation" } } +{ $description "Calls a quotation with the " { $snippet "key" } " environment variable set to " { $snippet "value" } ", resetting the environment variable afterwards to its previous value." } ; + +{ os-env os-envs set-os-env unset-os-env set-os-envs set-os-envs-pointer change-os-env with-os-env } related-words ARTICLE: "environment" "Environment variables" diff --git a/basis/environment/environment-tests.factor b/basis/environment/environment-tests.factor index 524cf89ccf..a34d1db452 100644 --- a/basis/environment/environment-tests.factor +++ b/basis/environment/environment-tests.factor @@ -35,3 +35,9 @@ os unix? [ ! Issue #794, setting something to ``f`` is a memory protection fault on mac [ ] [ f "dummy-env-variable-for-factor-test" set-os-env ] unit-test + +{ f "value" f } [ + "factor-test-key" os-env + "value" "factor-test-key" [ "factor-test-key" os-env ] with-os-env + "factor-test-key" os-env +] unit-test diff --git a/basis/environment/environment.factor b/basis/environment/environment.factor index 121751e07d..79c83733a3 100644 --- a/basis/environment/environment.factor +++ b/basis/environment/environment.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs combinators init kernel sequences splitting -system vocabs vocabs.loader ; +USING: assocs combinators continuations init kernel sequences +splitting system vocabs vocabs.loader ; IN: environment HOOK: os-env os ( key -- value ) @@ -25,6 +25,10 @@ HOOK: set-os-envs-pointer os ( malloc -- ) : set-os-envs ( assoc -- ) [ "=" glue ] { } assoc>map (set-os-envs) ; +: with-os-env ( value key quot -- ) + over [ [ [ set-os-env ] 2curry ] [ compose ] bi* ] dip + [ os-env ] keep [ set-os-env ] 2curry [ ] cleanup ; inline + { { [ os unix? ] [ "environment.unix" require ] } { [ os windows? ] [ "environment.windows" require ] } diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor index 96ad3759c4..855a4d1404 100644 --- a/basis/environment/unix/unix.factor +++ b/basis/environment/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.data alien.strings -alien.syntax kernel layouts sequences system unix +alien.syntax kernel layouts libc sequences system unix environment io.encodings.utf8 unix.utilities vocabs combinators alien.accessors unix.ffi ; IN: environment.unix diff --git a/basis/formatting/formatting-docs.factor b/basis/formatting/formatting-docs.factor index 314db36183..ce7800cdbd 100755 --- a/basis/formatting/formatting-docs.factor +++ b/basis/formatting/formatting-docs.factor @@ -6,7 +6,7 @@ IN: formatting HELP: printf { $values { "format-string" string } } { $description - "Writes the arguments (specified on the stack) formatted according to the format string." + "Writes the arguments (specified on the stack) formatted according to the format string." $nl "Several format specifications exist for handling arguments of different types, and " "specifying attributes for the result string, including such things as maximum width, " @@ -16,14 +16,17 @@ HELP: printf { { $snippet "%%" } "Single %" "" } { { $snippet "%P.Ds" } "String format" "string" } { { $snippet "%P.DS" } "String format uppercase" "string" } - { { $snippet "%c" } "Character format" "char" } - { { $snippet "%C" } "Character format uppercase" "char" } - { { $snippet "%+Pd" } "Integer format" "fixnum" } - { { $snippet "%+P.De" } "Scientific notation" "fixnum, float" } - { { $snippet "%+P.DE" } "Scientific notation" "fixnum, float" } - { { $snippet "%+P.Df" } "Fixed format" "fixnum, float" } - { { $snippet "%+Px" } "Hexadecimal" "hex" } - { { $snippet "%+PX" } "Hexadecimal uppercase" "hex" } + { { $snippet "%P.Du" } "Unparsed format" "object" } + { { $snippet "%c" } "Character format" "char" } + { { $snippet "%C" } "Character format uppercase" "char" } + { { $snippet "%+Pd" } "Integer format (base 10)" "integer" } + { { $snippet "%+Po" } "Octal format (base 8)" "integer" } + { { $snippet "%+Pb" } "Binary format (base 2)" "integer" } + { { $snippet "%+P.De" } "Scientific notation" "integer, float" } + { { $snippet "%+P.DE" } "Scientific notation" "integer, float" } + { { $snippet "%+P.Df" } "Fixed format" "integer, float" } + { { $snippet "%+Px" } "Hexadecimal (base 16)" "integer" } + { { $snippet "%+PX" } "Hexadecimal (base 16) uppercase" "integer" } { { $snippet "%[%?, %]" } "Sequence format" "sequence" } { { $snippet "%[%?: %? %]" } "Assocs format" "assocs" } } @@ -61,6 +64,10 @@ HELP: printf "USING: formatting ;" "0xff \"%04X\" printf" "00FF" } + { $example + "USING: formatting ;" + "12 \"%b\" printf" + "1100" } { $example "USING: formatting ;" "1.23456789 \"%.3f\" printf" @@ -81,11 +88,15 @@ HELP: printf "USING: formatting ;" "H{ { 1 2 } { 3 4 } } \"%[%d: %d %]\" printf" "{ 1:2, 3:4 }" } + { $example + "USING: calendar formatting ;" + "3 years \"%u\" printf" + "T{ duration { year 3 } }" } } ; HELP: sprintf { $values { "format-string" string } { "result" string } } -{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." } +{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." } { $see-also printf } ; HELP: strftime @@ -136,5 +147,3 @@ ARTICLE: "formatting" "Formatted printing" } ; ABOUT: "formatting" - - diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor index 0d70484b0b..a5a463ff04 100755 --- a/basis/formatting/formatting-tests.factor +++ b/basis/formatting/formatting-tests.factor @@ -3,7 +3,7 @@ USING: calendar kernel formatting tools.test system ; IN: formatting.tests -[ "%s" printf ] must-infer +[ "%s" printf ] must-infer [ "%s" sprintf ] must-infer [ "" ] [ "" sprintf ] unit-test @@ -20,6 +20,10 @@ IN: formatting.tests [ "123.10" ] [ 123.1 "%01.2f" sprintf ] unit-test [ "1.2346" ] [ 1.23456789 "%.4f" sprintf ] unit-test [ " 1.23" ] [ 1.23456789 "%6.2f" sprintf ] unit-test +[ "001100" ] [ 12 "%06b" sprintf ] unit-test +[ "==14" ] [ 12 "%'=4o" sprintf ] unit-test + +{ "foo: 1 bar: 2" } [ { 1 2 3 } "foo: %d bar: %s" vsprintf ] unit-test os windows? [ [ "1.234000e+008" ] [ 123400000 "%e" sprintf ] unit-test diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index c7e51581ad..1aedd07afb 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: accessors arrays assocs calendar combinators fry kernel -generalizations io io.streams.string macros math math.functions -math.parser peg.ebnf quotations sequences splitting strings -unicode.categories unicode.case vectors combinators.smart -present ; +USING: accessors arrays assocs calendar combinators +combinators.smart fry generalizations io io.streams.string +kernel macros math math.functions math.parser namespaces +peg.ebnf present prettyprint quotations sequences strings +unicode.case unicode.categories vectors ; FROM: math.parser.private => format-float ; IN: formatting @@ -20,7 +20,7 @@ IN: formatting { { CHAR: - [ [ 1 - ] dip remove-nth "-" prepend ] } { CHAR: + [ [ 1 - ] dip remove-nth "+" prepend ] } - [ drop swap drop ] + [ drop nip ] } case ] [ drop ] if ] when ; @@ -56,12 +56,15 @@ width = (width_)? => [[ [ ] or ]] digits_ = "." ([0-9])* => [[ second >digits ]] digits = (digits_)? => [[ 6 or ]] -fmt-% = "%" => [[ [ "%" ] ]] +fmt-% = "%" => [[ "%" ]] fmt-c = "c" => [[ [ 1string ] ]] fmt-C = "C" => [[ [ 1string >upper ] ]] fmt-s = "s" => [[ [ present ] ]] fmt-S = "S" => [[ [ present >upper ] ]] +fmt-u = "u" => [[ [ unparse ] ]] fmt-d = "d" => [[ [ >integer number>string ] ]] +fmt-o = "o" => [[ [ >integer >oct ] ]] +fmt-b = "b" => [[ [ >integer >bin ] ]] fmt-e = digits "e" => [[ first '[ _ format-scientific ] ]] fmt-E = digits "E" => [[ first '[ _ format-scientific >upper ] ]] fmt-f = digits "f" => [[ first '[ _ format-decimal ] ]] @@ -69,10 +72,10 @@ fmt-x = "x" => [[ [ >hex ] ]] fmt-X = "X" => [[ [ >hex >upper ] ]] unknown = (.)* => [[ unknown-printf-directive ]] -strings_ = fmt-c|fmt-C|fmt-s|fmt-S +strings_ = fmt-c|fmt-C|fmt-s|fmt-S|fmt-u strings = pad width strings_ => [[ compose-all ]] -numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X +numbers_ = fmt-d|fmt-o|fmt-b|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]] types = strings|numbers @@ -81,23 +84,37 @@ lists = "[%" types ", %]" => [[ second '[ _ map ", " join "{ " prepend " assocs = "[%" types ": %" types " %]" => [[ [ second ] [ fourth ] bi '[ unzip [ _ map ] dip _ map zip [ ":" join ] map ", " join "{ " prepend " }" append ] ]] -formats = "%" (types|fmt-%|lists|assocs|unknown) => [[ second '[ _ dip ] ]] +formats = "%" (types|fmt-%|lists|assocs|unknown) => [[ second ]] -plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]] +plain-text = (!("%").)+ => [[ >string ]] -text = (formats|plain-text)* => [[ [ [ [ push ] keep ] append ] map ]] +text = (formats|plain-text)* => [[ ]] ;EBNF PRIVATE> MACRO: printf ( format-string -- ) - parse-printf [ length ] keep compose-all - '[ _ @ [ write ] each ] ; + parse-printf [ [ callable? ] count ] keep [ + dup string? [ 1quotation ] [ [ 1 - ] dip ] if + over [ ndip ] 2curry + ] map nip [ compose-all ] [ length ] bi '[ + @ output-stream get [ stream-write ] curry _ napply + ] ; : sprintf ( format-string -- result ) [ printf ] with-string-writer ; inline +: vprintf ( seq format-string -- ) + parse-printf output-stream get '[ + dup string? [ + [ unclip-slice ] dip call( x -- y ) + ] unless _ stream-write + ] each drop ; + +: vsprintf ( seq format-string -- result ) + [ vprintf ] with-string-writer ; inline + string 2 CHAR: 0 pad-head ; inline @@ -133,27 +150,27 @@ MACRO: printf ( format-string -- ) EBNF: parse-strftime -fmt-% = "%" => [[ [ "%" ] ]] -fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]] -fmt-A = "A" => [[ [ dup day-of-week day-name ] ]] -fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]] -fmt-B = "B" => [[ [ dup month>> month-name ] ]] -fmt-c = "c" => [[ [ dup >datetime ] ]] -fmt-d = "d" => [[ [ dup day>> pad-00 ] ]] -fmt-H = "H" => [[ [ dup hour>> pad-00 ] ]] -fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when pad-00 ] ]] -fmt-j = "j" => [[ [ dup day-of-year pad-000 ] ]] -fmt-m = "m" => [[ [ dup month>> pad-00 ] ]] -fmt-M = "M" => [[ [ dup minute>> pad-00 ] ]] -fmt-p = "p" => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]] -fmt-S = "S" => [[ [ dup second>> floor pad-00 ] ]] -fmt-U = "U" => [[ [ dup week-of-year-sunday pad-00 ] ]] -fmt-w = "w" => [[ [ dup day-of-week number>string ] ]] -fmt-W = "W" => [[ [ dup week-of-year-monday pad-00 ] ]] -fmt-x = "x" => [[ [ dup >date ] ]] -fmt-X = "X" => [[ [ dup >time ] ]] -fmt-y = "y" => [[ [ dup year>> 100 mod pad-00 ] ]] -fmt-Y = "Y" => [[ [ dup year>> number>string ] ]] +fmt-% = "%" => [[ "%" ]] +fmt-a = "a" => [[ [ day-of-week day-abbreviation3 ] ]] +fmt-A = "A" => [[ [ day-of-week day-name ] ]] +fmt-b = "b" => [[ [ month>> month-abbreviation ] ]] +fmt-B = "B" => [[ [ month>> month-name ] ]] +fmt-c = "c" => [[ [ >datetime ] ]] +fmt-d = "d" => [[ [ day>> pad-00 ] ]] +fmt-H = "H" => [[ [ hour>> pad-00 ] ]] +fmt-I = "I" => [[ [ hour>> dup 12 > [ 12 - ] when pad-00 ] ]] +fmt-j = "j" => [[ [ day-of-year pad-000 ] ]] +fmt-m = "m" => [[ [ month>> pad-00 ] ]] +fmt-M = "M" => [[ [ minute>> pad-00 ] ]] +fmt-p = "p" => [[ [ hour>> 12 < "AM" "PM" ? ] ]] +fmt-S = "S" => [[ [ second>> floor pad-00 ] ]] +fmt-U = "U" => [[ [ week-of-year-sunday pad-00 ] ]] +fmt-w = "w" => [[ [ day-of-week number>string ] ]] +fmt-W = "W" => [[ [ week-of-year-monday pad-00 ] ]] +fmt-x = "x" => [[ [ >date ] ]] +fmt-X = "X" => [[ [ >time ] ]] +fmt-y = "y" => [[ [ year>> 100 mod pad-00 ] ]] +fmt-Y = "Y" => [[ [ year>> number>string ] ]] fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]] unknown = (.)* => [[ "Unknown directive" throw ]] @@ -161,16 +178,23 @@ formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I| fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x| fmt-X|fmt-y|fmt-Y|fmt-Z|unknown -formats = "%" (formats_) => [[ second '[ _ dip ] ]] +formats = "%" (formats_) => [[ second ]] -plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]] +plain-text = (!("%").)+ => [[ >string ]] -text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]] +text = (formats|plain-text)* => [[ ]] ;EBNF PRIVATE> MACRO: strftime ( format-string -- ) - parse-strftime [ length ] keep [ ] join - '[ _ @ reverse concat nip ] ; + parse-strftime [ + dup string? [ + '[ _ swap push-all ] + ] [ + '[ over @ swap push-all ] + ] if + ] map '[ + SBUF" " clone [ _ cleave drop ] keep "" like + ] ; diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 80d699fd1f..acd106d2de 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -137,7 +137,7 @@ ERROR: type-error type ; : handle-PWD ( obj -- ) drop - display-directory get "\"" dup surround 257 server-response ; + display-directory "\"" dup surround 257 server-response ; : handle-SYST ( obj -- ) drop diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 19491acfc3..e01fb9e6e7 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -113,7 +113,7 @@ M: action modify-form TUPLE: page-action < action template ; : ( path -- response ) - resolve-template-path "text/html" ; + resolve-template-path ; : ( -- page ) page-action new-action diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index b81edbd2bb..7aa771e37d 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -36,7 +36,7 @@ HELP: encode-password HELP: have-capabilities? { $values { "capabilities" "a sequence of capabilities" } - { "?" "a boolean" } + { "?" boolean } } { $description "Tests if the currently logged-in user possesses the given capabilities." } ; @@ -63,7 +63,7 @@ HELP: realm { $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ; HELP: uchange -{ $values { "quot" { $quotation "( old -- new )" } } { "key" symbol } } +{ $values { "quot" { $quotation ( old -- new ) } } { "key" symbol } } { $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ; HELP: uget @@ -196,7 +196,7 @@ $nl "Authentication realms can be adorned with additional functionality." { $subsections "furnace.auth.features" } "An administration tool." -{ $subsections "furnace.auth.user-admin" } +{ $subsections "webapps.user-admin" } "A concrete example." { $subsections "furnace.auth.example" } ; diff --git a/basis/furnace/auth/basic/basic-tests.factor b/basis/furnace/auth/basic/basic-tests.factor new file mode 100644 index 0000000000..63797607b3 --- /dev/null +++ b/basis/furnace/auth/basic/basic-tests.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2013 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors tools.test furnace.auth.basic http.server +http.server.responses kernel http namespaces ; +IN: furnace.auth.basic.tests + +CONSTANT: GET-AUTH "Basic Zm9vOmJhcg==" +{ "foo" "bar" } [ GET-AUTH parse-basic-auth ] unit-test + +{ t } [ [ "GET" >>method init-request + "path" <304> "name" + call-responder* >boolean +] with-scope ] unit-test diff --git a/basis/furnace/auth/basic/basic.factor b/basis/furnace/auth/basic/basic.factor index a9b367c5c9..802e489e74 100644 --- a/basis/furnace/auth/basic/basic.factor +++ b/basis/furnace/auth/basic/basic.factor @@ -27,3 +27,5 @@ M: basic-auth-realm logged-in-username ( realm -- uid ) drop request get "authorization" header parse-basic-auth dup [ over check-login swap and ] [ 2drop f ] if ; + +M: basic-auth-realm init-realm drop ; diff --git a/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor index a652e734a1..7758afd212 100644 --- a/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor +++ b/basis/furnace/auth/features/deactivate-user/deactivate-user-docs.factor @@ -6,7 +6,7 @@ HELP: allow-deactivation { $description "Adds a " { $snippet "deactivate-user" } " action to an authentication realm." } ; HELP: allow-deactivation? -{ $values { "?" "a boolean" } } +{ $values { "?" boolean } } { $description "Outputs true if the current authentication realm allows user profile deactivation." } ; ARTICLE: "furnace.auth.features.deactivate-user" "User profile deactivation" diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor index 1124ad43ec..be1276239c 100644 --- a/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile-docs.factor @@ -6,7 +6,7 @@ HELP: allow-edit-profile { $description "Adds an " { $snippet "edit-profile" } " action to an authentication realm." } ; HELP: allow-edit-profile? -{ $values { "?" "a boolean" } } +{ $values { "?" boolean } } { $description "Outputs true if the current authentication realm allows user profile editing." } ; ARTICLE: "furnace.auth.features.edit-profile" "User profile editing" diff --git a/basis/furnace/auth/features/recover-password/recover-password-docs.factor b/basis/furnace/auth/features/recover-password/recover-password-docs.factor index 22fa95f23e..3248bb1952 100644 --- a/basis/furnace/auth/features/recover-password/recover-password-docs.factor +++ b/basis/furnace/auth/features/recover-password/recover-password-docs.factor @@ -6,7 +6,7 @@ HELP: allow-password-recovery { $description "Adds a " { $snippet "recover-password" } " action to an authentication realm." } ; HELP: allow-password-recovery? -{ $values { "?" "a boolean" } } +{ $values { "?" boolean } } { $description "Outputs true if the current authentication realm allows user password recovery." } ; HELP: lost-password-from diff --git a/basis/furnace/auth/features/registration/registration-docs.factor b/basis/furnace/auth/features/registration/registration-docs.factor index d64a14c869..49f397c829 100644 --- a/basis/furnace/auth/features/registration/registration-docs.factor +++ b/basis/furnace/auth/features/registration/registration-docs.factor @@ -6,7 +6,7 @@ HELP: allow-registration { $description "Adds a " { $snippet "registration" } " action to an authentication realm." } ; HELP: allow-registration? -{ $values { "?" "a boolean" } } +{ $values { "?" boolean } } { $description "Outputs true if the current authentication realm allows user registration." } ; ARTICLE: "furnace.auth.features.registration" "User registration" diff --git a/basis/furnace/auth/providers/db/db-tests.factor b/basis/furnace/auth/providers/db/db-tests.factor index f23a4a8527..18a9a350d2 100644 --- a/basis/furnace/auth/providers/db/db-tests.factor +++ b/basis/furnace/auth/providers/db/db-tests.factor @@ -4,14 +4,18 @@ furnace.auth.login furnace.auth.providers furnace.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations -io.files io.files.temp io.directories accessors kernel ; +io.files io.files.temp io.directories accessors kernel +sequences system ; IN: furnace.auth.providers.db.tests "test" realm set -[ "auth-test.db" temp-file delete-file ] ignore-errors +: auth-test-db-name ( -- string ) + cpu name>> "auth-test." ".db" surround ; -"auth-test.db" temp-file [ +[ auth-test-db-name temp-file delete-file ] ignore-errors + +auth-test-db-name temp-file [ user ensure-table diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor index 443384147d..2f935c33e6 100644 --- a/basis/furnace/conversations/conversations-docs.factor +++ b/basis/furnace/conversations/conversations-docs.factor @@ -28,7 +28,7 @@ HELP: cset { $description "Sets the value of a conversation variable." } ; HELP: cchange -{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } } +{ $values { "key" symbol } { "quot" { $quotation ( old -- new ) } } } { $description "Applies the quotation to the old value of the conversation variable, and assigns the resulting value back to the variable." } ; ARTICLE: "furnace.conversations" "Furnace conversation scope" diff --git a/basis/furnace/db/db.factor b/basis/furnace/db/db.factor index d771d1d2d7..c09be983bb 100644 --- a/basis/furnace/db/db.factor +++ b/basis/furnace/db/db.factor @@ -4,10 +4,10 @@ USING: kernel accessors continuations namespaces destructors db db.private db.pools io.pools http.server http.server.filters ; IN: furnace.db -TUPLE: db-persistence < filter-responder pool ; +TUPLE: db-persistence < filter-responder pool disposed ; : ( responder db -- responder' ) - db-persistence boa ; + f db-persistence boa ; M: db-persistence call-responder* [ @@ -15,3 +15,5 @@ M: db-persistence call-responder* [ return-connection-later ] [ drop db-connection set ] 2bi ] [ call-next-method ] bi ; + +M: db-persistence dispose* pool>> dispose ; diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index 6fe2633031..ca1faa7729 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -14,7 +14,7 @@ C: base-path-check-responder M: base-path-check-responder call-responder* 2drop "$funny-dispatcher" resolve-base-path - "text/plain" ; + ; [ ] [ diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor index 605b04785c..e272f36fa1 100644 --- a/basis/furnace/sessions/sessions-docs.factor +++ b/basis/furnace/sessions/sessions-docs.factor @@ -11,7 +11,7 @@ HELP: { $description "Wraps a responder in a session manager responder." } ; HELP: schange -{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } } +{ $values { "key" symbol } { "quot" { $quotation ( old -- new ) } } } { $description "Applies the quotation to the old value of the session variable, and assigns the resulting value back to the variable." } ; HELP: sget diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index 1ac3dbd51a..5e9e10591f 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -20,7 +20,7 @@ M: foo init-session* drop 0 "x" sset ; M: foo call-responder* 2drop "x" [ 1 + ] schange - "x" sget number>string "text/html" ; + "x" sget number>string ; : url-responder-mock-test ( -- string ) [ @@ -47,7 +47,7 @@ M: foo call-responder* : ( -- action ) - [ [ ] "text/plain" exit-with ] >>display ; + [ [ ] exit-with ] >>display ; [ "auth-test.db" temp-file delete-file ] ignore-errors diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index fc1828bbb6..1e5d89f889 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -16,7 +16,7 @@ HELP: client-state { $notes "This word is used by session management, conversation scope and asides." } ; HELP: each-responder -{ $values { "quot" { $quotation "( responder -- )" } } } +{ $values { "quot" { $quotation ( ... responder -- ... ) } } } { $description "Applies the quotation to each responder involved in processing the current request." } ; HELP: hidden-form-field @@ -72,7 +72,7 @@ HELP: resolve-template-path { $description "Resolves a responder-relative template path." } ; HELP: same-host? -{ $values { "url" url } { "?" "a boolean" } } +{ $values { "url" url } { "?" boolean } } { $description "Tests if the given URL is located on the same host as the URL of the current request." } ; HELP: user-agent @@ -88,7 +88,7 @@ HELP: exit-with { $description "Exits from an outer " { $link with-exit-continuation } "." } ; HELP: with-exit-continuation -{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } } +{ $values { "quot" { $quotation ( -- value ) } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } } { $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." } { $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index 9a82490482..61547131fc 100644 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -24,7 +24,7 @@ ERROR: no-such-word name vocab ; : nested-responders ( -- seq ) responder-nesting get values ; -: each-responder ( quot -- ) +: each-responder ( quot: ( ... responder -- ... ) -- ) nested-responders swap each ; inline ERROR: no-such-responder responder ; diff --git a/basis/game/input/input-docs.factor b/basis/game/input/input-docs.factor index 1ea5dcc650..58cc35af1c 100644 --- a/basis/game/input/input-docs.factor +++ b/basis/game/input/input-docs.factor @@ -47,7 +47,7 @@ HELP: close-game-input { $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ; HELP: game-input-opened? -{ $values { "?" "a boolean" } } +{ $values { "?" boolean } } { $description "Returns true if the game input interface is open, false otherwise." } ; HELP: with-game-input @@ -176,10 +176,10 @@ HELP: buttons-delta-as { button-delta buttons-delta buttons-delta-as } related-words HELP: pressed -{ $class-description "This symbol is returned by " { $link button-delta } " or " { $link buttons-delta } " to represent a button or key being pressed between two samples of its state." } ; +{ $description "This symbol is returned by " { $link button-delta } " or " { $link buttons-delta } " to represent a button or key being pressed between two samples of its state." } ; HELP: released -{ $class-description "This symbol is returned by " { $link button-delta } " or " { $link buttons-delta } " to represent a button or key being released between two samples of its state." } ; +{ $description "This symbol is returned by " { $link button-delta } " or " { $link buttons-delta } " to represent a button or key being released between two samples of its state." } ; { pressed released } related-words diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index edd30b89fa..51e1b84ec9 100644 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -45,7 +45,7 @@ ERROR: game-input-not-open ; : open-game-input ( -- ) game-input-opened? [ - (open-game-input) + (open-game-input) ] unless game-input-opened [ 1 + ] change-global reset-mouse ; @@ -55,7 +55,7 @@ ERROR: game-input-not-open ; 1 - ] change-global game-input-opened? [ - (close-game-input) + (close-game-input) reset-game-input ] unless ; @@ -79,7 +79,7 @@ SYMBOLS: get-controllers [ [ product-id = ] [ instance-id = ] bi-curry bi* and - ] with with find nip ; + ] 2with find nip ; TUPLE: keyboard-state keys ; diff --git a/basis/game/input/xinput/xinput.factor b/basis/game/input/xinput/xinput.factor index 70b5e14fa2..c51ec1e098 100644 --- a/basis/game/input/xinput/xinput.factor +++ b/basis/game/input/xinput/xinput.factor @@ -17,7 +17,7 @@ xinput-game-input-backend game-input-backend set-global 65535 * >fixnum 0 65535 clamp ; inline MACRO: map-index-compose ( seq quot -- seq ) '[ '[ _ execute _ ] _ compose ] map-index 1quotation ; - + : fill-buttons ( button-bitmap -- button-array ) 10 0.0 dup rot >fixnum { XINPUT_GAMEPAD_START @@ -114,8 +114,8 @@ M: xinput-game-input-backend instance-id if ; M: xinput-game-input-backend read-controller - XINPUT_STATE [ XInputGetState ] keep - swap drop fill-controller-state ; + XINPUT_STATE [ XInputGetState drop ] keep + fill-controller-state ; M: xinput-game-input-backend calibrate-controller drop ; diff --git a/basis/gdk/ffi/ffi.factor b/basis/gdk/ffi/ffi.factor index 8a3f0da6d3..ad095ba66e 100644 --- a/basis/gdk/ffi/ffi.factor +++ b/basis/gdk/ffi/ffi.factor @@ -16,7 +16,8 @@ LIBRARY: gdk << "gdk" { { [ os windows? ] [ "libgdk-win32-2.0-0.dll" cdecl add-library ] } - { [ os unix? ] [ drop ] } + { [ os macosx? ] [ drop ] } + { [ os unix? ] [ "libgdk-x11-2.0.so" cdecl add-library ] } } cond >> diff --git a/basis/gdk/gl/ffi/ffi.factor b/basis/gdk/gl/ffi/ffi.factor index 507550ff98..a1ff666c2e 100644 --- a/basis/gdk/gl/ffi/ffi.factor +++ b/basis/gdk/gl/ffi/ffi.factor @@ -10,4 +10,12 @@ IN: gdk.gl.ffi LIBRARY: gdk.gl +<< +"gdk.gl" { + { [ os windows? ] [ "libgdkglext-win32-1.0-0.dll" cdecl add-library ] } + { [ os macosx? ] [ drop ] } + { [ os unix? ] [ "libgdkglext-x11-1.0.so" cdecl add-library ] } +} cond +>> + GIR: vocab:gdk/gl/GdkGLExt-1.0.gir diff --git a/basis/gdk/pixbuf/ffi/ffi.factor b/basis/gdk/pixbuf/ffi/ffi.factor index f8a8c7db88..f51f554bb5 100644 --- a/basis/gdk/pixbuf/ffi/ffi.factor +++ b/basis/gdk/pixbuf/ffi/ffi.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2010 Anton Gorenko. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.data alien.libraries alien.syntax +USING: alien alien.c-types alien.data alien.libraries alien.syntax combinators gio.ffi glib.ffi gobject-introspection gobject-introspection.standard-types kernel libc sequences system vocabs ; @@ -15,17 +15,39 @@ LIBRARY: gdk.pixbuf << "gdk.pixbuf" { { [ os windows? ] [ "libgdk_pixbuf-2.0-0.dll" cdecl add-library ] } - { [ os unix? ] [ drop ] } + { [ os macosx? ] [ "libgdk_pixbuf-2.0.dylib" cdecl add-library ] } + { [ os unix? ] [ "libgdk_pixbuf-2.0.so" cdecl add-library ] } } cond >> GIR: vocab:gdk/pixbuf/GdkPixbuf-2.0.gir -! : data>GInputStream ( data -- GInputStream ) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index ea579aa83a..7a219522eb 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -97,8 +97,8 @@ HELP: nrot { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" } "Some core words expressed in terms of " { $link nrot } ":" { $table - { { $link swap } { $snippet "1 nrot" } } - { { $link rot } { $snippet "2 nrot" } } + { { $link swap } { $snippet "2 nrot" } } + { { $link rot } { $snippet "3 nrot" } } } } ; @@ -111,8 +111,8 @@ HELP: -nrot { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" } "Some core words expressed in terms of " { $link -nrot } ":" { $table - { { $link swap } { $snippet "1 -nrot" } } - { { $link -rot } { $snippet "2 -nrot" } } + { { $link swap } { $snippet "2 -nrot" } } + { { $link -rot } { $snippet "3 -nrot" } } } } ; diff --git a/basis/gio/ffi/ffi.factor b/basis/gio/ffi/ffi.factor index 96227b4679..e4df71e69b 100644 --- a/basis/gio/ffi/ffi.factor +++ b/basis/gio/ffi/ffi.factor @@ -13,7 +13,8 @@ LIBRARY: gio << "gio" { { [ os windows? ] [ "libgio-2.0-0.dll" cdecl add-library ] } - { [ os unix? ] [ drop ] } + { [ os macosx? ] [ "libgio-2.0.dylib" cdecl add-library ] } + { [ os unix? ] [ "libgio-2.0.so" cdecl add-library ] } } cond >> diff --git a/basis/glib/ffi/ffi.factor b/basis/glib/ffi/ffi.factor index c7bca2e8be..eb96dd0133 100644 --- a/basis/glib/ffi/ffi.factor +++ b/basis/glib/ffi/ffi.factor @@ -12,7 +12,7 @@ LIBRARY: glib "glib" { { [ os windows? ] [ "libglib-2.0-0.dll" cdecl add-library ] } { [ os macosx? ] [ "libglib-2.0.0.dylib" cdecl add-library ] } - { [ os unix? ] [ drop ] } + { [ os unix? ] [ "libglib-2.0.so" cdecl add-library ] } } cond >> diff --git a/basis/gobject/ffi/ffi.factor b/basis/gobject/ffi/ffi.factor index 919f9daa0f..ccdf210a1e 100644 --- a/basis/gobject/ffi/ffi.factor +++ b/basis/gobject/ffi/ffi.factor @@ -16,7 +16,8 @@ LIBRARY: gobject << "gobject" { { [ os windows? ] [ "libobject-2.0-0.dll" cdecl add-library ] } - { [ os unix? ] [ drop ] } + { [ os macosx? ] [ "libgobject-2.0.dylib" cdecl add-library ] } + { [ os unix? ] [ "libgobject-2.0.so" cdecl add-library ] } } cond >> diff --git a/basis/graphs/graphs-docs.factor b/basis/graphs/graphs-docs.factor index 66e896065c..45f7f81ae7 100644 --- a/basis/graphs/graphs-docs.factor +++ b/basis/graphs/graphs-docs.factor @@ -28,5 +28,5 @@ HELP: remove-vertex { $side-effects "graph" } ; HELP: closure -{ $values { "vertex" object } { "quot" { $quotation "( vertex -- assoc )" } } { "assoc" "a new assoc" } } +{ $values { "vertex" object } { "quot" { $quotation ( vertex -- assoc ) } } { "assoc" "a new assoc" } } { $description "Outputs a set of all vertices reachable from " { $snippet "vertex" } " via edges given by the quotation. The set always includes " { $snippet "vertex" } "." } ; diff --git a/basis/graphs/graphs.factor b/basis/graphs/graphs.factor index a1ab6c5dc3..ce561d96c9 100644 --- a/basis/graphs/graphs.factor +++ b/basis/graphs/graphs.factor @@ -14,7 +14,7 @@ IN: graphs PRIVATE> : add-vertex ( vertex edges graph -- ) - [ [ nest dupd set-at ] curry with each ] if-graph ; inline + [ [ nest conjoin ] curry with each ] if-graph ; inline : add-vertex* ( vertex edges graph -- ) [ diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index 80ec52faf5..2401db1a1a 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax sequences strings ; +USING: help.markup help.syntax kernel sequences strings ; IN: grouping ARTICLE: "grouping" "Groups and clumps" @@ -65,7 +65,7 @@ $nl "New groups are created by calling " { $link } "." } ; HELP: group -{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } +{ $values { "seq" sequence } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } { $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." } { $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } { $examples @@ -73,7 +73,7 @@ HELP: group } ; HELP: -{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } } +{ $values { "seq" sequence } { "n" "a non-negative integer" } { "groups" groups } } { $description "Outputs a virtual sequence whose elements are slices of disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples { $example @@ -100,7 +100,7 @@ $nl "New clumps are created by calling " { $link } "." } ; HELP: clump -{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } +{ $values { "seq" sequence } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } { $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." } { $notes "For an empty sequence, the result is an empty sequence. For a non empty sequence with a length smaller than " { $snippet "n" } ", the result will be an empty sequence." } { $examples @@ -108,7 +108,7 @@ HELP: clump } ; HELP: circular-clump -{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } +{ $values { "seq" sequence } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } } { $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements, wrapping around the end of the sequence, and collects the clumps into a new array." } { $notes "For an empty sequence, the result is an empty sequence." } { $examples @@ -116,7 +116,7 @@ HELP: circular-clump } ; HELP: -{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } } +{ $values { "seq" sequence } { "n" "a non-negative integer" } { "clumps" clumps } } { $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." } { $examples "Running averages:" @@ -136,7 +136,7 @@ HELP: } ; HELP: -{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } } +{ $values { "seq" sequence } { "n" "a non-negative integer" } { "clumps" clumps } } { $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence, starting with each of its elements and wrapping around the end of the sequence." } { $examples { $example @@ -153,7 +153,7 @@ HELP: { } related-words HELP: monotonic? -{ $values { "seq" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } } +{ $values { "seq" sequence } { "quot" { $quotation ( elt1 elt2 -- ? ) } } { "?" boolean } } { $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." } { $examples "Testing if a sequence is non-decreasing:" @@ -163,11 +163,11 @@ HELP: monotonic? } ; HELP: all-equal? -{ $values { "seq" sequence } { "?" "a boolean" } } +{ $values { "seq" sequence } { "?" boolean } } { $description "Tests if all elements in the sequence are equal. Yields true with an empty sequence." } ; HELP: all-eq? -{ $values { "seq" sequence } { "?" "a boolean" } } +{ $values { "seq" sequence } { "?" boolean } } { $description "Tests if all elements in the sequence are the same identical object. Yields true with an empty sequence." } ; { monotonic? all-eq? all-equal? } related-words diff --git a/basis/gtk/ffi/ffi.factor b/basis/gtk/ffi/ffi.factor index 18e5615c70..e9b3238ba7 100644 --- a/basis/gtk/ffi/ffi.factor +++ b/basis/gtk/ffi/ffi.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Anton Gorenko. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.destructors alien.libraries -alien.syntax combinators gobject-introspection +alien.libraries.finder alien.syntax assocs gobject-introspection gobject-introspection.standard-types kernel pango.ffi system vocabs ; IN: gtk.ffi @@ -15,9 +15,9 @@ LIBRARY: gtk << "gtk" { - { [ os windows? ] [ "libgtk-win32-2.0-0.dll" cdecl add-library ] } - { [ os unix? ] [ drop ] } -} cond + { linux "gtk-x11-2.0" } + { windows "libgtk-win32-2.0-0" } +} os of [ find-library cdecl add-library ] [ drop ] if* >> IMPLEMENT-STRUCTS: GtkTreeIter ; diff --git a/basis/heaps/heaps-docs.factor b/basis/heaps/heaps-docs.factor index 8ceb7bb78f..3888951f6b 100644 --- a/basis/heaps/heaps-docs.factor +++ b/basis/heaps/heaps-docs.factor @@ -53,49 +53,49 @@ HELP: { $description "Create a new " { $link max-heap } "." } ; HELP: heap-push -{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } } +{ $values { "value" object } { "key" "a comparable object" } { "heap" heap } } { $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } { $side-effects "heap" } ; HELP: heap-push* -{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } { "entry" entry } } +{ $values { "value" object } { "key" "a comparable object" } { "heap" heap } { "entry" entry } } { $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." } { $side-effects "heap" } ; HELP: heap-push-all -{ $values { "assoc" assoc } { "heap" "a heap" } } +{ $values { "assoc" assoc } { "heap" heap } } { $description "Push every key/value pair of an assoc onto a heap." } { $side-effects "heap" } ; HELP: heap-peek -{ $values { "heap" "a heap" } { "value" object } { "key" object } } +{ $values { "heap" heap } { "value" object } { "key" object } } { $description "Output the first element in the heap, leaving it in the heap." } ; HELP: heap-pop* -{ $values { "heap" "a heap" } } +{ $values { "heap" heap } } { $description "Remove the first element from the heap." } { $side-effects "heap" } ; HELP: heap-pop -{ $values { "heap" "a heap" } { "value" object } { "key" object } } +{ $values { "heap" heap } { "value" object } { "key" object } } { $description "Output and remove the first element in the heap." } { $side-effects "heap" } ; HELP: heap-empty? -{ $values { "heap" "a heap" } { "?" "a boolean" } } +{ $values { "heap" heap } { "?" boolean } } { $description "Tests if a heap has no nodes." } ; HELP: heap-size -{ $values { "heap" "a heap" } { "n" integer } } +{ $values { "heap" heap } { "n" integer } } { $description "Returns the number of key/value pairs in the heap." } ; HELP: heap-delete -{ $values { "entry" entry } { "heap" "a heap" } } +{ $values { "entry" entry } { "heap" heap } } { $description "Remove the specified entry from the heap." } { $errors "Throws an error if the entry is from another heap or if it has already been deleted." } { $side-effects "heap" } ; HELP: slurp-heap { $values - { "heap" "a heap" } { "quot" quotation } } + { "heap" heap } { "quot" quotation } } { $description "Removes values from a heap and processes them with the quotation until the heap is empty." } ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 6193d9fa2c..dccf1e5e55 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -64,14 +64,15 @@ M: heap heap-size ( heap -- n ) [ right ] dip data-nth ; inline : data-set-nth ( entry n heap -- ) - [ [ >>index drop ] [ ] 2bi ] dip + [ [ swap index<< ] 2keep ] dip data>> set-nth-unsafe ; inline : data-push ( entry heap -- n ) dup heap-size [ - swap 2dup data>> ensure 2drop data-set-nth - ] [ - ] bi ; inline + swap + [ data>> ensure 2drop ] + [ data-set-nth ] 2bi + ] keep ; inline : data-first ( heap -- entry ) data>> first ; inline @@ -82,12 +83,11 @@ M: heap heap-size ( heap -- n ) GENERIC: heap-compare ( entry1 entry2 heap -- ? ) -: (heap-compare) ( entry1 entry2 heap -- <=> ) - drop [ key>> ] compare ; inline +M: min-heap heap-compare + drop { entry entry } declare [ key>> ] bi@ after? ; inline -M: min-heap heap-compare (heap-compare) +gt+ eq? ; - -M: max-heap heap-compare (heap-compare) +lt+ eq? ; +M: max-heap heap-compare + drop { entry entry } declare [ key>> ] bi@ before? ; inline : heap-bounds-check? ( m heap -- ? ) heap-size >= ; inline @@ -135,12 +135,13 @@ DEFER: down-heap ] if ; inline recursive : down-heap ( m heap -- ) - 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; inline recursive + 2dup left-bounds-check? + [ 2drop ] [ (down-heap) ] if ; inline recursive PRIVATE> M: heap heap-push* ( value key heap -- entry ) - [ dup ] [ data-push ] [ ] tri up-heap ; + [ dup ] [ data-push ] [ up-heap ] tri ; : heap-push ( value key heap -- ) heap-push* drop ; @@ -163,22 +164,20 @@ M: bad-heap-delete summary index>> { fixnum } declare ; inline M: heap heap-delete ( entry heap -- ) - [ entry>index ] [ ] bi + [ entry>index ] keep 2dup heap-size 1 - = [ nip data>> pop* ] [ [ nip data>> pop ] [ data-set-nth ] - [ ] 2tri - down-heap + [ down-heap ] 2tri ] if ; M: heap heap-pop* ( heap -- ) [ data-first ] keep heap-delete ; M: heap heap-pop ( heap -- value key ) - [ data-first ] keep - [ heap-delete ] [ drop ] 2bi >entry< ; + [ data-first dup ] keep heap-delete >entry< ; : heap-pop-all ( heap -- alist ) [ dup heap-empty? not ] @@ -198,5 +197,5 @@ ERROR: not-a-heap obj ; : >min-heap ( assoc -- min-heap ) [ heap-push-all ] keep ; -: >max-heap ( assoc -- min-heap ) +: >max-heap ( assoc -- max-heap ) [ heap-push-all ] keep ; diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index a10d49f6f7..f7a6133d97 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -239,10 +239,8 @@ command-line get [ "Now, the " { $snippet "grep.factor" } " script will start up much faster. See " { $link "images" } " for details." { $heading "Executable scripts" } "It is also possible to make executable scripts. A Factor file can begin with a comment like the following:" -{ $code "#! /usr/bin/env factor" } +{ $code "#!/usr/bin/env factor" } "If the text file is made executable, then it can be run, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "." -$nl -"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result." { $references { } "command-line" diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index bc1cbd7f64..9b0528080a 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -1,6 +1,6 @@ -USING: help.markup help.crossref help.stylesheet help.topics -help.syntax definitions io prettyprint summary arrays math -sequences vocabs strings see ; +USING: arrays help.crossref help.markup help.stylesheet +help.syntax help.topics io kernel math prettyprint quotations +see sequences strings summary vocabs ; IN: help ARTICLE: "printing-elements" "Printing markup elements" @@ -239,11 +239,11 @@ HELP: simple-element { $class-description "Class of simple elements, which are just arrays of elements." } ; HELP: ($span) -{ $values { "quot" "a quotation" } } +{ $values { "quot" quotation } } { $description "Prints an inline markup element." } ; HELP: ($block) -{ $values { "quot" "a quotation" } } +{ $values { "quot" quotation } } { $description "Prints a block markup element with newlines before and after." } ; HELP: $heading @@ -340,7 +340,7 @@ HELP: $link } ; HELP: textual-list -{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- )" } } } +{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ) } } } { $description "Applies the quotation to each element of the sequence, printing a comma between each pair of elements." } { $examples { $example "USING: help.markup io namespaces ;" "last-element off" "{ \"fish\" \"chips\" \"salt\" } [ write ] textual-list" "fish, chips, salt" } @@ -406,7 +406,7 @@ HELP: $quotation "Produces the text “a quotation with stack effect " { $emphasis "effect" } "”." } { $examples - { $markup-example { $quotation "( obj -- )" } } + { $markup-example { $quotation ( obj -- ) } } } ; HELP: $list @@ -487,7 +487,7 @@ HELP: HELP: HELP: ARTICLE: { $syntax "ARTICLE: topic title content... ;" } -{ $values { "topic" "an object" } { "title" "a string" } { "content" "markup elements" } } +{ $values { "topic" object } { "title" string } { "content" "markup elements" } } { $description "Defines a help article. String topic names are reserved for core documentation. Contributed modules should name articles by arrays, where the first element of an array identifies the module; for example, " { $snippet "{ \"httpd\" \"intro\" }" } "." } { $examples { $code diff --git a/basis/help/help.factor b/basis/help/help.factor index 60cba2fc88..afbcc7c849 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -16,7 +16,7 @@ GENERIC: word-help* ( word -- content ) ] ?if ; : $predicate ( element -- ) - { { "object" object } { "?" "a boolean" } } $values + { { "object" object } { "?" boolean } } $values [ "Tests if the object is an instance of the " , first "predicating" word-prop <$link> , diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index dc8bacc8e0..7930f165b6 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs debugger fry hashtables help -help.home help.topics help.vocabs html html.streams -io.directories io.encodings.binary io.encodings.utf8 io.files -io.files.temp io.pathnames kernel make math.parser memoize -namespaces sequences serialize sorting splitting unicode.case -vocabs vocabs.hierarchy words xml.syntax xml.writer ; +USING: accessors arrays assocs debugger fry help help.home +help.topics help.vocabs html html.streams io.directories +io.encodings.binary io.encodings.utf8 io.files io.files.temp +io.pathnames kernel make math.parser memoize namespaces +sequences serialize splitting tools.completion vocabs +vocabs.hierarchy words xml.syntax xml.writer ; FROM: io.encodings.ascii => ascii ; FROM: ascii => ascii? ; IN: help.html @@ -47,7 +47,7 @@ M: vocab-author topic>filename* name>> "author" ; M: f topic>filename* drop \ f topic>filename* ; : topic>filename ( topic -- filename ) - topic>filename* dup [ + topic>filename* [ [ % "-" % dup array? @@ -55,7 +55,7 @@ M: f topic>filename* drop \ f topic>filename* ; [ escape-filename ] if % ".html" % ] "" make - ] [ 2drop f ] if ; + ] [ drop f ] if* ; M: topic url-of topic>filename ; @@ -98,7 +98,7 @@ M: pathname url-of dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; : all-vocabs-really ( -- seq ) - all-vocabs-recursive >hashtable no-roots remove-redundant-prefixes + all-vocabs-recursive no-roots remove-redundant-prefixes [ vocab-name "scratchpad" = not ] filter ; : all-topics ( -- topics ) @@ -111,16 +111,26 @@ M: pathname url-of ] { } make ; : serialize-index ( index file -- ) - [ [ [ topic>filename ] dip ] { } assoc-map-as object>bytes ] dip - binary set-file-contents ; + binary [ + [ [ topic>filename ] dip ] { } assoc-map-as serialize + ] with-file-writer ; + +: generate-article-index ( -- ) + articles get [ [ >link ] [ article-title ] bi* ] assoc-map + "articles.idx" serialize-index ; + +: generate-word-index ( -- ) + all-words [ dup name>> ] { } map>assoc + "words.idx" serialize-index ; + +: generate-vocab-index ( -- ) + all-vocabs-really [ dup vocab-name ] { } map>assoc + "vocabs.idx" serialize-index ; : generate-indices ( -- ) - articles get keys [ [ >link ] [ article-title ] bi ] { } map>assoc "articles.idx" serialize-index - all-words [ dup name>> ] { } map>assoc "words.idx" serialize-index - all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ; - -: (generate-help-files) ( -- ) - all-topics [ '[ _ generate-help-file ] try ] each ; + generate-article-index + generate-word-index + generate-vocab-index ; : generate-help-files ( -- ) H{ @@ -128,7 +138,9 @@ M: pathname url-of { recent-words f } { recent-articles f } { recent-vocabs f } - } [ (generate-help-files) ] with-variables ; + } [ + all-topics [ '[ _ generate-help-file ] try ] each + ] with-variables ; : generate-help ( -- ) "docs" cache-file @@ -143,17 +155,8 @@ M: pathname url-of MEMO: load-index ( name -- index ) binary file-contents bytes>object ; -TUPLE: result title href ; - -: partition-exact ( string results -- results' ) - [ title>> = ] with partition append ; - : offline-apropos ( string index -- results ) - load-index over >lower - '[ [ drop _ ] dip >lower subseq? ] assoc-filter - [ swap result boa ] { } assoc>map - [ title>> ] sort-with - partition-exact ; + load-index completions ; : article-apropos ( string -- results ) "articles.idx" offline-apropos ; diff --git a/basis/help/lint/checks/checks-docs.factor b/basis/help/lint/checks/checks-docs.factor new file mode 100644 index 0000000000..640337aec1 --- /dev/null +++ b/basis/help/lint/checks/checks-docs.factor @@ -0,0 +1,18 @@ +USING: help.markup help.syntax sequences words ; +IN: help.lint.checks + +HELP: check-example +{ $values { "element" sequence } } +{ $description "Throws an error if the expected output from the $example is different from the expected, or if it leaks disposables." } ; + +HELP: check-values +{ $values { "word" word } { "element" sequence } } +{ $description "Throws an error if the $values pair doesnt match the declared stack effect." } +{ $examples + { $unchecked-example + "USING: help.lint.checks math ;" + ": foo ( x -- y ) ;" + "\\ foo { $values { \"a\" number } { \"b\" number } } check-values" + "$values don't match stack effect; expected { \"x\" \"y\" }, got { \"a\" \"b\" }\n\nType :help for debugging help." + } +} ; diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor index b7cb680e87..a916a1bdcb 100644 --- a/basis/help/lint/checks/checks.factor +++ b/basis/help/lint/checks/checks.factor @@ -1,11 +1,12 @@ ! 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 vocabs vocabs.loader words -words.symbol summary debugger io ; +USING: accessors arrays assocs classes classes.struct +classes.tuple combinators combinators.short-circuit debugger +definitions effects eval formatting fry grouping help +help.markup help.topics io io.streams.string kernel macros +namespaces sequences sequences.deep sets splitting strings +summary unicode.categories vocabs vocabs.loader words +words.constant words.symbol ; FROM: sets => members ; IN: help.lint.checks @@ -20,31 +21,34 @@ SYMBOL: all-vocabs SYMBOL: vocab-articles : check-example ( element -- ) - '[ - _ rest [ - but-last "\n" join - [ (eval>string) ] call( code -- output ) - "\n" ?tail drop - ] keep - last assert= - ] vocabs-quot get call( quot -- ) ; + ! [ + '[ + _ rest [ + but-last "\n" join + [ (eval>string) ] call( code -- output ) + "\n" ?tail drop + ] keep + last assert= + ] vocabs-quot get call( quot -- ) ; + ! ] leaks members length [ + ! "%d disposable(s) leaked in example" sprintf simple-lint-error + ! ] unless-zero ; : check-examples ( element -- ) \ $example swap elements [ check-example ] each ; : extract-values ( element -- seq ) - \ $values swap elements dup empty? [ - first rest keys - ] unless ; + \ $values swap elements + [ f ] [ first rest keys ] if-empty ; : extract-value-effects ( element -- seq ) - \ $values swap elements dup empty? [ - first rest [ - \ $quotation swap elements dup empty? [ drop f ] [ - first second - ] if + \ $values swap elements [ f ] [ + first rest [ + \ $quotation swap elements [ f ] [ + first second dup effect? [ effect>string ] when + ] if-empty ] map - ] unless ; + ] if-empty ; : effect-values ( word -- seq ) stack-effect @@ -74,27 +78,27 @@ SYMBOL: vocab-articles [ symbol? ] [ parsing-word? ] [ "declared-effect" word-prop not ] + [ constant? ] } 1|| ; +: skip-check-values? ( word element -- ? ) + [ don't-check-word? ] [ contains-funky-elements? ] bi* or ; + : 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 ; + 2dup skip-check-values? [ 2drop ] [ + [ effect-values ] [ extract-values ] bi* 2dup + sequence= [ 2drop ] [ + "$values don't match stack effect; expected %u, got %u" sprintf + simple-lint-error + ] if + ] if ; : check-value-effects ( word element -- ) - [ effect-effects ] - [ extract-value-effects ] - bi* [ 2dup and [ = ] [ 2drop t ] if ] 2all? - [ "$quotation documentation in $values don't match stack effect" simple-lint-error ] - unless ; + [ effect-effects ] [ extract-value-effects ] bi* + [ 2dup and [ = ] [ 2drop t ] if ] 2all? [ + "$quotation stack effects in $values don't match" + simple-lint-error + ] unless ; : check-nulls ( element -- ) \ $values swap elements @@ -102,9 +106,8 @@ SYMBOL: vocab-articles [ "$values should not contain null" simple-lint-error ] when ; : check-see-also ( element -- ) - \ $see-also swap elements [ - rest all-unique? t assert= - ] each ; + \ $see-also swap elements [ rest all-unique? ] all? + [ "$see-also are not unique" simple-lint-error ] unless ; : vocab-exists? ( name -- ? ) [ lookup-vocab ] [ all-vocabs get member? ] bi or ; @@ -144,10 +147,26 @@ SYMBOL: vocab-articles simple-lint-error ] when ; +: extract-slots ( elements -- seq ) + [ dup pair? [ first \ $slot = ] [ drop f ] if ] deep-filter + [ second ] map ; + : 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 ; + \ $class-description swap elements over class? [ + [ + dup struct-class? [ struct-slots ] [ all-slots ] if + [ name>> ] map + ] [ extract-slots ] bi* + [ swap member? not ] with filter [ + ", " join "Described $slot does not exist: " prepend + simple-lint-error + ] unless-empty + ] [ + nip empty? not [ + "A word that is not a class has a $class-description" + simple-lint-error + ] when + ] if ; : check-article-title ( article -- ) article-title first LETTER? diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 7e8c2e8c94..890445f442 100644 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -67,7 +67,7 @@ PRIVATE> ] check-something ; : check-about ( vocab -- ) - vocab-link boa dup + dup '[ _ vocab-help [ lookup-article drop ] when* ] check-something ; : check-vocab ( vocab -- ) @@ -100,5 +100,3 @@ PRIVATE> [ word-help not ] filter [ article-parent ] filter [ predicate? not ] filter ; - -MAIN: help-lint diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index f4a000ac64..eba7bfed52 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -43,6 +43,7 @@ M: simple-element print-element [ print-element ] each ; M: string print-element [ write ] ($span) ; M: array print-element unclip execute( arg -- ) ; M: word print-element { } swap execute( arg -- ) ; +M: effect print-element effect>string print-element ; M: f print-element drop ; : print-element* ( element style -- ) diff --git a/basis/help/search/summary b/basis/help/search/summary.txt similarity index 100% rename from basis/help/search/summary rename to basis/help/search/summary.txt diff --git a/basis/help/topics/topics-docs.factor b/basis/help/topics/topics-docs.factor index 82cf78e70d..74dd405806 100644 --- a/basis/help/topics/topics-docs.factor +++ b/basis/help/topics/topics-docs.factor @@ -1,5 +1,5 @@ -USING: help.markup help.syntax help.crossref help io io.styles -hashtables strings ; +USING: help help.crossref help.markup help.syntax io.styles +sequences strings words ; IN: help.topics HELP: articles @@ -23,11 +23,11 @@ HELP: article-content { $description "Outputs the content of a specific help article." } ; HELP: all-articles -{ $values { "seq" "a sequence" } } +{ $values { "seq" sequence } } { $description "Outputs a sequence of all help article names, and all words with documentation." } ; HELP: elements -{ $values { "elt-type" "a word" } { "element" "a markup element" } { "seq" "a new sequence" } } +{ $values { "elt-type" word } { "element" "a markup element" } { "seq" "a new sequence" } } { $description "Outputs a sequence of all elements of type " { $snippet "elt-type" } " found by traversing " { $snippet "element" } "." } ; HELP: collect-elements diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index 322b92eee3..995fcbca52 100644 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -17,6 +17,7 @@ INSTANCE: word topic GENERIC: >link ( obj -- obj ) M: link >link ; +M: wrapper >link wrapped>> >link ; M: vocab-spec >link ; M: object >link link boa ; M: f >link drop \ f >link ; @@ -33,7 +34,7 @@ M: link summary SYMBOL: articles articles [ H{ } clone ] initialize - + SYMBOL: article-xref article-xref [ H{ } clone ] initialize diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index abdaf77e78..a87f005e35 100644 --- a/basis/help/tutorial/tutorial.factor +++ b/basis/help/tutorial/tutorial.factor @@ -113,7 +113,15 @@ $nl "Now, you can run unit tests:" { $code "\"palindrome\" test" } $nl -"It should report that all tests have passed. Now you can read about " { $link "first-program-extend" } "." ; +"It should report that all your tests have been run and there were no test failures, displaying the following output:" +$nl +{ $snippet + "Unit Test: { [ f ] [ \"hello\" palindrome? ] }" + "\n" + "Unit Test: { [ t ] [ \"racecar\" palindrome? ] }" +} +$nl +"Now you can read about " { $link "first-program-extend" } "." ; ARTICLE: "first-program-extend" "Extending your first program" "Our palindrome program works well, however we'd like to extend it to ignore spaces and non-alphabetical characters in the input." diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index cb2fb94dff..9177b81cd9 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -119,7 +119,7 @@ set-specializer \ member? { { array } { string } } set-specializer -\ member-eq? { array } set-specializer +\ member-eq? { { array } { string } } set-specializer \ assoc-stack { vector } set-specializer @@ -128,6 +128,10 @@ set-specializer set-specializer ] each +{ le> be> } [ + { byte-array } set-specializer +] each + \ base> { string fixnum } set-specializer M\ hashtable at* diff --git a/basis/html/forms/forms-docs.factor b/basis/html/forms/forms-docs.factor index 9203ad31ae..bc678191ba 100644 --- a/basis/html/forms/forms-docs.factor +++ b/basis/html/forms/forms-docs.factor @@ -1,5 +1,6 @@ +USING: assocs help.markup help.syntax kernel quotations strings +; IN: html.forms -USING: help.markup help.syntax strings quotations kernel assocs ; HELP:
{ $values { "form" form } } @@ -78,7 +79,7 @@ HELP: with-each-object { $notes "This word is used to implement the " { $snippet "t:bind-each" } " tag of the " { $vocab-link "html.templates.chloe" } " templating system. It can also be called directly from " { $vocab-link "html.templates.fhtml" } " templates." } ; HELP: validation-failed? -{ $values { "?" "a boolean" } } +{ $values { "?" boolean } } { $description "Tests if validation of the current form failed." } ; HELP: validate-values diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index 7b5f6bc619..8ec925fc7d 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -25,7 +25,7 @@ HELP: compile-attr HELP: CHLOE: { $syntax "CHLOE: name definition... ;" } -{ $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } } +{ $values { "name" "the tag name" } { "definition" { $quotation ( tag -- ) } } } { $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ; HELP: COMPONENT: @@ -47,7 +47,7 @@ HELP: [code] { $description "Compiles the quotation. It will be called when the template is called." } ; HELP: process-children -{ $values { "tag" tag } { "quot" { $quotation "( compiled-tag -- )" } } } +{ $values { "tag" tag } { "quot" { $quotation ( compiled-tag -- ) } } } { $description "Compiles the tag. The quotation will be applied to the resulting quotation when the template is called." } { $examples "See " { $link "html.templates.chloe.extend.tags.example" } " for an example which uses this word to implement a custom control flow tag." } ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index 0fd8024747..b6d960841e 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2005 Alex Chapman ! Copyright (C) 2006, 2010 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: continuations sequences kernel namespaces debugger -combinators math quotations generic strings splitting accessors -assocs fry vocabs.parser parser parser.notes lexer io io.files -io.streams.string io.encodings.utf8 html.templates compiler.units ; +USING: accessors combinators compiler.units html.templates io +io.encodings.utf8 io.files kernel lexer math namespaces parser +parser.notes quotations sequences splitting vocabs.parser ; IN: html.templates.fhtml ! We use a custom lexer so that %> ends a token even if not diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 437f595deb..3628f9942b 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -5,7 +5,7 @@ http.client.post-data.private io.encodings.8-bit.latin1 ; IN: http.client HELP: download-failed -{ $error-description "Thrown by " { $link http-request } " if the server returns a status code other than 200. The " { $slot "response" } " and " { $slot "body" } " slots can be inspected for the underlying cause of the problem." } ; +{ $error-description "Thrown by " { $link http-request } " if the server returns a status code other than 200. The " { $slot "response" } " slot can be inspected for the underlying cause of the problem." } ; HELP: too-many-redirects { $error-description "Thrown by " { $link http-request } " if the server returns a chain of than " { $link max-redirects } " redirections." } ; @@ -50,72 +50,129 @@ HELP: download-to { $description "Downloads the contents of the URL to a file with the given pathname." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: ?download-to +{ $values { "url" "a " { $link url } " or " { $link string } } { "file" "a pathname string" } } +{ $description "Version of " { $link download-to } " that only downloads if " { $snippet "file" } " does not exist." } +{ $errors "Throws an error if the HTTP request fails." } ; + HELP: http-get { $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } { $description "Downloads the contents of a URL." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: http-get* +{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } +{ $description "Downloads the contents of a URL, but does not check the HTTP response code for success." } ; + +{ http-get http-get* } related-words + HELP: http-post { $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } { $description "Submits an HTTP POST request." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: http-post* +{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } +{ $description "Submits an HTTP POST request, but does not check the HTTP response code for success." } ; + +{ http-post http-post* } related-words + HELP: http-put { $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } { $description "Submits an HTTP PUT request." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: http-put* +{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } +{ $description "Submits an HTTP PUT request, but does not check the HTTP response code for success." } ; + +{ http-put http-put* } related-words + HELP: http-head { $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } { $description "Same as " { $link http-get } " except that the server is not supposed to return a message-body in the response, as per RFC2616. However in practise, most web servers respond to GET and HEAD method calls with identical responses." } { $errors "Throws an error if the HTTP request fails." } ; - + +HELP: http-head* +{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } +{ $description "Same as " { $link http-get* } " except that the server is not supposed to return a message-body in the response, as per RFC2616. However in practise, most web servers respond to GET and HEAD method calls with identical responses." } ; + +{ http-head http-head* } related-words + HELP: http-delete { $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } { $description "Requests that the origin server delete the resource identified by the URL." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: http-delete* +{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } +{ $description "Requests that the origin server delete the resource identified by the URL, but does not check the HTTP response code for success." } ; + +{ http-delete http-delete* } related-words + HELP: http-options { $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } { $description "Submits an HTTP OPTIONS request." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: http-options* +{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } +{ $description "Submits an HTTP OPTIONS request, but does not check the HTTP response code for success." } ; + +{ http-options http-options* } related-words + HELP: http-trace { $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } { $description "Submits an HTTP TRACE request." } { $errors "Throws an error if the HTTP request fails." } ; -HELP: with-http-get -{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" { $quotation "( chunk -- )" } } { "response" response } } -{ $description "Downloads the contents of a URL. Chunks of data are passed to the quotation as they are read." } -{ $errors "Throws an error if the HTTP request fails." } ; +HELP: http-trace* +{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } +{ $description "Submits an HTTP TRACE request, but does not check the HTTP response code for success." } ; + +{ http-trace http-trace* } related-words HELP: http-request { $values { "request" request } { "response" response } { "data" sequence } } -{ $description "Sends an HTTP request to an HTTP server, and reads the response." } +{ $description "A variant of " { $link http-request* } " that checks that the response was successful." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: http-request* +{ $values { "request" request } { "response" response } { "data" sequence } } +{ $description "Sends an HTTP request to an HTTP server, and reads the response." } ; + HELP: with-http-request -{ $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } } +{ $values { "request" request } { "quot" { $quotation ( chunk -- ) } } { "response" response } } +{ $description "A variant of " { $link with-http-request* } " that checks that the response was successful." } ; + +HELP: with-http-request* +{ $values { "request" request } { "quot" { $quotation ( chunk -- ) } } { "response" response } } { $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ; +{ http-request http-request* with-http-request with-http-request* } related-words + ARTICLE: "http.client.get" "GET requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" -{ $subsections http-get } +{ $subsections + http-get + http-get* +} "Utilities to retrieve a " { $link url } " and save the contents to a file:" { $subsections download download-to + ?download-to } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" { $subsections http-request + http-request* } -"The " { $link http-get } " and " { $link http-request } " words output sequences. This is undesirable if the response data may be large. Another pair of words take a quotation instead, and pass the quotation chunks of data incrementally:" +"The " { $link http-request } " and " { $link http-request* } " words output sequences. This is undesirable if the response data may be large. Another pair of words take a quotation instead, and pass the quotation chunks of data incrementally:" { $subsections - with-http-get with-http-request + with-http-request* } ; ARTICLE: "http.client.post-data" "HTTP client post data" @@ -138,21 +195,21 @@ ARTICLE: "http.client.post-data" "HTTP client 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:" -{ $subsections http-post } +{ $subsections http-post http-post* } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" { $subsections } "Both words take a post data parameter; see " { $link "http.client.post-data" } "." ; ARTICLE: "http.client.put" "PUT requests with the HTTP client" "Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:" -{ $subsections http-put } +{ $subsections http-put http-put* } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" { $subsections } "Both words take a post data parameter; see " { $link "http.client.post-data" } "." ; ARTICLE: "http.client.head" "HEAD requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" -{ $subsections http-head } +{ $subsections http-head http-head* } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" { $subsections @@ -160,7 +217,7 @@ ARTICLE: "http.client.head" "HEAD requests with the HTTP client" ARTICLE: "http.client.delete" "DELETE requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" -{ $subsections http-delete } +{ $subsections http-delete http-delete* } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" { $subsections @@ -168,7 +225,7 @@ ARTICLE: "http.client.delete" "DELETE requests with the HTTP client" ARTICLE: "http.client.options" "OPTIONS requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" -{ $subsections http-options } +{ $subsections http-options http-options* } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" { $subsections @@ -177,7 +234,7 @@ ARTICLE: "http.client.options" "OPTIONS requests with the HTTP client" ARTICLE: "http.client.trace" "TRACE requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" -{ $subsections http-trace } +{ $subsections http-trace http-trace* } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" { $subsections diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 7f99c62984..0edcacb7b1 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -1,14 +1,12 @@ ! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs combinators.short-circuit kernel math math.parser -namespaces make sequences strings splitting calendar -continuations accessors vectors math.order hashtables -byte-arrays destructors io io.sockets io.streams.string io.files -io.timeouts io.pathnames io.encodings io.encodings.string -io.encodings.ascii io.encodings.utf8 io.encodings.binary -io.encodings.iana io.crlf io.streams.duplex fry ascii urls -urls.encoding present locals http http.parsers -http.client.post-data mime.types ; +USING: accessors ascii assocs calendar combinators.short-circuit +destructors fry hashtables http http.client.post-data +http.parsers io io.crlf io.encodings io.encodings.ascii +io.encodings.binary io.encodings.iana io.encodings.string +io.files io.pathnames io.sockets io.timeouts kernel locals math +math.order math.parser mime.types namespaces present sequences +splitting urls vocabs.loader ; IN: http.client ERROR: too-many-redirects ; @@ -140,10 +138,16 @@ SYMBOL: redirects [ do-redirect ] [ nip ] if ] with-variable ; inline recursive +: request-url ( url -- url' ) + dup >url dup protocol>> [ nip ] [ + drop dup url? [ present ] when + "http://" prepend >url + ] if ensure-port ; + : ( url method -- request ) swap >>method - swap >url ensure-port >>url ; inline + swap request-url >>url ; inline PRIVATE> @@ -154,15 +158,18 @@ ERROR: download-failed response ; : check-response ( response -- response ) dup code>> success? [ download-failed ] unless ; -: check-response-with-body ( response body -- response body ) - [ >>body check-response ] keep ; - -: with-http-request ( request quot -- response ) +: with-http-request* ( request quot: ( chunk -- ) -- response ) [ (with-http-request) ] with-destructors ; inline +: with-http-request ( request quot: ( chunk -- ) -- response ) + with-http-request* check-response ; inline + +: http-request* ( request -- response data ) + BV{ } clone [ '[ _ push-all ] with-http-request* ] keep + B{ } like over content-encoding>> decode [ >>body ] keep ; + : http-request ( request -- response data ) - [ [ % ] with-http-request ] B{ } make - over content-encoding>> decode check-response-with-body ; + http-request* [ check-response ] dip ; : ( url -- request ) "GET" ; @@ -170,14 +177,19 @@ ERROR: download-failed response ; : http-get ( url -- response data ) http-request ; -: with-http-get ( url quot -- response ) - [ ] dip with-http-request ; inline +: http-get* ( url -- response data ) + http-request* ; : download-name ( url -- name ) present file-name "?" split1 drop "/" ?tail drop ; : download-to ( url file -- ) - binary [ [ write ] with-http-get check-response drop ] with-file-writer ; + binary [ + [ write ] with-http-request drop + ] with-file-writer ; + +: ?download-to ( url file -- ) + dup exists? [ 2drop ] [ download-to ] if ; : download ( url -- ) dup download-name download-to ; @@ -189,6 +201,9 @@ ERROR: download-failed response ; : http-post ( post-data url -- response data ) http-request ; +: http-post* ( post-data url -- response data ) + http-request* ; + : ( post-data url -- request ) "PUT" swap >>post-data ; @@ -196,30 +211,43 @@ ERROR: download-failed response ; : http-put ( post-data url -- response data ) http-request ; +: http-put* ( post-data url -- response data ) + http-request* ; + : ( url -- request ) "DELETE" ; : http-delete ( url -- response data ) http-request ; +: http-delete* ( url -- response data ) + http-request* ; + : ( url -- request ) "HEAD" ; : http-head ( url -- response data ) http-request ; +: http-head* ( url -- response data ) + http-request* ; + : ( url -- request ) "OPTIONS" ; : http-options ( url -- response data ) http-request ; +: http-options* ( url -- response data ) + http-request* ; + : ( url -- request ) "TRACE" ; : http-trace ( url -- response data ) http-request ; -USE: vocabs.loader +: http-trace* ( url -- response data ) + http-request* ; { "http.client" "debugger" } "http.client.debugger" require-when diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index d9a4e36a57..94a0fa7728 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -1,5 +1,5 @@ -USING: http http.server http.client http.client.private tools.test -multiline io.streams.string io.encodings.utf8 io.encodings.8-bit +USING: destructors http http.server http.client http.client.private tools.test +multiline fry 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 make continuations urls hashtables accessors namespaces xml.data @@ -221,17 +221,6 @@ http.server.dispatchers db.tuples ; : test-db ( -- db ) test-db-file ; -: test-httpd ( responder -- ) - [ - main-responder set - - 0 >>insecure - f >>secure - start-server - threaded-server set - server-addrs random - ] with-scope "addr" set ; - : add-addr ( url -- url' ) >url clone "addr" get set-url-addr ; @@ -247,66 +236,62 @@ http.server.dispatchers db.tuples ; ] with-db ] unit-test -[ ] [ +: test-with-dispatcher ( dispatcher quot -- ) + '[ + main-responder set + 0 >>insecure f >>secure + [ + server-addrs random "addr" set @ + ] with-threaded-server + ] with-scope ; inline + +USING: locals ; + +:: test-with-db-persistence ( db-persistence quot -- ) + db-persistence [ + quot test-with-dispatcher + ] with-disposal ; inline + + + add-quit-action - add-quit-action - - "vocab:http/test" >>default - "nested" add-responder - - [ URL" redirect-loop" ] >>display - "redirect-loop" add-responder + "vocab:http/test" >>default + "nested" add-responder + + [ URL" redirect-loop" ] >>display + "redirect-loop" add-responder [ - test-httpd -] unit-test + [ t ] [ + "vocab:http/test/foo.html" ascii file-contents + "http://localhost/nested/foo.html" add-addr http-get nip = + ] unit-test -[ t ] [ - "vocab:http/test/foo.html" ascii file-contents - "http://localhost/nested/foo.html" add-addr http-get nip = -] unit-test + [ "http://localhost/redirect-loop" add-addr http-get nip ] + [ too-many-redirects? ] must-fail-with -[ "http://localhost/redirect-loop" add-addr http-get nip ] -[ too-many-redirects? ] must-fail-with + [ "Goodbye" ] [ + "http://localhost/quit" add-addr http-get nip + ] unit-test -[ "Goodbye" ] [ - "http://localhost/quit" add-addr http-get nip -] unit-test +] test-with-dispatcher ! HTTP client redirect bug -[ ] [ - - add-quit-action - [ "quit" ] >>display - "redirect" add-responder + + add-quit-action + [ "quit" ] >>display + "redirect" add-responder [ - test-httpd -] unit-test + [ "Goodbye" ] [ + "http://localhost/redirect" add-addr http-get nip + ] unit-test -[ "Goodbye" ] [ - "http://localhost/redirect" add-addr http-get nip -] unit-test + [ ] [ + [ stop-test-httpd ] ignore-errors + ] unit-test - -[ ] [ - [ stop-test-httpd ] ignore-errors -] unit-test +] test-with-dispatcher ! Dispatcher bugs -[ ] [ - - - "Test" - - "" add-responder - add-quit-action - - "" add-responder - "d" add-responder - test-db - - test-httpd -] unit-test - : 404? ( response -- ? ) { [ download-failed? ] @@ -314,29 +299,40 @@ http.server.dispatchers db.tuples ; [ response>> code>> 404 = ] } 1&& ; -! This should give a 404 not an infinite redirect loop -[ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with - -! This should give a 404 not an infinite redirect loop -[ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with - -[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test - -[ ] [ + + + "Test" + + "" add-responder + add-quit-action - [ [ "Hi" write ] "text/plain" ] >>display - "Test" - - "" add-responder - add-quit-action - test-db + "" add-responder + "d" add-responder +test-db [ - test-httpd -] unit-test + ! This should give a 404 not an infinite redirect loop + [ "http://localhost/d/blah" add-addr http-get nip ] [ 404? ] must-fail-with -[ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test + ! This should give a 404 not an infinite redirect loop + [ "http://localhost/blah/" add-addr http-get nip ] [ 404? ] must-fail-with -[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test + [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test + +] test-with-db-persistence + + + [ [ "Hi" write ] "text/plain" ] >>display + "Test" + + "" add-responder + add-quit-action +test-db [ + + [ "Hi" ] [ "http://localhost/" add-addr http-get nip ] unit-test + + [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test + +] test-with-db-persistence USING: html.components html.forms xml xml.traversal validators @@ -344,126 +340,122 @@ furnace furnace.conversations ; SYMBOL: a -[ ] [ - - - [ a get-global "a" set-value ] >>init - [ [ "" write "a" render "" write ] "text/html" ] >>display - [ { { "a" [ v-integer ] } } validate-params ] >>validate - [ "a" value a set-global URL" " ] >>submit - - - >>default - add-quit-action - test-db - - test-httpd -] unit-test - -3 a set-global - : test-a ( xml -- value ) string>xml body>> "input" deep-tag-named "value" attr ; -[ "3" ] [ - "http://localhost/" add-addr http-get - swap dup cookies>> "cookies" set session-id-key get-cookie - value>> "session-id" set test-a -] unit-test + + + [ a get-global "a" set-value ] >>init + [ [ "" write "a" render "" write ] "text/html" ] >>display + [ { { "a" [ v-integer ] } } validate-params ] >>validate + [ "a" value a set-global URL" " ] >>submit + + + >>default + add-quit-action +test-db [ -[ "4" ] [ - [ - "4" "a" ,, - "http://localhost" add-addr "__u" ,, - "session-id" get session-id-key ,, - ] H{ } make - "http://localhost/" add-addr "cookies" get >>cookies http-request nip test-a -] unit-test + 3 a set-global -[ 4 ] [ a get-global ] unit-test + [ "3" ] [ + "http://localhost/" add-addr http-get + swap dup cookies>> "cookies" set session-id-key get-cookie + value>> "session-id" set test-a + ] unit-test -! Test flash scope -[ "xyz" ] [ - [ - "xyz" "a" ,, - "http://localhost" add-addr "__u" ,, - "session-id" get session-id-key ,, - ] H{ } make - "http://localhost/" add-addr "cookies" get >>cookies http-request nip test-a -] unit-test + [ "4" ] [ + [ + "4" "a" ,, + "http://localhost" add-addr "__u" ,, + "session-id" get session-id-key ,, + ] H{ } make + "http://localhost/" add-addr "cookies" get >>cookies + http-request nip test-a + ] unit-test -[ 4 ] [ a get-global ] unit-test + [ 4 ] [ a get-global ] unit-test -[ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test + ! Test flash scope + [ "xyz" ] [ + [ + "xyz" "a" ,, + "http://localhost" add-addr "__u" ,, + "session-id" get session-id-key ,, + ] H{ } make + "http://localhost/" add-addr "cookies" get >>cookies + http-request nip test-a + ] unit-test + + [ 4 ] [ a get-global ] unit-test + + [ "Goodbye" ] [ "http://localhost/quit" add-addr http-get nip ] unit-test + +] test-with-db-persistence ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test [ f ] [ <404> dup clone "b" "a" put-cookie drop "a" get-cookie ] unit-test ! Test basic auth -[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test +[ "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 + + add-quit-action + "vocab:http/test/foo.html" >>default [ + [ t ] [ + "http://localhost/" add-addr http-get nip + "vocab:http/test/foo.html" ascii file-contents = + ] unit-test -[ t ] [ - "http://localhost/" add-addr http-get nip - "vocab:http/test/foo.html" ascii file-contents = -] unit-test + [ ] [ stop-test-httpd ] unit-test -[ ] [ stop-test-httpd ] unit-test +] test-with-dispatcher ! 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 + + add-quit-action + + [ "b" ] >>submit + "a" add-responder + + [ + request get post-data>> data>> "data" = + [ "OK" "text/plain" ] [ "OOPS" throw ] if + ] >>submit + "b" add-responder [ -[ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test + [ "OK" ] [ "data" "http://localhost/a" add-addr http-post nip ] unit-test -! Check that download throws errors (reported by Chris Double) -[ + ! Check that download throws errors (reported by Chris Double) [ - "http://localhost/tweet_my_twat" add-addr download - ] with-temp-directory -] must-fail + [ + "http://localhost/tweet_my_twat" add-addr download + ] with-temp-directory + ] must-fail -[ ] [ stop-test-httpd ] unit-test + [ ] [ stop-test-httpd ] unit-test + +] test-with-dispatcher ! Check that index.fhtml works -[ ] [ - - "resource:basis/http/test/" enable-fhtml >>default - add-quit-action - test-httpd -] unit-test + + "resource:basis/http/test/" enable-fhtml >>default + add-quit-action [ -[ "OK\n\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test + [ "OK\n\n" ] [ "http://localhost/" add-addr http-get nip ] unit-test -[ ] [ stop-test-httpd ] unit-test + [ ] [ stop-test-httpd ] unit-test + +] test-with-dispatcher ! Check that just closing the socket without sending anything works -[ ] [ - - add-quit-action - test-httpd -] unit-test + + add-quit-action [ + [ ] [ "addr" get binary [ ] with-client ] unit-test -[ ] [ "addr" get binary [ ] with-client ] unit-test + [ ] [ stop-test-httpd ] unit-test -[ ] [ stop-test-httpd ] unit-test +] test-with-dispatcher diff --git a/basis/http/server/responses/responses-docs.factor b/basis/http/server/responses/responses-docs.factor index dd2867817e..d4bbd4c986 100644 --- a/basis/http/server/responses/responses-docs.factor +++ b/basis/http/server/responses/responses-docs.factor @@ -1,11 +1,21 @@ USING: help.markup help.syntax io.streams.string strings -http math ; +http math furnace.json ; IN: http.server.responses HELP: { $values { "body" "a response body" } { "content-type" string } { "response" response } } { $description "Creates a successful HTTP response which sends a response body with the specified content type to the client." } ; +HELP: +{ $values { "body" "a response body" } { "response" response } } +{ $description "Creates a response with content type " { $snippet "text/plain" } "." } ; + +HELP: +{ $values { "body" "a response body" } { "response" response } } +{ $description "Creates a response with content type " { $snippet "text/html" } "." } ; + +{ } related-words + HELP: { $values { "code" integer } { "message" string } { "response" response } } { $description "Creates an HTTP error response." } @@ -17,9 +27,15 @@ HELP: } ; ARTICLE: "http.server.responses" "Canned HTTP responses" -"The " { $vocab-link "http.server.responses" } " vocabulary provides constructors for a few useful " { $link response } " objects." +"The " { $vocab-link "http.server.responses" } " vocabulary provides constructors for a few useful " { $link response } " objects." $nl +"For successful responses:" { $subsections + + +} +"For errors:" +{ $subsections <304> <403> <400> diff --git a/basis/http/server/responses/responses.factor b/basis/http/server/responses/responses.factor index 14527f5d68..9bade222ff 100644 --- a/basis/http/server/responses/responses.factor +++ b/basis/http/server/responses/responses.factor @@ -11,7 +11,13 @@ IN: http.server.responses utf8 >>content-encoding swap >>content-type swap >>body ; - + +: ( body -- response ) + "text/plain" ; + +: ( body -- response ) + "text/html" ; + : trivial-response-body ( code message -- ) @@ -23,7 +29,7 @@ IN: http.server.responses : ( code message -- response ) 2dup [ trivial-response-body ] with-string-writer - "text/html" + swap >>message swap >>code ; diff --git a/basis/http/server/server-docs.factor b/basis/http/server/server-docs.factor index 5d1b231f60..00b76f8b51 100644 --- a/basis/http/server/server-docs.factor +++ b/basis/http/server/server-docs.factor @@ -1,5 +1,5 @@ -USING: help.markup help.syntax io.streams.string quotations strings urls -http vocabs.refresh math io.servers assocs ; +USING: assocs help.markup help.syntax http io.servers kernel +math strings urls vocabs.refresh ; IN: http.server HELP: trivial-responder @@ -32,7 +32,7 @@ HELP: main-responder { $var-description "The responder which will handle HTTP requests." } ; HELP: post-request? -{ $values { "?" "a boolean" } } +{ $values { "?" boolean } } { $description "Outputs if the current request is a POST request.s" } ; HELP: responder-nesting diff --git a/basis/http/server/server-tests.factor b/basis/http/server/server-tests.factor index da43c0e0bc..cfadfeb217 100644 --- a/basis/http/server/server-tests.factor +++ b/basis/http/server/server-tests.factor @@ -1,6 +1,6 @@ USING: accessors continuations http http.server io.encodings.utf8 io.encodings.binary io.streams.string kernel -math sequences tools.test urls ; +math peg sequences tools.test urls ; IN: http.server.tests [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test @@ -62,3 +62,12 @@ IN: http.server.tests "\r\n\r\n\r\nGET / HTTP/1.0\r\n\r\n" [ read-request ] with-string-reader ] unit-test + +! Don't rethrow parse-errors with an empty request string. They are +! expected from certain browsers when the server serves a certificate +! that the browser can't verify. +{ } [ 0 "" f handle-client-error ] unit-test + +[ + 0 "not empty" f handle-client-error +] [ parse-error? ] must-fail-with diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 6b69d36503..4b9cbc5fbc 100644 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations -combinators vocabs.refresh tools.time math math.parser present -vectors hashtables +combinators combinators.short-circuit vocabs.refresh tools.time math math.parser +present vectors hashtables io io.sockets io.sockets.secure @@ -29,6 +29,7 @@ html.streams html mime.types math.order +peg xml.writer vocabs ; FROM: mime.multipart => parse-multipart ; @@ -66,7 +67,7 @@ upload-limit [ 200,000,000 ] initialize upload-limit get [ min ] when* limited-input binary decode-input parse-multipart-form-data parse-multipart ; - + : read-content ( request -- bytes ) "content-length" header string>number read ; @@ -285,13 +286,18 @@ LOG: httpd-benchmark DEBUG TUPLE: http-server < threaded-server ; +: handle-client-error ( error -- ) + dup { [ parse-error? ] [ got>> empty? ] } 1&& [ drop ] [ rethrow ] if ; + M: http-server handle-client* drop [ - ?refresh-all - request-limit get limited-input - [ read-request ] ?benchmark - [ do-request ] ?benchmark - [ do-response ] ?benchmark + [ + ?refresh-all + request-limit get limited-input + [ read-request ] ?benchmark + [ do-request ] ?benchmark + [ do-response ] ?benchmark + ] [ handle-client-error ] recover ] with-destructors ; : ( -- server ) diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor index 943ef769d6..523862db5c 100644 --- a/basis/http/server/static/static-docs.factor +++ b/basis/http/server/static/static-docs.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2008 Your name. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax io.streams.string ; IN: http.server.static HELP: -{ $values { "root" "a pathname string" } { "hook" { $quotation "( path mime-type -- response )" } } { "responder" file-responder } } +{ $values { "root" "a pathname string" } { "hook" { $quotation ( path mime-type -- response ) } } { "responder" file-responder } } { $description "Creates a file responder which serves content from " { $snippet "path" } " by using the hook to generate a response." } ; HELP: diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 294c3d7a0d..01b085e1ae 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -71,7 +71,7 @@ TUPLE: file-responder root hook special index-names allow-listings ; : list-directory ( directory -- response ) file-responder get allow-listings>> [ - directory>html "text/html" + directory>html ] [ drop <403> ] if ; @@ -105,7 +105,7 @@ M: file-responder call-responder* ( path responder -- response ) index-names>> adjoin ; : serve-fhtml ( path -- response ) - "text/html" ; + ; : enable-fhtml ( responder -- responder ) [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at diff --git a/basis/images/images-docs.factor b/basis/images/images-docs.factor new file mode 100644 index 0000000000..236c3d978a --- /dev/null +++ b/basis/images/images-docs.factor @@ -0,0 +1,6 @@ +USING: help.markup help.syntax math ; +IN: images + +HELP: rowstride +{ $values { "image" image } { "n" integer } } +{ $description "Returns an images rowstride metric." } ; diff --git a/basis/images/images-tests.factor b/basis/images/images-tests.factor index 1fda9b3b81..0c647c6208 100644 --- a/basis/images/images-tests.factor +++ b/basis/images/images-tests.factor @@ -4,26 +4,31 @@ USING: images tools.test kernel accessors ; IN: images.tests [ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA ubyte-components f f B{ - 0 0 0 0 - 0 0 0 0 - 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 57 57 57 255 - 0 0 0 0 - 0 0 0 0 + 0 0 0 0 + 0 0 0 0 } } pixel-at ] unit-test [ B{ - 0 0 0 0 - 0 0 0 0 - 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 57 57 57 255 - 0 0 0 0 - 0 0 0 0 + 0 0 0 0 + 0 0 0 0 } ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA ubyte-components f f B{ - 0 0 0 0 - 0 0 0 0 - 0 0 0 0 - 0 0 0 0 - 0 0 0 0 - 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 + 0 0 0 0 } } [ set-pixel-at ] keep bitmap>> ] unit-test + +{ 40 30 } [ + T{ image f { 10 3 } RGBA ubyte-components f f } rowstride + T{ image f { 10 3 } RGB ubyte-components f f } rowstride +] unit-test diff --git a/basis/images/images.factor b/basis/images/images.factor index 2d90faf9ad..359a19cae9 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel locals accessors sequences math arrays ; +USING: accessors combinators kernel locals math sequences ; IN: images SINGLETONS: @@ -18,7 +18,7 @@ SINGLETONS: u-9-9-9-e5-components float-11-11-10-components ; -UNION: component-order +UNION: component-order A L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR INTENSITY DEPTH DEPTH-STENCIL R RG ; @@ -41,8 +41,8 @@ UNION: unnormalized-integer-components int-integer-components uint-integer-components ; UNION: signed-unnormalized-integer-components - byte-integer-components - short-integer-components + byte-integer-components + short-integer-components int-integer-components ; UNION: unsigned-unnormalized-integer-components @@ -131,10 +131,13 @@ TUPLE: image : bytes-per-pixel ( image -- n ) [ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ; - + : bytes-per-image ( image -- n ) [ dim>> product ] [ bytes-per-pixel ] bi * ; +: rowstride ( image -- n ) + [ dim>> first ] [ bytes-per-pixel ] bi * ; + : set-pixel-at ( pixel x y image -- ) [ 1 ] dip set-pixel-row-at ; inline - diff --git a/basis/images/loader/cocoa/cocoa.factor b/basis/images/loader/cocoa/cocoa.factor index b3d05999f9..8a83cdcd77 100644 --- a/basis/images/loader/cocoa/cocoa.factor +++ b/basis/images/loader/cocoa/cocoa.factor @@ -1,23 +1,17 @@ ! Copyright (C) 2010, 2011 Joe Groff, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.data cocoa cocoa.classes cocoa.messages -combinators core-foundation.data core-graphics -core-graphics.types fry locals images images.loader io kernel -math sequences ; +USING: accessors cocoa cocoa.classes core-foundation +core-foundation.data core-foundation.urls core-graphics +core-graphics.private core-graphics.types destructors +images.loader io kernel locals math sequences ; FROM: system => os macosx? ; IN: images.loader.cocoa SINGLETON: ns-image os macosx? [ - "png" ns-image register-image-class - "tif" ns-image register-image-class - "tiff" ns-image register-image-class - "gif" ns-image register-image-class - "jpg" ns-image register-image-class - "jpeg" ns-image register-image-class - "bmp" ns-image register-image-class - "ico" ns-image register-image-class + { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" } + [ ns-image register-image-class ] each ] when : ( byte-array -- image-rep ) @@ -33,5 +27,23 @@ os macosx? [ 0 0 w h image CGContextDrawImage ] make-bitmap-image ; +: image>CGImage ( image -- image ) + [ bitmap>> ] [ dim>> first2 ] bi 8 pick 4 * + bitmap-color-space bitmap-flags + CGBitmapContextCreate -> autorelease + CGBitmapContextCreateImage ; + M: ns-image stream>image* drop stream-contents CGImage>image ; + +:: save-ns-image ( image path type -- ) + [ + path f &CFRelease + type 1 f CGImageDestinationCreateWithURL &CFRelease + [ + image image>CGImage &CFRelease + f CGImageDestinationAddImage + ] [ + CGImageDestinationFinalize drop + ] bi + ] with-destructors ; diff --git a/basis/images/loader/gdiplus/gdiplus.factor b/basis/images/loader/gdiplus/gdiplus.factor index 5ef2bd05ca..0eceef4a26 100644 --- a/basis/images/loader/gdiplus/gdiplus.factor +++ b/basis/images/loader/gdiplus/gdiplus.factor @@ -1,25 +1,22 @@ ! (c)2010 Joe Groff bsd license -USING: accessors alien.c-types alien.data alien.enums -classes.struct destructors images images.loader kernel locals -math windows.com windows.gdiplus windows.streams windows.types -typed byte-arrays grouping sequences ; +USING: accessors alien alien.c-types alien.data alien.enums alien.strings +assocs byte-arrays classes.struct destructors grouping images images.loader +io kernel locals math mime.types namespaces sequences specialized-arrays +windows.com windows.gdiplus windows.streams windows.types ; FROM: system => os windows? ; IN: images.loader.gdiplus +SPECIALIZED-ARRAY: ImageCodecInfo + SINGLETON: gdi+-image os windows? [ - "png" gdi+-image register-image-class - "tif" gdi+-image register-image-class - "tiff" gdi+-image register-image-class - "gif" gdi+-image register-image-class - "jpg" gdi+-image register-image-class - "jpeg" gdi+-image register-image-class - "bmp" gdi+-image register-image-class - "ico" gdi+-image register-image-class + { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" } + [ gdi+-image register-image-class ] each ] when ( x y w h -- rect ) GpRect ; inline @@ -31,9 +28,11 @@ os windows? [ : gdi+-bitmap-width ( bitmap -- w ) { UINT } [ GdipGetImageWidth check-gdi+-status ] with-out-parameters ; -: gdi+-bitmap-height ( bitmap -- w ) + +: gdi+-bitmap-height ( bitmap -- h ) { UINT } [ GdipGetImageHeight check-gdi+-status ] with-out-parameters ; + : gdi+-lock-bitmap ( bitmap rect mode format -- data ) { BitmapData } [ GdipBitmapLockBits check-gdi+-status ] with-out-parameters ; @@ -46,7 +45,7 @@ os windows? [ memory>byte-array :> pixels bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status w h pixels ; - + :: data>image ( w h pixels -- image ) image new { w h } >>dim @@ -55,11 +54,53 @@ os windows? [ ubyte-components >>component-type f >>upside-down? ; +! Only one pixel format supported, but I can't find images in the +! wild, loaded using gdi+, in which the format is different. +ERROR: unsupported-pixel-format component-order ; + +: check-pixel-format ( image -- ) + component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ; + +: image>gdi+-bitmap ( image -- bitmap ) + dup check-pixel-format + [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri + { void* } [ + GdipCreateBitmapFromScan0 check-gdi+-status + ] with-out-parameters &GdipFree ; + +: image-encoders-size ( -- num size ) + { UINT UINT } [ + GdipGetImageEncodersSize check-gdi+-status + ] with-out-parameters ; + +: image-encoders ( -- codec-infos ) + image-encoders-size dup 3dup + GdipGetImageEncoders check-gdi+-status + nip swap ; + +: extension>mime-type ( extension -- mime-type ) + ! Crashes if you let this mime through on my machine. + dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ; + +: mime-type>clsid ( mime-type -- clsid ) + image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ; + +: startup-gdi+ ( -- ) + start-gdi+ &stop-gdi+ drop ; + +: write-image-to-stream ( image stream extension -- ) + [ image>gdi+-bitmap ] + [ stream>IStream &com-release ] + [ extension>mime-type mime-type>clsid ] tri* + f GdipSaveImageToStream check-gdi+-status ; + PRIVATE> M: gdi+-image stream>image* - drop - start-gdi+ &stop-gdi+ drop + drop startup-gdi+ stream>gdi+-bitmap gdi+-bitmap>data data>image ; + +M: gdi+-image image>stream ( image extension class -- ) + drop startup-gdi+ output-stream get swap write-image-to-stream ; diff --git a/basis/images/loader/gtk/gtk-tests.factor b/basis/images/loader/gtk/gtk-tests.factor new file mode 100644 index 0000000000..799c14faeb --- /dev/null +++ b/basis/images/loader/gtk/gtk-tests.factor @@ -0,0 +1,21 @@ +USING: accessors arrays continuations gdk.pixbuf.ffi glib.ffi gobject.ffi +images.loader images.loader.gtk images.loader.gtk.private io +io.encodings.binary io.files kernel tools.test ; +IN: images.loader.gtk.tests + +: open-png-image ( -- image ) + "vocab:images/testing/png/basi0g01.png" load-image ; + +[ t ] [ + open-png-image [ dim>> ] [ + image>GdkPixbuf &g_object_unref + [ gdk_pixbuf_get_width ] [ gdk_pixbuf_get_height ] bi 2array + ] bi = +] unit-test + +[ t ] [ + [ + open-png-image image>GdkPixbuf &g_object_unref + "frob" GdkPixbuf>byte-array + ] [ g-error? ] recover +] unit-test diff --git a/basis/images/loader/gtk/gtk.factor b/basis/images/loader/gtk/gtk.factor index 9d99076e7d..095fcea72c 100644 --- a/basis/images/loader/gtk/gtk.factor +++ b/basis/images/loader/gtk/gtk.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2010 Philipp Brüschweiler. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.data arrays combinators -destructors gdk.pixbuf.ffi gobject.ffi grouping images +USING: accessors alien.c-types alien.data alien.syntax arrays assocs +combinators destructors gdk.pixbuf.ffi glib.ffi gobject.ffi grouping images images.loader io kernel locals math sequences -specialized-arrays ; +specialized-arrays unicode.case ; FROM: system => os linux? ; IN: images.loader.gtk SPECIALIZED-ARRAY: uchar @@ -11,14 +11,10 @@ SPECIALIZED-ARRAY: uchar SINGLETON: gtk-image os linux? [ - "png" gtk-image register-image-class - "tif" gtk-image register-image-class - "tiff" gtk-image register-image-class - "gif" gtk-image register-image-class - "jpg" gtk-image register-image-class - "jpeg" gtk-image register-image-class - "bmp" gtk-image register-image-class - "ico" gtk-image register-image-class + ! Explicit type initialization needed for glib < 2.36. + g_type_init + { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" } + [ gtk-image register-image-class ] each ] when components { + { 8 ubyte-components } + { 16 ushort-components } + { 32 uint-components } +} + : component-type ( GdkPixbuf -- component-type ) - gdk_pixbuf_get_bits_per_sample { - { 8 [ ubyte-components ] } - { 16 [ ushort-components ] } - { 32 [ uint-components ] } - } case ; + gdk_pixbuf_get_bits_per_sample bits>components at ; : GdkPixbuf>image ( GdkPixbuf -- image ) [ image new ] dip @@ -62,6 +60,33 @@ os linux? [ f >>premultiplied-alpha? f >>upside-down? ; +: image>GdkPixbuf ( image -- GdkPixbuf ) + { + [ bitmap>> ] + [ drop GDK_COLORSPACE_RGB ] + [ has-alpha? ] + [ component-type>> bytes-per-component 8 * ] + [ dim>> first2 ] + [ rowstride ] + } cleave f f gdk_pixbuf_new_from_data ; + +: GdkPixbuf>byte-array ( GdkPixbuf type -- byte-array ) + { void* int } [ + rot f f + { { pointer: GError initial: f } } [ + gdk_pixbuf_save_to_bufferv drop + ] with-out-parameters + ] with-out-parameters rot handle-GError memory>byte-array ; + +! The type parameter is almost always the same as the file extension, +! except for in the jpg -> jpeg and tif -> tiff cases. +: extension>pixbuf-type ( extension -- type ) + >lower { { "jpg" "jpeg" } { "tif" "tiff" } } ?at drop ; + +: write-image ( image extension -- ) + [ image>GdkPixbuf &g_object_unref ] [ extension>pixbuf-type ] bi* + GdkPixbuf>byte-array write ; + PRIVATE> M: gtk-image stream>image* @@ -69,3 +94,6 @@ M: gtk-image stream>image* stream-contents data>GInputStream &g_object_unref GInputStream>GdkPixbuf &g_object_unref GdkPixbuf>image ; + +M: gtk-image image>stream + drop write-image ; diff --git a/basis/images/loader/loader-docs.factor b/basis/images/loader/loader-docs.factor new file mode 100644 index 0000000000..cbd8a4035f --- /dev/null +++ b/basis/images/loader/loader-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax images strings ; +IN: images.loader + +HELP: save-graphic-image +{ $values { "image" image } { "path" string } } +{ $description "Saves a (graphic) image to disk. The extension of the path string is used to select which save format to save the image with." } +{ $examples + "This example renders a text on an image and then saves the image to /tmp/foo.jpg" + { $code + "USING: fonts images.loader ui.text ;" + "monospace-font \"Hello, there!\" string>image drop " + "\"/tmp/hello.jpg\" save-graphic-image" + } +} ; diff --git a/basis/images/loader/loader-tests.factor b/basis/images/loader/loader-tests.factor new file mode 100644 index 0000000000..8691a680e6 --- /dev/null +++ b/basis/images/loader/loader-tests.factor @@ -0,0 +1,59 @@ +USING: continuations glib.ffi images.loader io.files.temp kernel sequences +system tools.test ; +IN: images.loader.tests + +: open-png-image ( -- image ) + "vocab:images/testing/png/basi0g01.png" load-image ; + +: convert-to ( image format -- image' ) + "foo." prepend temp-file [ save-graphic-image ] keep load-image ; + +os windows? [ + ! Windows can handle these three formats fine. + { { t t t } } [ + { "png" "tif" "gif" } [ + open-png-image [ swap convert-to ] keep = + ] map + ] unit-test +] when + +os linux? [ + ! GTK only these two. + { { t t } } [ + { "png" "bmp" } [ + open-png-image [ swap convert-to ] keep = + ] map + ] unit-test + + ! It either can save to gif or throw a g-error if the gif encoder + ! is excluded. + { t } [ + [ open-png-image dup "gif" convert-to = ] [ g-error? ] recover + ] unit-test +] when + +os { linux windows } member? [ + { t } [ + [ + open-png-image + "hai!" save-graphic-image + ] [ unknown-image-extension? ] recover + ] unit-test + + ! Windows can't save .bmp-files for unknown reason. It can load + ! them though. + os windows? [ + [ + open-png-image "foo.bmp" temp-file save-graphic-image + ] [ unknown-image-extension? ] must-fail-with + ] [ + { t } [ + open-png-image dup "bmp" convert-to = + ] unit-test + ] if + + { t } [ + "vocab:images/testing/bmp/rgb_8bit.bmp" load-image dup + "foo.png" temp-file [ save-graphic-image ] [ load-image ] bi = + ] unit-test +] when diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 6bd5d54a28..1496ae00ae 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: ascii assocs byte-arrays destructors fry io.encodings.binary io.files io.pathnames io.streams.byte-array -kernel namespaces sequences strings ; +kernel namespaces strings ; IN: images.loader ERROR: unknown-image-extension extension ; @@ -32,8 +32,11 @@ GENERIC: stream>image* ( stream class -- image ) : register-image-class ( extension class -- ) swap types get set-at ; +: ?register-image-class ( extension class -- ) + over types get key? [ 2drop ] [ register-image-class ] if ; + : load-image ( path -- image ) - [ binary ] [ image-class ] bi load-image* ; + dup image-class load-image* ; M: object load-image* stream>image ; @@ -47,9 +50,8 @@ M: pathname load-image* [ binary ] dip stream>image ; ! Image Encode - -GENERIC: image>stream ( image class -- ) +GENERIC: image>stream ( image extension class -- ) : save-graphic-image ( image path -- ) - [ image-class ] [ ] bi + dup file-extension dup (image-class) rot binary [ image>stream ] with-file-writer ; diff --git a/basis/images/tessellation/tessellation.factor b/basis/images/tessellation/tessellation.factor index bd43bf0f90..0ed02bab74 100644 --- a/basis/images/tessellation/tessellation.factor +++ b/basis/images/tessellation/tessellation.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel math grouping fry columns locals accessors -images math.vectors arrays ; +USING: accessors arrays fry grouping images kernel locals math +math.vectors sequences ; IN: images.tessellation : group-rows ( bitmap bitmap-dim -- rows ) diff --git a/basis/interpolate/interpolate-docs.factor b/basis/interpolate/interpolate-docs.factor new file mode 100644 index 0000000000..02300ea282 --- /dev/null +++ b/basis/interpolate/interpolate-docs.factor @@ -0,0 +1,10 @@ +USING: help.markup help.syntax math strings ; +IN: interpolate + +HELP: ninterpolate +{ $values { "str" string } { "n" integer } } +{ $description "Assigns stack arguments to numbered variables for string interpolation." } +{ $examples + { $example "USING: interpolate ;" "\"Bob\" \"Alice\" \"Hi ${0}, it's ${1}.\" 2 ninterpolate" "Hi Bob, it's Alice." } +} +{ $see-also interpolate } ; diff --git a/basis/interpolate/interpolate.factor b/basis/interpolate/interpolate.factor index 6e5f68fcdf..bed5b7416c 100644 --- a/basis/interpolate/interpolate.factor +++ b/basis/interpolate/interpolate.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel macros make multiline namespaces vocabs.parser -present sequences strings splitting fry accessors ; +USING: accessors arrays fry hashtables io kernel macros make +math.parser multiline namespaces present sequences +sequences.generalizations splitting strings vocabs.parser ; IN: interpolate string swap 2array ] map-index + >hashtable [ _ interpolate ] with-variables + ] ; diff --git a/basis/interval-maps/interval-maps-docs.factor b/basis/interval-maps/interval-maps-docs.factor index 64fc40d4b9..a4603bff03 100644 --- a/basis/interval-maps/interval-maps-docs.factor +++ b/basis/interval-maps/interval-maps-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax assocs kernel sequences ; +USING: assocs help.markup help.syntax kernel sequences ; IN: interval-maps HELP: interval-at* @@ -12,7 +12,7 @@ HELP: interval-at { $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ; HELP: interval-key? -{ $values { "key" object } { "map" interval-map } { "?" "a boolean" } } +{ $values { "key" object } { "map" interval-map } { "?" boolean } } { $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ; HELP: diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index bb6686ce24..0b63f2815b 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -44,9 +44,9 @@ PRIVATE> [ nip ] [ interval-contains? ] 2bi [ value t ] [ drop f f ] if ; inline -: interval-at ( key map -- value ) interval-at* drop ; +: interval-at ( key map -- value ) interval-at* drop ; inline -: interval-key? ( key map -- ? ) interval-at* nip ; +: interval-key? ( key map -- ? ) interval-at* nip ; inline : interval-values ( map -- values ) check-interval-map array>> [ value ] map ; diff --git a/basis/interval-sets/interval-sets.factor b/basis/interval-sets/interval-sets.factor index 4fdcfc3634..6668a3c910 100644 --- a/basis/interval-sets/interval-sets.factor +++ b/basis/interval-sets/interval-sets.factor @@ -11,13 +11,6 @@ TUPLE: interval-set { array uint-array read-only } ; > 2 - [ start <=> ] with search nip ; inline - ERROR: not-an-interval-set obj ; : check-interval-set ( map -- map ) @@ -26,15 +19,19 @@ ERROR: not-an-interval-set obj ; PRIVATE> : in? ( key set -- ? ) - check-interval-set dupd find-interval - [ [ start ] [ end 1 - ] bi between? ] - [ drop f ] if* ; + check-interval-set array>> + dupd [ <=> ] with search swap [ + even? [ >= ] [ 1 - <= ] if + ] [ 2drop f ] if* ; pairs ( sequence -- intervals ) [ dup number? [ dup 2array ] when ] map ; +ALIAS: start first-unsafe +ALIAS: end second-unsafe + : disjoint? ( node1 node2 -- ? ) [ end ] [ start ] bi* < ; @@ -46,7 +43,7 @@ PRIVATE> drop dup first2 < [ unclip-slice , ] [ 2 tail-slice ] if - (delete-redundancies) + (delete-redundancies) ] } case ; diff --git a/basis/inverse/inverse-docs.factor b/basis/inverse/inverse-docs.factor index 961409a11d..adda3838cc 100644 --- a/basis/inverse/inverse-docs.factor +++ b/basis/inverse/inverse-docs.factor @@ -1,38 +1,38 @@ -USING: help.syntax help.markup ; +USING: help.markup help.syntax kernel quotations words ; IN: inverse HELP: [undo] -{ $values { "quot" "a quotation" } { "undo" "the inverse of the quotation" } } +{ $values { "quot" quotation } { "undo" "the inverse of the quotation" } } { $description "Creates the inverse of the given quotation" } { $see-also undo } ; HELP: undo -{ $values { "quot" "a quotation" } } +{ $values { "quot" quotation } } { $description "Executes the inverse of the given quotation" } { $see-also [undo] } ; HELP: define-inverse -{ $values { "word" "a word" } { "quot" "the inverse" } } +{ $values { "word" word } { "quot" "the inverse" } } { $description "Defines the inverse of a given word, taking no arguments from the quotation, only the stack." } { $see-also define-dual define-involution define-pop-inverse } ; HELP: define-dual -{ $values { "word1" "a word" } { "word2" "a word" } } +{ $values { "word1" word } { "word2" word } } { $description "Defines the inverse of each word as being the other one." } { $see-also define-inverse define-involution } ; HELP: define-involution -{ $values { "word" "a word" } } +{ $values { "word" word } } { $description "Defines a word as being its own inverse." } { $see-also define-dual define-inverse } ; HELP: define-pop-inverse -{ $values { "word" "a word" } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" "a quotation" } } +{ $values { "word" word } { "n" "number of arguments to be taken from the inverted quotation" } { "quot" quotation } } { $description "Defines the inverse of the given word, taking the given number of arguments from the inverted quotation. The quotation given should generate an inverse quotation." } { $see-also define-inverse } ; HELP: matches? -{ $values { "quot" "a quotation" } { "?" "a boolean" } } +{ $values { "quot" quotation } { "?" boolean } } { $description "Tests if the stack can match the given quotation. The quotation is inverted, and if the inverse can run without a unification failure, then t is returned. Else f is returned. If a different error is encountered (such as stack underflow), this will be propagated." } ; HELP: switch diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 5f6a8bac2b..35399c0132 100644 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -259,7 +259,7 @@ DEFER: __ : empty-inverse ( class -- quot ) deconstruct-pred - [ tuple>array rest [ ] any? [ fail ] when ] + [ tuple-slots [ ] any? [ fail ] when ] compose ; \ new 1 [ ?wrapped empty-inverse ] define-pop-inverse diff --git a/basis/io/backend/unix/macosx/macosx.factor b/basis/io/backend/unix/macosx/macosx.factor index 6149ce7928..376ace3585 100644 --- a/basis/io/backend/unix/macosx/macosx.factor +++ b/basis/io/backend/unix/macosx/macosx.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend system namespaces -io.backend.unix.multiplexers io.backend.unix.multiplexers.run-loop -kernel accessors assocs continuations unix io.backend.unix -io.backend.unix.multiplexers.kqueue io.files.unix init ; +USING: init io.backend io.backend.unix +io.backend.unix.multiplexers io.backend.unix.multiplexers.kqueue +io.backend.unix.multiplexers.run-loop namespaces system ; +USE: io.files.unix ! need this for deploy IN: io.backend.unix.macosx SINGLETON: macosx-kqueue diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor index e2a7cda826..31a28662bb 100644 --- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes.struct kernel destructors bit-arrays sequences assocs specialized-arrays math namespaces -locals fry unix unix.linux.epoll unix.time io.ports +libc locals fry unix unix.linux.epoll unix.time io.ports io.backend.unix io.backend.unix.multiplexers ; SPECIALIZED-ARRAY: epoll-event IN: io.backend.unix.multiplexers.epoll diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index 67b7563e92..5696c2df99 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.data combinators -destructors io.backend.unix kernel math.bitwise sequences +destructors io.backend.unix libc kernel math.bitwise sequences specialized-arrays unix unix.kqueue unix.time assocs io.backend.unix.multiplexers classes.struct literals ; SPECIALIZED-ARRAY: kevent diff --git a/basis/io/backend/unix/multiplexers/multiplexers.factor b/basis/io/backend/unix/multiplexers/multiplexers.factor index ded028dda4..2440b6a8ae 100644 --- a/basis/io/backend/unix/multiplexers/multiplexers.factor +++ b/basis/io/backend/unix/multiplexers/multiplexers.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors assocs sequences threads destructors ; +USING: accessors assocs destructors kernel sequences threads ; IN: io.backend.unix.multiplexers TUPLE: mx < disposable fd reads writes ; diff --git a/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor index 804243558e..51405b203c 100644 --- a/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor +++ b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor @@ -10,13 +10,12 @@ IN: io.backend.unix.multiplexers.run-loop TUPLE: run-loop-mx kqueue-mx ; : file-descriptor-callback ( -- callback ) - void { CFFileDescriptorRef CFOptionFlags void* } - cdecl [ - 2drop + [ + 3drop 0 mx get-global kqueue-mx>> wait-for-events - enable-all-callbacks + reset-run-loop yield - ] alien-callback ; + ] CFFileDescriptorCallBack ; : ( -- mx ) [ diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor index 09fd5840c2..6e10a959da 100644 --- a/basis/io/backend/unix/multiplexers/select/select.factor +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.data kernel bit-arrays sequences assocs math -namespaces accessors math.order locals fry io.ports -io.backend.unix io.backend.unix.multiplexers unix unix.ffi -unix.time layouts ; +USING: accessors alien.data assocs bit-arrays fry +io.backend.unix io.backend.unix.multiplexers kernel layouts +locals math math.order sequences unix.ffi unix.time ; IN: io.backend.unix.multiplexers.select TUPLE: select-mx < mx read-fdset write-fdset ; @@ -13,8 +12,8 @@ TUPLE: select-mx < mx read-fdset write-fdset ; ! byte order differences on big endian platforms : munge ( i -- i' ) little-endian? [ - cell 4 = [ 0b11000 ] [ 0b111000 ] if - bitxor ] unless ; inline + cell 4 = 0b11000 0b111000 ? bitxor + ] unless ; inline : ( -- mx ) select-mx new-mx diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 45f08a1247..43f25d077b 100755 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.data alien.syntax generic -assocs kernel kernel.private math io.ports sequences strings -sbufs threads unix unix.ffi unix.stat vectors io.buffers io.backend -io.encodings math.parser continuations system libc namespaces -make io.timeouts io.encodings.utf8 destructors -destructors.private accessors summary combinators locals -unix.time unix.types fry io.backend.unix.multiplexers -classes.struct hints ; +USING: accessors alien.c-types alien.data alien.syntax +classes.struct combinators destructors destructors.private fry +hints io.backend io.backend.unix.multiplexers io.buffers +io.files io.ports io.timeouts kernel kernel.private libc locals +make math namespaces sequences summary system threads unix +unix.ffi unix.stat unix.types ; QUALIFIED: io IN: io.backend.unix +CONSTANT: file-mode 0o0666 + GENERIC: handle-fd ( handle -- fd ) TUPLE: fd < disposable fd ; @@ -65,15 +65,11 @@ M: unix handle-length ( handle -- n/f ) fd>> \ stat [ fstat -1 = not ] keep swap [ st_size>> ] [ drop f ] if ; -SYMBOL: +retry+ ! just try the operation again without blocking -SYMBOL: +input+ -SYMBOL: +output+ - ERROR: io-timeout ; M: io-timeout summary drop "I/O operation timed out" ; -: wait-for-fd ( handle event -- ) +M: unix wait-for-fd ( handle event -- ) dup +retry+ eq? [ 2drop ] [ [ [ self ] dip handle-fd mx get-global ] dip { { +input+ [ add-input-callback ] } @@ -86,11 +82,6 @@ M: io-timeout summary drop "I/O operation timed out" ; '[ handle>> _ wait-for-fd ] with-timeout ; ! Some general stuff -CONSTANT: file-mode 0o0666 - -! Returns an event to wait for which will ensure completion of -! this request -GENERIC: refill ( port handle -- event/f ) M: fd refill fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read @@ -110,8 +101,6 @@ M: unix (wait-to-read) ( port -- ) [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ; ! Writers -GENERIC: drain ( port handle -- event/f ) - M: fd drain fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write { diff --git a/basis/io/buffers/buffers-docs.factor b/basis/io/buffers/buffers-docs.factor index 8a233337f0..d27e0bf59e 100644 --- a/basis/io/buffers/buffers-docs.factor +++ b/basis/io/buffers/buffers-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax byte-arrays alien destructors ; +USING: alien byte-arrays destructors help.markup help.syntax +kernel ; IN: io.buffers ARTICLE: "buffers" "Locked I/O buffers" @@ -49,7 +50,7 @@ $nl HELP: { $values { "n" "a non-negative integer" } { "buffer" buffer } } -{ $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ; +{ $description "Allocates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ; HELP: buffer-reset { $values { "n" "a non-negative integer" } { "buffer" buffer } } @@ -69,19 +70,40 @@ HELP: buffer-end HELP: buffer-read { $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } } -{ $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ; +{ $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } +{ $examples + { $example + "USING: destructors io.buffers kernel prettyprint ;" + "5 100 [ B{ 7 14 21 } over >buffer buffer-read ] with-disposal ." + "B{ 7 14 21 }" + } +} ; HELP: buffer-length { $values { "buffer" buffer } { "n" "a non-negative integer" } } -{ $description "Outputs the number of unconsumed bytes in the buffer." } ; +{ $description "Outputs the number of unconsumed bytes in the buffer." } +{ $examples + { $example + "USING: destructors io.buffers kernel prettyprint ;" + "100 [ B{ 7 14 21 } over >buffer buffer-length ] with-disposal ." + "3" + } +} ; HELP: buffer-capacity { $values { "buffer" buffer } { "n" "a non-negative integer" } } -{ $description "Outputs the buffer's maximum capacity before growing." } ; +{ $description "Outputs the buffer's maximum capacity before growing." } +{ $examples + { $example + "USING: destructors io.buffers prettyprint ;" + "100 [ buffer-capacity ] with-disposal ." + "100" + } +} ; HELP: buffer-empty? -{ $values { "buffer" buffer } { "?" "a boolean" } } -{ $description "Tests if the buffer contains no more data to be read." } ; +{ $values { "buffer" buffer } { "?" boolean } } +{ $description "Tests if the buffer contains no more data to be read or written." } ; HELP: >buffer { $values { "byte-array" byte-array } { "buffer" buffer } } @@ -91,7 +113,14 @@ HELP: >buffer HELP: byte>buffer { $values { "byte" "a byte" } { "buffer" buffer } } { $description "Appends a single byte to a buffer." } -{ $warning "This word will corrupt memory if the buffer is full." } ; +{ $warning "This word will corrupt memory if the buffer is full." } +{ $examples + { $example + "USING: destructors io.buffers kernel prettyprint ;" + "100 [ 237 over byte>buffer buffer-pop ] with-disposal ." + "237" + } +} ; HELP: n>buffer { $values { "n" "a non-negative integer" } { "buffer" buffer } } diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor index eb656be6b4..86c2778cd7 100644 --- a/basis/io/directories/directories.factor +++ b/basis/io/directories/directories.factor @@ -11,6 +11,9 @@ IN: io.directories : with-directory ( path quot -- ) [ absolute-path current-directory ] dip with-variable ; inline +: with-resource-directory ( quot -- ) + [ "resource:" ] dip with-directory ; inline + ! Creating directories HOOK: make-directory io-backend ( path -- ) @@ -28,7 +31,7 @@ HOOK: make-directory io-backend ( path -- ) ! Listing directories TUPLE: directory-entry name type ; -HOOK: >directory-entry os ( byte-array -- directory-entry ) +C: directory-entry HOOK: (directory-entries) os ( path -- seq ) diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index de61aeaf0b..a2547f28f7 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -46,7 +46,7 @@ HELP: find-in-directories HELP: find-all-files { $values { "path" "a pathname string" } { "quot" quotation } - { "paths/f" "a sequence of pathname strings or f" } + { "paths" "a sequence of pathname strings" } } { $description "Recursively finds all files in the input directory matching the predicate quotation." } ; diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 2406f21345..19dd52e87b 100644 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations deques dlists fry io.backend io.directories io.files.info io.pathnames kernel -locals math sequences sorting system unicode.case vocabs -vocabs.loader ; +kernel.private locals math sequences sorting strings system +unicode.case vocabs vocabs.loader ; IN: io.directories.search : qualified-directory-entries ( path -- seq ) @@ -22,9 +22,13 @@ IN: io.directories.search > ] [ bfs>> ] bi [ push-front ] [ push-back ] if @@ -35,6 +39,7 @@ TUPLE: directory-iterator path bfs queue ; dup path>> over push-directory-entries ; : next-directory-entry ( iter -- directory-entry/f ) + { directory-iterator } declare dup queue>> deque-empty? [ drop f ] [ dup queue>> pop-back dup directory? @@ -58,25 +63,24 @@ TUPLE: directory-iterator path bfs queue ; PRIVATE> -: each-file ( path bfs? quot -- ) +: each-file ( path bfs? quot: ( ... name -- ... ) -- ) setup-traversal iterate-directory drop ; inline -: each-directory-entry ( path bfs? quot -- ) +: each-directory-entry ( path bfs? quot: ( ... entry -- ... ) -- ) setup-traversal iterate-directory-entries drop ; inline : recursive-directory-files ( path bfs? -- paths ) - [ ] collector [ each-file ] dip ; inline + [ ] collector [ each-file ] dip ; : recursive-directory-entries ( path bfs? -- directory-entries ) - [ ] collector [ each-directory-entry ] dip ; inline + [ ] collector [ each-directory-entry ] dip ; -: find-file ( path bfs? quot -- path/f ) +: find-file ( path bfs? quot: ( ... name -- ... ? ) -- path/f ) [ ] dip [ keep and ] curry iterate-directory ; inline -: find-all-files ( path quot -- paths/f ) - [ f ] dip selector - [ [ f ] compose iterate-directory drop ] dip ; inline +: find-all-files ( path quot: ( ... name -- ... ? ) -- paths ) + f swap selector [ each-file ] dip ; inline ERROR: file-not-found path bfs? quot ; @@ -96,14 +100,11 @@ ERROR: file-not-found path bfs? quot ; : 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 + [ name>> dup ] [ directory? ] bi + [ directory-size ] [ link-size/0 ] if ] { } map>assoc ] with-qualified-directory-entries sort-values ; diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor index 3429d5beb2..bc1e53366d 100644 --- a/basis/io/directories/unix/linux/linux.factor +++ b/basis/io/directories/unix/linux/linux.factor @@ -1,11 +1,17 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.data io.directories.unix kernel -system unix classes.struct unix.ffi ; +USING: alien.c-types alien.data classes.struct fry +io.directories io.directories.unix kernel libc math sequences +system unix.ffi ; IN: io.directories.unix.linux -M: linux find-next-file ( DIR* -- dirent ) - dirent - f void* - [ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep - void* deref [ drop f ] unless ; +: next-dirent ( DIR* dirent* -- dirent* ? ) + f void* [ + readdir64_r [ dup strerror libc-error ] unless-zero + ] 2keep void* deref ; inline + +M: linux (directory-entries) ( path -- seq ) + [ + dirent + '[ _ _ next-dirent ] [ >directory-entry ] produce nip + ] with-unix-directory ; diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index c6cb222f6f..b401813005 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -1,17 +1,16 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.data alien.strings -assocs combinators continuations destructors fry io io.backend -io.directories io.encodings.binary io.files.info.unix -io.encodings.utf8 io.files io.pathnames io.files.types kernel -math.bitwise sequences system unix unix.stat vocabs.loader -classes.struct unix.ffi literals libc vocabs ; +USING: accessors alien.c-types alien.data alien.strings assocs +classes.struct continuations fry io.backend io.backend.unix +io.directories io.encodings.utf8 io.files io.files.info +io.files.info.unix io.files.types kernel libc literals math +sequences system unix unix.ffi vocabs ; IN: io.directories.unix -CONSTANT: file-mode 0o0666 - CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL } +CONSTANT: mkdir-mode flags{ USER-ALL GROUP-ALL OTHER-ALL } ! 0o777 + M: unix touch-file ( path -- ) normalize-path dup exists? [ touch ] [ @@ -24,7 +23,7 @@ M: unix move-file ( from to -- ) M: unix delete-file ( path -- ) normalize-path unlink-file ; M: unix make-directory ( path -- ) - normalize-path 0o777 [ mkdir ] unix-system-call drop ; + normalize-path mkdir-mode [ mkdir ] unix-system-call drop ; M: unix delete-directory ( path -- ) normalize-path [ rmdir ] unix-system-call drop ; @@ -35,19 +34,12 @@ M: unix copy-file ( from to -- ) [ [ file-permissions ] dip swap set-file-permissions ] 2bi ; : with-unix-directory ( path quot -- ) - [ opendir dup [ (io-error) ] unless ] dip - dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline + dupd '[ _ _ + [ opendir dup [ (io-error) ] unless ] dip + dupd curry swap '[ _ closedir io-error ] [ ] cleanup + ] with-directory ; inline -HOOK: find-next-file os ( DIR* -- byte-array ) - -M: unix find-next-file ( DIR* -- byte-array ) - dirent - f void* - 0 set-errno - [ readdir_r 0 = [ errno 0 = [ (io-error) ] unless ] unless ] 2keep - void* deref [ drop f ] unless ; - -: dirent-type>file-type ( ch -- type ) +: dirent-type>file-type ( type -- file-type ) H{ { $ DT_BLK +block-device+ } { $ DT_CHR +character-device+ } @@ -59,17 +51,24 @@ M: unix find-next-file ( DIR* -- byte-array ) { $ DT_WHT +whiteout+ } } at* [ drop +unknown+ ] unless ; -M: unix >directory-entry ( byte-array -- directory-entry ) - { - [ d_name>> underlying>> utf8 alien>string ] - [ d_type>> dirent-type>file-type ] - } cleave directory-entry boa ; +! An easy way to return +unknown+ is to mount a .iso on OSX and +! call directory-entries on the mount point. + +: next-dirent ( DIR* dirent* -- dirent* ? ) + f void* [ + readdir_r [ dup strerror libc-error ] unless-zero + ] 2keep void* deref ; inline + +: >directory-entry ( dirent* -- directory-entry ) + [ d_name>> utf8 alien>string ] + [ d_type>> dirent-type>file-type ] bi + dup +unknown+ = [ drop dup file-info type>> ] when + ; inline M: unix (directory-entries) ( path -- seq ) [ - '[ _ find-next-file dup ] - [ >directory-entry ] - produce nip + dirent + '[ _ _ next-dirent ] [ >directory-entry ] produce nip ] with-unix-directory ; os linux? [ "io.directories.unix.linux" require ] when diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor index 46ce2ec441..2168eeffed 100644 --- a/basis/io/directories/windows/windows.factor +++ b/basis/io/directories/windows/windows.factor @@ -48,13 +48,11 @@ M: windows delete-directory ( path -- ) normalize-path RemoveDirectory win32-error=0/f ; -: find-first-file ( path -- WIN32_FIND_DATA handle ) - WIN32_FIND_DATA +: find-first-file ( path WIN32_FIND_DATA -- WIN32_FIND_DATA HANDLE ) [ nip ] [ FindFirstFile ] 2bi [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ; -: find-next-file ( path -- WIN32_FIND_DATA/f ) - WIN32_FIND_DATA +: find-next-file ( HANDLE WIN32_FIND_DATA -- WIN32_FIND_DATA/f ) [ nip ] [ FindNextFile ] 2bi 0 = [ GetLastError ERROR_NO_MORE_FILES = [ win32-error @@ -63,23 +61,27 @@ M: windows delete-directory ( path -- ) TUPLE: windows-directory-entry < directory-entry attributes ; -M: windows >directory-entry ( byte-array -- directory-entry ) +C: windows-directory-entry + +: >windows-directory-entry ( WIN32_FIND_DATA -- directory-entry ) [ cFileName>> alien>native-string ] [ dwFileAttributes>> [ win32-file-type ] [ win32-file-attributes ] bi ] bi - dupd remove windows-directory-entry boa ; + dupd remove ; inline M: windows (directory-entries) ( path -- seq ) "\\" ?tail drop "\\*" append - find-first-file [ >directory-entry ] dip + WIN32_FIND_DATA + find-first-file over + [ >windows-directory-entry ] 2dip [ '[ - [ _ find-next-file dup ] - [ >directory-entry ] + [ _ _ find-next-file dup ] + [ >windows-directory-entry ] produce nip over name>> "." = [ nip ] [ swap prefix ] if ] - ] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ; + ] [ drop '[ _ FindClose win32-error=0/f ] ] 2bi [ ] cleanup ; diff --git a/basis/io/encodings/string/string.factor b/basis/io/encodings/string/string.factor index 67c34fb377..e6f278e5b3 100644 --- a/basis/io/encodings/string/string.factor +++ b/basis/io/encodings/string/string.factor @@ -1,23 +1,30 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: byte-vectors io io.encodings io.streams.byte-array -io.streams.string kernel locals sbufs sequences io.private -io.encodings.binary ; +USING: accessors byte-arrays byte-vectors io io.encodings +io.streams.byte-array io.streams.string kernel locals +sbufs sequences io.private io.encodings.ascii +io.encodings.binary io.encodings.private io.encodings.utf8 ; IN: io.encodings.string :: decode ( byte-array encoding -- string ) encoding binary eq? [ byte-array ] [ - byte-array encoding :> reader - byte-array length - encoding guess-decoded-length - reader stream-exemplar-growable new-resizable :> buf - [ reader stream-read1 dup ] [ buf push ] while drop - buf reader stream-exemplar like + byte-array byte-array? encoding ascii eq? and [ + byte-array byte-array>string-fast + ] [ + byte-array encoding :> reader + byte-array length encoding guess-decoded-length :> buf + [ reader stream-read1 dup ] [ buf push ] while drop + buf "" like + ] if ] if ; inline :: encode ( string encoding -- byte-array ) encoding binary eq? [ string ] [ - string length encoding guess-encoded-length :> vec - string vec encoding stream-write - vec B{ } like + string aux>> not encoding { ascii utf8 } member-eq? and [ + string string>byte-array-fast + ] [ + string length encoding guess-encoded-length :> vec + string vec encoding stream-write + vec B{ } like + ] if ] if ; inline diff --git a/basis/io/encodings/utf7/authors.txt b/basis/io/encodings/utf7/authors.txt new file mode 100644 index 0000000000..8c0a152f90 --- /dev/null +++ b/basis/io/encodings/utf7/authors.txt @@ -0,0 +1 @@ +Björn Lindqvist diff --git a/basis/io/encodings/utf7/summary.txt b/basis/io/encodings/utf7/summary.txt new file mode 100644 index 0000000000..dc1e53c9fd --- /dev/null +++ b/basis/io/encodings/utf7/summary.txt @@ -0,0 +1 @@ +UTF7 encoding/decoding diff --git a/basis/io/encodings/utf7/utf7-docs.factor b/basis/io/encodings/utf7/utf7-docs.factor new file mode 100644 index 0000000000..4dabcce5aa --- /dev/null +++ b/basis/io/encodings/utf7/utf7-docs.factor @@ -0,0 +1,10 @@ +USING: help.markup help.syntax ; +IN: io.encodings.utf7 + +HELP: utf7 +{ $values { "utf7codec" utf7codec } } +{ $description "Encoding descriptor for UTF-7 encoding." } ; + +HELP: utf7imap4 +{ $values { "utf7codec" utf7codec } } +{ $description "Encoding descriptor for the encoding UTF-7 modified for IMAP (see RFC 3501 5.1.3)." } ; diff --git a/basis/io/encodings/utf7/utf7-tests.factor b/basis/io/encodings/utf7/utf7-tests.factor new file mode 100644 index 0000000000..9e6ed54282 --- /dev/null +++ b/basis/io/encodings/utf7/utf7-tests.factor @@ -0,0 +1,53 @@ +USING: io.encodings.string io.encodings.utf7 kernel sequences strings +tools.test ; +IN: io.encodings.utf7.tests + +[ + { + "~/b&AOU-g&APg-" + "b&AOU-x" + "b&APg-x" + "test" + "Skr&AOQ-ppost" + "Ting &- S&AOU-ger" + "~/F&APg-lder/mailb&AOU-x &- stuff + more" + "~peter/mail/&ZeVnLIqe-/&U,BTFw-" + } +] [ + { + "~/bågø" + "båx" + "bøx" + "test" + "Skräppost" + "Ting & Såger" + "~/Følder/mailbåx & stuff + more" + "~peter/mail/日本語/台北" + } [ utf7imap4 encode >string ] map +] unit-test + +[ t ] [ + { + "~/bågø" + "båx" + "bøx" + "test" + "Skräppost" + "Ting & Såger" + "~/Følder/mailbåx & stuff + more" + "~peter/mail/日本語/台北" + } dup [ utf7 encode utf7 decode ] map = +] unit-test + +[ t ] [ + { + "~/bågø" + "båx" + "bøx" + "test" + "Skräppost" + "Ting & Såger" + "~/Følder/mailbåx & stuff + more" + "~peter/mail/日本語/台北" + } dup [ utf7imap4 encode utf7imap4 decode ] map = +] unit-test diff --git a/basis/io/encodings/utf7/utf7.factor b/basis/io/encodings/utf7/utf7.factor new file mode 100644 index 0000000000..40d4fe5490 --- /dev/null +++ b/basis/io/encodings/utf7/utf7.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2013-2014 Björn Lindqvist +! See http://factorcode.org/license.txt for BSD license +USING: accessors ascii base64 fry grouping.extras io +io.encodings io.encodings.string io.encodings.utf16 kernel math +math.functions sequences splitting strings ; +IN: io.encodings.utf7 + +TUPLE: utf7codec dialect buffer ; + +! These words encodes the difference between standard utf7 and the +! dialect used by IMAP which wants slashes replaced with commas when +! encoding and uses '&' instead of '+' as the escaping character. +: utf7 ( -- utf7codec ) + { + { { } { } } + { { CHAR: + } { CHAR: - } } + } V{ } utf7codec boa ; + +: utf7imap4 ( -- utf7codec ) + { + { { CHAR: / } { CHAR: , } } + { { CHAR: & } { CHAR: - } } + } V{ } utf7codec boa ; + +: >raw-base64 ( bytes -- bytes' ) + >string utf16be encode >base64 [ CHAR: = = ] trim-tail ; + +: raw-base64> ( str -- str' ) + dup length 4 / ceiling 4 * CHAR: = pad-tail base64> utf16be decode ; + +: encode-chunk ( repl-pair surround-pair chunk ascii? -- bytes ) + [ swap [ first ] [ concat ] bi replace nip ] + [ >raw-base64 -rot [ first2 replace ] [ first2 surround ] bi* ] if ; + +: encode-utf7-string ( str codec -- bytes ) + [ [ printable? ] group-by ] dip + dialect>> first2 '[ _ _ rot first2 swap encode-chunk ] map + B{ } concat-as ; + +M: utf7codec encode-string ( str stream codec -- ) + swapd encode-utf7-string swap stream-write ; + +DEFER: emit-char + +: decode-chunk ( dialect -- ch buffer ) + dup first2 swap [ second read-until drop ] [ first2 swap replace ] bi* + [ second first first { } ] [ raw-base64> emit-char ] if-empty ; + +: fill-buffer ( dialect -- ch buffer ) + dup second first first read1 dup swapd = [ + drop decode-chunk + ] [ nip { } ] if ; + +: emit-char ( dialect buffer -- ch buffer' ) + [ fill-buffer ] [ nip unclip swap ] if-empty ; + +: replace-all! ( src dst -- ) + [ delete-all ] keep push-all ; + +M: utf7codec decode-char ( stream codec -- char/f ) + swap [ + [ dialect>> ] [ buffer>> ] bi [ emit-char ] keep replace-all! + ] with-input-stream ; diff --git a/basis/io/files/info/info-docs.factor b/basis/io/files/info/info-docs.factor index 7e57d66b99..e54588a1b5 100644 --- a/basis/io/files/info/info-docs.factor +++ b/basis/io/files/info/info-docs.factor @@ -13,15 +13,15 @@ HELP: link-info { file-info link-info } related-words HELP: directory? -{ $values { "file-info" file-info } { "?" "a boolean" } } +{ $values { "file-info" file-info } { "?" boolean } } { $description "Tests if " { $snippet "file-info" } " is a directory." } ; HELP: regular-file? -{ $values { "file-info" file-info } { "?" "a boolean" } } +{ $values { "file-info" file-info } { "?" boolean } } { $description "Tests if " { $snippet "file-info" } " is a normal file." } ; HELP: symbolic-link? -{ $values { "file-info" file-info } { "?" "a boolean" } } +{ $values { "file-info" file-info } { "?" boolean } } { $description "Tests if " { $snippet "file-info" } " is a symbolic link." } ; HELP: file-systems diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index bf7c0905f5..6446dc269f 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax combinators csv io.backend io.encodings.utf8 io.files io.files.info -io.files.unix kernel math.order namespaces sequences sorting -system unix unix.statfs.linux unix.statvfs.linux io.files.links +io.files.unix libc libc.linux kernel math.order namespaces sequences +sorting system unix unix.statfs.linux unix.statvfs.linux io.files.links arrays io.files.info.unix assocs io.pathnames unix.types classes.struct ; FROM: csv => delimiter ; @@ -14,7 +14,7 @@ namelen ; M: linux new-file-system-info linux-file-system-info new ; -M: linux file-system-statfs ( path -- byte-array ) +M: linux file-system-statfs ( path -- statfs ) \ statfs64 [ statfs64 io-error ] keep ; M: linux statfs>file-system-info ( file-system-info statfs -- file-system-info' ) @@ -32,7 +32,7 @@ M: linux statfs>file-system-info ( file-system-info statfs -- file-system-info' ! [ statfs64-f_spare >>spare ] } cleave ; -M: linux file-system-statvfs ( path -- byte-array ) +M: linux file-system-statvfs ( path -- statvfs ) \ statvfs64 [ statvfs64 io-error ] keep ; M: linux statvfs>file-system-info ( file-system-info statfs -- file-system-info' ) diff --git a/basis/io/files/info/unix/macosx/macosx.factor b/basis/io/files/info/unix/macosx/macosx.factor index 85658c21e0..dd3e555af6 100644 --- a/basis/io/files/info/unix/macosx/macosx.factor +++ b/basis/io/files/info/unix/macosx/macosx.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types alien.data alien.strings arrays calendar.unix classes.struct combinators grouping io.encodings.utf8 io.files io.files.info io.files.info.unix -io.files.unix kernel math sequences specialized-arrays +io.files.unix libc kernel math sequences specialized-arrays system unix unix.getfsstat.macosx unix.statfs.macosx unix.statvfs.macosx ; SPECIALIZED-ARRAY: uint diff --git a/basis/io/files/info/unix/unix-docs.factor b/basis/io/files/info/unix/unix-docs.factor index 425f76b18d..01ee8f4113 100644 --- a/basis/io/files/info/unix/unix-docs.factor +++ b/basis/io/files/info/unix/unix-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes help.markup help.syntax io.streams.string -strings math calendar io.files.info io.files.info.unix ; +USING: calendar help.markup help.syntax io.files.info kernel +math strings ; IN: io.files.info.unix HELP: add-file-permissions @@ -49,37 +49,37 @@ HELP: file-user-id HELP: group-execute? { $values { "obj" "a pathname string or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: group-read? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "group read" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: group-write? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "group write" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: other-execute? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "other execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: other-read? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "other read" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: other-write? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "other write" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: set-file-access-time @@ -130,98 +130,98 @@ HELP: set-file-modified-time HELP: set-gid { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "gid" } " bit of a file to true or false." } ; HELP: gid? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: set-group-execute { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "group execute" } " bit of a file to true or false." } ; HELP: set-group-read { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "group read" } " bit of a file to true or false." } ; HELP: set-group-write { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "group write" } " bit of a file to true or false." } ; HELP: set-other-execute { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ; HELP: set-other-read { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "other read" } " bit of a file to true or false." } ; HELP: set-other-write { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ; HELP: set-sticky { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "sticky" } " bit of a file to true or false." } ; HELP: sticky? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: set-uid { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "uid" } " bit of a file to true or false." } ; HELP: uid? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: set-user-execute { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "user execute" } " bit of a file to true or false." } ; HELP: set-user-read { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "user read" } " bit of a file to true or false." } ; HELP: set-user-write { $values - { "path" "a pathname string" } { "?" "a boolean" } } + { "path" "a pathname string" } { "?" boolean } } { $description "Sets the " { $snippet "user write" } " bit of a file to true or false." } ; HELP: user-execute? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "user execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: user-read? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "user read" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: user-write? { $values { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } + { "?" boolean } } { $description "Tests whether the " { $snippet "user write" } " bit is set on a file, " { $link file-info } ", or an integer." } ; ARTICLE: "unix-file-permissions" "Unix file permissions" diff --git a/basis/io/files/temp/macosx/macosx.factor b/basis/io/files/temp/macosx/macosx.factor index eb31b1e656..54123c9882 100644 --- a/basis/io/files/temp/macosx/macosx.factor +++ b/basis/io/files/temp/macosx/macosx.factor @@ -1,7 +1,7 @@ ! (c)2012 Joe Groff bsd license USING: alien.c-types alien.syntax cocoa.plists cocoa.runtime cocoa.types core-foundation.strings io.directories io.files -io.files.temp io.pathnames kernel memoize sequences system ; +io.files.temp io.pathnames kernel sequences system ; IN: io.files.temp.macosx -MEMO: (temp-directory) ( -- path ) +: (temp-directory) ( -- path ) NSTemporaryDirectory CF>string (make-factor-bundle-subdir) ; M: macosx temp-directory (temp-directory) ; -MEMO: (cache-directory) ( -- path ) +: (cache-directory) ( -- path ) NSCachesDirectory NSUserDomainMask 1 NSSearchPathForDirectoriesInDomains plist> (first-existing) (make-factor-bundle-subdir) ; diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index 7e8d166b32..0dc85d6b04 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -1,6 +1,4 @@ -USING: help.markup help.syntax io io.ports kernel math -io.pathnames io.directories math.parser io.files strings -quotations io.files.unique.private ; +USING: help.markup help.syntax quotations strings ; IN: io.files.unique HELP: default-temporary-directory @@ -24,7 +22,7 @@ HELP: unique-retries { unique-length unique-retries } related-words HELP: make-unique-file -{ $values { "prefix" "a string" } { "suffix" "a string" } +{ $values { "prefix" string } { "suffix" string } { "path" "a pathname string" } } { $description "Creates a file that is guaranteed not to exist in the directory stored in " { $link current-temporary-directory } ". The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } { $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ; @@ -32,8 +30,8 @@ HELP: make-unique-file { unique-file make-unique-file cleanup-unique-file } related-words HELP: cleanup-unique-file -{ $values { "prefix" "a string" } { "suffix" "a string" } -{ "quot" "a quotation" } } +{ $values { "prefix" string } { "suffix" string } +{ "quot" quotation } } { $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." } { $notes "The unique file will be deleted after calling this word." } ; @@ -43,7 +41,7 @@ HELP: unique-directory { $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ; HELP: cleanup-unique-directory -{ $values { "quot" "a quotation" } } +{ $values { "quot" quotation } } { $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." } { $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation. This combinator is like " { $link with-unique-directory } " but does not delete the directory." } ; diff --git a/basis/io/files/unix/unix.factor b/basis/io/files/unix/unix.factor index e695345125..108f3bd475 100644 --- a/basis/io/files/unix/unix.factor +++ b/basis/io/files/unix/unix.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: unix byte-arrays kernel io.backend.unix math.bitwise -io.ports io.files io.files.private io.pathnames environment -destructors system unix.ffi literals ; +USING: byte-arrays destructors environment io.backend.unix +io.files io.files.private io.pathnames io.ports kernel libc +literals system unix unix.ffi ; IN: io.files.unix M: unix cwd ( -- path ) diff --git a/basis/io/files/windows/windows-docs.factor b/basis/io/files/windows/windows-docs.factor new file mode 100644 index 0000000000..099efaa07c --- /dev/null +++ b/basis/io/files/windows/windows-docs.factor @@ -0,0 +1,13 @@ +USING: help.markup help.syntax ; +IN: io.files.windows + +HELP: open-read +{ $values { "path" "a filesystem path" } { "win32-file" "a win32 file-handle" } } +{ $description "Opens a file for reading and returns a filehandle to it." } +{ $examples + { $unchecked-example + "USING: io.files.windows prettyprint ;" + "\"resource:core/kernel/kernel.factor\" absolute-path open-read ." + "T{ win32-file { handle ALIEN: 234 } { ptr 0 } }" + } +} ; diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index 3617a126f7..b3f4e866bf 100755 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -3,19 +3,17 @@ USING: accessors alien alien.c-types alien.data alien.strings alien.syntax arrays assocs classes.struct combinators combinators.short-circuit continuations destructors environment -io io.backend io.binary io.buffers io.encodings.utf16n io.files +fry io io.backend io.binary io.buffers io.encodings.utf16n io.files io.files.private io.files.types io.pathnames io.ports io.streams.c io.streams.null io.timeouts kernel libc literals locals make math math.bitwise namespaces sequences specialized-arrays system threads tr windows windows.errors windows.handles windows.kernel32 windows.shell32 windows.time -windows.types fry ; +windows.types windows.winsock ; SPECIALIZED-ARRAY: ushort IN: io.files.windows HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) -HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) -HOOK: add-completion io-backend ( port -- port ) HOOK: open-append os ( path -- win32-file ) TUPLE: win32-file < win32-handle ptr ; @@ -25,9 +23,6 @@ TUPLE: win32-file < win32-handle ptr ; M: win32-file dispose [ cancel-operation ] [ call-next-method ] bi ; - -: opened-file ( handle -- win32-file ) - check-invalid-handle |dispose add-completion ; CONSTANT: share-mode flags{ @@ -35,7 +30,7 @@ CONSTANT: share-mode FILE_SHARE_WRITE FILE_SHARE_DELETE } - + : default-security-attributes ( -- obj ) SECURITY_ATTRIBUTES SECURITY_ATTRIBUTES heap-size >>nLength ; @@ -46,16 +41,6 @@ TUPLE: FileArgs C: FileArgs -: make-FileArgs ( port -- ) - { - [ handle>> check-disposed ] - [ handle>> handle>> ] - [ buffer>> ] - [ buffer>> buffer-length ] - [ drop 0 DWORD ] - [ FileArgs-overlapped ] - } cleave ; - ! Global variable with assoc mapping overlapped to threads SYMBOL: pending-overlapped @@ -63,30 +48,20 @@ TUPLE: io-callback port thread ; C: io-callback -: (make-overlapped) ( -- overlapped-ext ) - OVERLAPPED malloc-struct &free ; - -: make-overlapped ( port -- overlapped-ext ) - [ (make-overlapped) ] dip - handle>> ptr>> [ - [ 32 bits >>offset ] - [ -32 shift >>offset-high ] bi - ] when* ; - -M: windows FileArgs-overlapped ( port -- overlapped ) - make-overlapped ; - : ( handle existing -- handle ) f 1 CreateIoCompletionPort dup win32-error=0/f ; -SYMBOL: master-completion-port - : ( -- handle ) INVALID_HANDLE_VALUE f ; -M: windows add-completion ( win32-handle -- win32-handle ) +SYMBOL: master-completion-port + +: add-completion ( win32-handle -- win32-handle ) dup handle>> master-completion-port get-global drop ; +: opened-file ( handle -- win32-file ) + check-invalid-handle |dispose add-completion ; + : eof? ( error -- ? ) { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ; @@ -143,7 +118,7 @@ ERROR: invalid-file-size n ; GetLastError ERROR_INVALID_FUNCTION = [ f ] [ throw-win32-error ] if ] unless* ; - + ERROR: seek-before-start n ; : set-seek-ptr ( n handle -- ) @@ -182,45 +157,66 @@ M: windows handle-length ( handle -- n/f ) : update-file-ptr ( n port -- ) handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; -: finish-write ( n port -- ) - [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; +: (make-overlapped) ( -- overlapped-ext ) + OVERLAPPED malloc-struct &free ; -: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) - { - [ hFile>> ] - [ lpBuffer>> buffer-end ] - [ lpBuffer>> buffer-capacity ] - [ lpNumberOfBytesRet>> ] - [ lpOverlapped>> ] - } cleave ; +: make-overlapped ( handle -- overlapped-ext ) + (make-overlapped) swap + ptr>> [ [ 32 bits >>offset ] [ -32 shift >>offset-high ] bi ] when* ; + +: make-FileArgs ( port handle -- ) + [ nip dup check-disposed handle>> ] + [ + [ buffer>> dup buffer-length 0 DWORD ] dip make-overlapped + ] 2bi ; : setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) { [ hFile>> ] - [ lpBuffer>> buffer@ ] - [ lpBuffer>> buffer-length ] + [ lpBuffer>> [ buffer@ ] [ buffer-length ] bi ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +: finish-write ( n port -- ) + [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; + +M: object drain ( port handle -- event/f ) + [ make-FileArgs dup setup-write WriteFile ] + [ drop [ wait-for-file ] [ finish-write ] bi ] 2bi f ; + +: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> [ buffer-end ] [ buffer-capacity ] bi ] [ lpNumberOfBytesRet>> ] [ lpOverlapped>> ] } cleave ; - -M: windows (wait-to-write) - [ - [ make-FileArgs dup setup-write WriteFile ] - [ wait-for-file ] - [ finish-write ] - tri - ] with-destructors ; : finish-read ( n port -- ) [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ; +M: object refill ( port handle -- event/f ) + [ make-FileArgs dup setup-read ReadFile ] + [ drop [ wait-for-file ] [ finish-read ] bi ] 2bi f ; + +M: windows (wait-to-write) ( port -- ) + [ dup handle>> drain ] with-destructors drop ; + M: windows (wait-to-read) ( port -- ) - [ - [ make-FileArgs dup setup-read ReadFile ] - [ wait-for-file ] - [ finish-read ] - tri - ] with-destructors ; + [ dup handle>> refill ] with-destructors drop ; + +: make-fd-set ( socket -- fd_set ) + fd_set swap 1array void* >c-array >>fd_array 1 >>fd_count ; + +: select-sets ( socket event -- read-fds write-fds except-fds ) + [ make-fd-set ] dip +input+ = [ f f ] [ f swap f ] if ; + +CONSTANT: select-timeval S{ timeval { sec 0 } { usec 1000 } } + +M: windows wait-for-fd ( handle event -- ) + [ file>> handle>> 1 swap ] dip select-sets select-timeval + select drop yield ; : console-app? ( -- ? ) GetConsoleWindow >boolean ; @@ -288,10 +284,10 @@ SLOT: attributes : read-only? ( file-info -- ? ) attributes>> +read-only+ swap member? ; - + : set-file-attributes ( path flags -- ) SetFileAttributes win32-error=0/f ; - + : set-file-normal-attribute ( path -- ) FILE_ATTRIBUTE_NORMAL set-file-attributes ; diff --git a/basis/io/launcher/launcher-docs.factor b/basis/io/launcher/launcher-docs.factor index 60d923be9f..992da3c981 100644 --- a/basis/io/launcher/launcher-docs.factor +++ b/basis/io/launcher/launcher-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations kernel io io.files -math calendar ; +USING: calendar help.markup help.syntax io io.files kernel literals math +quotations sequences ; IN: io.launcher ARTICLE: "io.launcher.command" "Specifying a command" @@ -98,7 +98,14 @@ HELP: get-environment HELP: current-process-handle { $values { "handle" "a process handle" } } -{ $description "Returns the handle of the current process." } ; +{ $description "Returns the handle of the current process." } +{ $examples + { $example + "USING: io.launcher math prettyprint ;" + "current-process-handle number? ." + "t" + } +} ; HELP: run-process* { $values { "process" process } { "handle" "a process handle" } } @@ -108,6 +115,13 @@ HELP: run-process* HELP: run-process { $values { "desc" "a launch descriptor" } { "process" process } } { $description "Launches a process. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." } +{ $examples + { $unchecked-example + "USING: io.launcher prettyprint ;" + "\"pwd\" run-process ." + "T{ process\n { command \"pwd\" }\n { environment H{ } }\n { environment-mode +append-environment+ }\n { group +same-group+ }\n { status 0 }\n}" + } +} { $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; HELP: run-detached @@ -126,13 +140,41 @@ HELP: process-failed HELP: try-process { $values { "desc" "a launch descriptor" } } -{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ; +{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } +{ $examples + { $unchecked-example + "USING: continuations io.launcher prettyprint ;" + "[ \"i-dont-exist\" try-process ] [ ] recover ." + $[ + { + "T{ process-failed" + " { process" + " T{ process" + " { command \"i-dont-exist\" }" + " { environment H{ } }" + " { environment-mode +append-environment+ }" + " { group +same-group+ }" + " { status 255 }" + " }" + " }" + "}" + } "\n" join + ] + } +} ; { run-process try-process run-detached } related-words HELP: kill-process { $values { "process" process } } -{ $description "Kills a running process. Does nothing if the process has already exited." } ; +{ $description "Kills a running process. Does nothing if the process has already exited." } +{ $examples + { $unchecked-example + "USING: io.launcher ;" + "\"cat\" run-detached kill-process" + "" + } +} ; HELP: kill-process* { $values { "process" "process" } } @@ -182,7 +224,14 @@ HELP: with-process-reader { "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." } ; +{ $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." } +{ $examples + { $unchecked-example + "USING: io.launcher prettyprint ;" + "\"ls -dl /etc\" utf8 [ contents ] with-process-reader ." + "\"drwxr-xr-x 213 root root 12288 mar 11 18:52 /etc\\n\"" + } +} ; HELP: with-process-writer { $values diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 79fb29b770..649bbf00bc 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -179,7 +179,7 @@ M: process cancel-operation kill-process ; M: object run-pipeline-element [ >process swap >>stdout swap >>stdin run-detached ] - [ drop [ [ dispose ] when* ] bi@ ] + [ [ drop [ [ &dispose drop ] when* ] bi@ ] with-destructors ] 3bi wait-for-process ; @@ -233,15 +233,15 @@ PRIVATE> : ( desc encoding -- stream process ) [ [ - (pipe) (pipe) { - [ [ |dispose drop ] bi@ ] + (pipe) |dispose + (pipe) |dispose { [ rot >process [ swap in>> or ] change-stdin [ swap out>> or ] change-stdout run-detached ] - [ [ out>> dispose ] [ in>> dispose ] bi* ] + [ [ out>> &dispose drop ] [ in>> &dispose drop ] bi* ] [ [ in>> ] [ out>> ] bi* ] } 2cleave ] dip swap diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index 0a98c80c58..9b685184a0 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -3,8 +3,8 @@ concurrency.promises continuations debugger.unix destructors io io.backend.unix io.directories io.encodings.ascii io.encodings.binary io.encodings.utf8 io.files io.files.temp io.launcher io.launcher.unix io.pathnames io.streams.duplex -io.timeouts kernel locals math namespaces sequences threads -tools.test unix unix.process ; +io.timeouts kernel libc locals math namespaces sequences +threads tools.test unix unix.process ; IN: io.launcher.unix.tests : arch-temp-file ( str -- str' ) diff --git a/basis/io/launcher/unix/unix.factor b/basis/io/launcher/unix/unix.factor index 3c56dd0c27..0f9165a977 100644 --- a/basis/io/launcher/unix/unix.factor +++ b/basis/io/launcher/unix/unix.factor @@ -3,9 +3,9 @@ USING: accessors alien.c-types alien.data arrays assocs combinators continuations environment io io.backend io.backend.unix io.files io.files.private io.files.unix -io.launcher io.pathnames io.ports kernel math namespaces -sequences strings system threads unix unix.process unix.ffi -simple-tokenizer ; +io.launcher io.pathnames io.ports kernel libc math +namespaces sequences strings system threads unix unix.process +unix.ffi simple-tokenizer ; IN: io.launcher.unix : get-arguments ( process -- seq ) diff --git a/basis/io/launcher/windows/test/append.factor b/basis/io/launcher/windows/test/append.factor index 2943b53f70..67aa447edc 100644 --- a/basis/io/launcher/windows/test/append.factor +++ b/basis/io/launcher/windows/test/append.factor @@ -1,2 +1,3 @@ USE: io "Hello appender" print +"Örjan ågren är åter" print diff --git a/basis/io/launcher/windows/test/env.factor b/basis/io/launcher/windows/test/env.factor index 503ca7d018..b97ecc0a84 100644 --- a/basis/io/launcher/windows/test/env.factor +++ b/basis/io/launcher/windows/test/env.factor @@ -1,4 +1,5 @@ USE: system USE: prettyprint +USE: prettyprint.config USE: environment -os-envs . +os-envs [ . ] without-limits \ No newline at end of file diff --git a/basis/io/launcher/windows/windows-tests.factor b/basis/io/launcher/windows/windows-tests.factor index 5dba709844..883d416200 100644 --- a/basis/io/launcher/windows/windows-tests.factor +++ b/basis/io/launcher/windows/windows-tests.factor @@ -1,6 +1,6 @@ USING: accessors arrays assocs calendar continuations environment eval hashtables io io.directories -io.encodings.ascii io.files io.files.temp io.launcher +io.encodings.ascii io.encodings.utf8 io.files io.files.temp io.launcher io.launcher.windows io.pathnames kernel math namespaces parser sequences splitting system tools.test combinators.short-circuit ; IN: io.launcher.windows.tests @@ -92,7 +92,7 @@ IN: io.launcher.windows.tests console-vm "-run=listener" 2array >>command +closed+ >>stdin +stdout+ >>stderr - ascii [ lines last ] with-process-reader + utf8 [ lines last ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -135,7 +135,7 @@ IN: io.launcher.windows.tests console-vm "-script" "stderr.factor" 3array >>command "err2.txt" temp-file >>stderr - ascii stream-lines first + utf8 stream-lines first ] with-directory ] unit-test @@ -143,11 +143,13 @@ IN: io.launcher.windows.tests "err2.txt" temp-file ascii file-lines first ] unit-test + + [ t ] [ launcher-test-path [ console-vm "-script" "env.factor" 3array >>command - ascii stream-contents + utf8 [ contents ] with-process-reader ] with-directory eval( -- alist ) os-envs = @@ -159,9 +161,9 @@ IN: io.launcher.windows.tests console-vm "-script" "env.factor" 3array >>command +replace-environment+ >>environment-mode os-envs >>environment - ascii stream-contents + utf8 [ contents ] with-process-reader ] with-directory eval( -- alist ) - + os-envs = ] unit-test @@ -170,7 +172,7 @@ IN: io.launcher.windows.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment - ascii stream-contents + utf8 [ contents ] with-process-reader ] with-directory eval( -- alist ) "A" of @@ -182,7 +184,7 @@ IN: io.launcher.windows.tests console-vm "-script" "env.factor" 3array >>command { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode - ascii stream-contents + utf8 [ contents ] with-process-reader ] with-directory eval( -- alist ) "USERPROFILE" of "XXX" = @@ -201,7 +203,7 @@ IN: io.launcher.windows.tests [ "append-test" temp-file delete-file ] ignore-errors -[ "Hello appender\r\nHello appender\r\n" ] [ +{ "Hello appender\r\nÖrjan ågren är åter\r\nHello appender\r\nÖrjan ågren är åter\r\n" } [ 2 [ launcher-test-path [ @@ -210,8 +212,8 @@ IN: io.launcher.windows.tests try-process ] with-directory ] times - - "append-test" temp-file ascii file-contents + + "append-test" temp-file utf8 file-contents ] unit-test [ "IN: scratchpad " ] [ diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index 49d44616bf..b5bfff28ab 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -18,13 +18,13 @@ HELP: { $errors "Throws an error if a memory mapping could not be established." } ; HELP: with-mapped-file -{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } +{ $values { "path" "a pathname string" } { "quot" { $quotation ( mmap -- ) } } } { $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 -- )" } } } +{ $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. See " { $link "io.mmap.arrays" } " for a discussion of how to access data in a mapped file." } { $errors "Throws an error if a memory mapping could not be established." } ; diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index ec51de4261..67c245d956 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -1,9 +1,7 @@ ! Copyright (C) 2007, 2009 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: continuations destructors io.files io.files.info -io.backend kernel quotations system alien alien.accessors -accessors vocabs combinators alien.c-types alien.data -math ; +USING: accessors alien.c-types alien.data combinators +destructors io.backend io.files.info kernel math system vocabs ; IN: io.mmap TUPLE: mapped-file < disposable address handle length ; diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 84378efeb8..9703561b91 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors destructors io.backend.unix io.mmap literals -io.mmap.private kernel locals math.bitwise system unix unix.ffi ; +USING: accessors destructors io.backend.unix io.mmap +io.mmap.private kernel libc literals locals system unix +unix.ffi ; IN: io.mmap.unix :: mmap-open ( path length prot flags open-mode -- alien fd ) diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor index 9b2440aec8..d1047e7fbe 100755 --- a/basis/io/monitors/linux/linux.factor +++ b/basis/io/monitors/linux/linux.factor @@ -3,7 +3,7 @@ USING: kernel io.backend io.monitors io.monitors.recursive io.files io.pathnames io.buffers io.ports io.timeouts io.backend.unix io.encodings.utf8 unix.linux.inotify assocs -namespaces make threads continuations init math math.bitwise +namespaces make threads continuations init libc math math.bitwise sets alien alien.strings alien.c-types vocabs.loader accessors system hashtables destructors unix classes.struct literals ; FROM: namespaces => set ; diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor index 2fa13862a4..687478a59f 100644 --- a/basis/io/monitors/monitors-docs.factor +++ b/basis/io/monitors/monitors-docs.factor @@ -1,6 +1,6 @@ IN: io.monitors -USING: help.markup help.syntax continuations destructors -concurrency.mailboxes quotations ; +USING: concurrency.mailboxes destructors help.markup help.syntax +kernel quotations ; HELP: with-monitors { $values { "quot" quotation } } @@ -8,12 +8,12 @@ HELP: with-monitors { $errors "Throws an error if the platform does not support file system change monitors." } ; HELP: -{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } } +{ $values { "path" "a pathname string" } { "recursive?" boolean } { "monitor" "a new monitor" } } { $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." } { $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; HELP: (monitor) -{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } } +{ $values { "path" "a pathname string" } { "recursive?" boolean } { "mailbox" mailbox } { "monitor" "a new monitor" } } { $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." } { $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; @@ -26,7 +26,7 @@ HELP: next-change { $errors "Throws an error if the monitor is closed from another thread." } ; HELP: with-monitor -{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" { $quotation "( monitor -- )" } } } +{ $values { "path" "a pathname string" } { "recursive?" boolean } { "quot" { $quotation ( monitor -- ) } } } { $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } { $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; diff --git a/basis/io/monitors/recursive/recursive-tests.factor b/basis/io/monitors/recursive/recursive-tests.factor index 947c9ce01d..ef4c4656e4 100644 --- a/basis/io/monitors/recursive/recursive-tests.factor +++ b/basis/io/monitors/recursive/recursive-tests.factor @@ -1,19 +1,19 @@ USING: accessors math kernel namespaces continuations io.files io.monitors io.monitors.recursive io.backend concurrency.mailboxes tools.test destructors io.files.info -io.pathnames io.files.temp io.directories.hierarchy ; +io.pathnames io.files.temp io.directories.hierarchy fry ; IN: io.monitors.recursive.tests SINGLETON: mock-io-backend -TUPLE: counter i ; +TUPLE: mock-counter i ; SYMBOL: dummy-monitor-created SYMBOL: dummy-monitor-disposed TUPLE: dummy-monitor < monitor ; -M: dummy-monitor dispose +M: dummy-monitor dispose* drop dummy-monitor-disposed get [ 1 + ] change-i drop ; M: mock-io-backend (monitor) @@ -28,12 +28,12 @@ M: mock-io-backend (monitor) M: mock-io-backend link-info global [ link-info ] with-variables ; -[ ] [ 0 counter boa dummy-monitor-created set ] unit-test -[ ] [ 0 counter boa dummy-monitor-disposed set ] unit-test +[ ] [ 0 mock-counter boa dummy-monitor-created set ] unit-test +[ ] [ 0 mock-counter boa dummy-monitor-disposed set ] unit-test [ ] [ mock-io-backend io-backend [ - "" resource-path dispose + "resource:core/io" resource-path dispose ] with-variable ] unit-test @@ -44,14 +44,18 @@ M: mock-io-backend link-info [ "doesnotexist" temp-file delete-tree ] ignore-errors [ - mock-io-backend io-backend [ - "doesnotexist" temp-file dispose + 0 mock-counter boa dummy-monitor-created [ + mock-io-backend io-backend [ + "doesnotexist" temp-file dispose + ] with-variable ] with-variable ] must-fail +[ ] [ 0 mock-counter boa dummy-monitor-created set ] unit-test +[ ] [ 0 mock-counter boa dummy-monitor-disposed set ] unit-test + +! Test that disposing twice is allowed [ ] [ - mock-io-backend io-backend [ - "" resource-path - [ dispose ] [ dispose ] bi - ] with-variable + "resource:core/io" resource-path + [ dispose ] [ dispose ] bi ] unit-test diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index 70daed9018..b0c86a215f 100755 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -69,7 +69,7 @@ M: recursive-monitor dispose* { +rename-file-new+ [ child-added ] } [ 3drop ] } case - ] with with each ; + ] 2with each ; : pump-loop ( -- ) receive { @@ -100,9 +100,11 @@ M: recursive-monitor dispose* ready>> ?promise ?linked drop ; : ( path mailbox -- monitor ) - [ absolute-path ] dip - recursive-monitor new-monitor - H{ } clone >>children - >>ready - dup start-pump-thread - dup wait-for-ready ; + [ + [ absolute-path ] dip + recursive-monitor new-monitor |dispose + H{ } clone >>children + >>ready + dup start-pump-thread + dup wait-for-ready + ] with-destructors ; diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index 62499f5d4f..f10ccd1e64 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -9,7 +9,10 @@ IN: io.pipes TUPLE: pipe in out ; M: pipe dispose ( pipe -- ) - [ in>> dispose ] [ out>> dispose ] bi ; + [ + [ in>> &dispose drop ] + [ out>> &dispose drop ] bi + ] with-destructors ; HOOK: (pipe) io-backend ( -- pipe ) diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor index 2ac4964697..92058e805f 100644 --- a/basis/io/pipes/unix/unix.factor +++ b/basis/io/pipes/unix/unix.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.data system kernel unix math sequences -io.backend.unix io.ports specialized-arrays accessors unix.ffi ; +io.backend.unix io.ports libc specialized-arrays accessors unix.ffi ; QUALIFIED: io.pipes SPECIALIZED-ARRAY: int IN: io.pipes.unix diff --git a/basis/io/pools/pools-docs.factor b/basis/io/pools/pools-docs.factor index 80c8b2d925..16f651f423 100644 --- a/basis/io/pools/pools-docs.factor +++ b/basis/io/pools/pools-docs.factor @@ -22,7 +22,7 @@ HELP: return-connection { $description "Returns a connection to the pool." } ; HELP: with-pooled-connection -{ $values { "pool" pool } { "quot" { $quotation "( conn -- )" } } } +{ $values { "pool" pool } { "quot" { $quotation ( conn -- ) } } } { $description "Calls a quotation with a pooled connection on the stack. If the quotation returns successfully, the connection is returned to the pool; if the quotation throws an error, the connection is disposed of with " { $link dispose } "." } ; HELP: make-connection diff --git a/basis/io/ports/ports-docs.factor b/basis/io/ports/ports-docs.factor index 2eb9280444..d7f23c8be0 100644 --- a/basis/io/ports/ports-docs.factor +++ b/basis/io/ports/ports-docs.factor @@ -72,5 +72,5 @@ HELP: (wait-to-read) { $contract "Suspends the current thread until the port's buffer has data available for reading." } ; HELP: wait-to-read -{ $values { "port" input-port } { "eof?" "a boolean" } } +{ $values { "port" input-port } { "eof?" boolean } } { $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ; diff --git a/basis/io/ports/ports-tests.factor b/basis/io/ports/ports-tests.factor index b2acabc329..9fb5a5826b 100644 --- a/basis/io/ports/ports-tests.factor +++ b/basis/io/ports/ports-tests.factor @@ -25,7 +25,7 @@ IN: io.ports.tests [ ] [ "test.txt" temp-file delete-file ] unit-test ! Getting the stream-element-type of an output-port was broken -[ +byte+ ] [ binary [ stream-element-type ] [ dispose ] bi ] unit-test -[ +byte+ ] [ binary [ out>> stream-element-type ] [ dispose ] bi ] unit-test -[ +character+ ] [ ascii [ stream-element-type ] [ dispose ] bi ] unit-test -[ +character+ ] [ ascii [ out>> stream-element-type ] [ dispose ] bi ] unit-test \ No newline at end of file +[ +byte+ ] [ binary [ stream-element-type ] with-disposal ] unit-test +[ +byte+ ] [ binary [ out>> stream-element-type ] with-disposal ] unit-test +[ +character+ ] [ ascii [ stream-element-type ] with-disposal ] unit-test +[ +character+ ] [ ascii [ out>> stream-element-type ] with-disposal ] unit-test diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 5b48db5175..2697ac6d80 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -1,13 +1,10 @@ ! Copyright (C) 2005, 2010 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types alien.data assocs -byte-arrays byte-vectors classes combinators continuations -destructors dlists fry generic grouping hints io io.backend -io.buffers io.encodings io.encodings.ascii io.encodings.binary -io.encodings.private io.encodings.utf8 io.timeouts kernel libc -locals math math.order namespaces sequences specialized-arrays -specialized-arrays.instances.alien.c-types.uchar splitting -strings summary system io.files kernel.private ; +USING: accessors alien alien.c-types alien.data byte-arrays +combinators destructors fry grouping hints io io.backend +io.buffers io.encodings io.files io.timeouts kernel +kernel.private libc locals math math.order namespaces sequences +strings system ; IN: io.ports SYMBOL: default-buffer-size @@ -127,7 +124,7 @@ M: output-port stream-write1 : write-in-groups ( byte-array port -- ) [ binary-object uchar ] dip [ buffer>> size>> ] [ '[ _ stream-write ] ] bi - each ; + each ; inline M: output-port stream-write dup check-disposed @@ -142,7 +139,7 @@ HOOK: (wait-to-write) io-backend ( port -- ) : port-flush ( port -- ) dup buffer>> buffer-empty? - [ drop ] [ dup (wait-to-write) port-flush ] if ; + [ drop ] [ dup (wait-to-write) port-flush ] if ; inline recursive M: output-port stream-flush [ check-disposed ] [ port-flush ] bi ; diff --git a/basis/io/sockets/secure/openssl/openssl-docs.factor b/basis/io/sockets/secure/openssl/openssl-docs.factor new file mode 100644 index 0000000000..f917621d17 --- /dev/null +++ b/basis/io/sockets/secure/openssl/openssl-docs.factor @@ -0,0 +1,48 @@ +USING: help.markup help.syntax io.files io.buffers kernel openssl.libssl +strings sequences ; +IN: io.sockets.secure.openssl + +HELP: subject-name +{ $values { "certificate" "an SSL peer certificate" } { "host" string } } +{ $description "The subject name of a certificate." } ; + +HELP: subject-names-match? +{ $values { "host" "a host name" } { "subject" "a subject name" } { "?" boolean } } +{ $description "True if the host name matches the subject name." } +{ $examples + { $code + "\"www.google.se\" \"*.google.se\" subject-names-match?" + "t" + } +} ; + +HELP: alternative-dns-names +{ $values { "certificate" "an SSL peer certificate" } { "dns-names" sequence } } +{ $description "Alternative subject names for the certificate." } ; + +HELP: do-ssl-connect +{ $values { "ssl-handle" ssl-handle } } +{ $description "Connects the SSL handle to the remote server. Blocks until the connection is established or an error is thrown." } ; + +HELP: do-ssl-read +{ $values + { "buffer" buffer } + { "ssl" SSL } + { "event/f" "f or a symbol indicating the desired operation" } } +{ $description "Reads from the ssl connection to the buffer." } ; + +HELP: do-ssl-write +{ $values + { "buffer" buffer } + { "ssl" SSL } + { "event/f" "f or a symbol indicating the desired operation" } } +{ $description "Writes from the buffer to the ssl connection." } ; + +HELP: check-ssl-error +{ $values + { "ssl" SSL } + { "ret" "error code returned by an SSL function" } + { "exra-cases/f" "f or an assoc of error codes and quotations" } + { "event/f" "f or a symbol indicating the desired operation" } +} +{ $description "Checks if the last SSL function returned successfully or not. If so, returns " { $link f } " or a symbol, " { $link +input+ } " or " { $link +output+ } ", that indicates the socket operation required by libssl." } ; diff --git a/basis/io/sockets/secure/openssl/openssl-tests.factor b/basis/io/sockets/secure/openssl/openssl-tests.factor new file mode 100644 index 0000000000..41aa9d809a --- /dev/null +++ b/basis/io/sockets/secure/openssl/openssl-tests.factor @@ -0,0 +1,16 @@ +USING: accessors http.client http.server io.servers +io.sockets.secure io.sockets.secure.openssl kernel tools.test ; +IN: io.sockets.secure.openssl.tests + +{ 200 } [ "https://www.google.se" http-get drop code>> ] unit-test + +[ + 8887 >>insecure f >>secure [ + "https://localhost:8887" http-get + ] with-threaded-server +] must-fail +! XXX: Make this fail with certificate-missing-error? on Windows someday. +! ] [ certificate-missing-error? ] must-fail-with + +[ "test" 33 handle>> check-subject-name ] +[ certificate-missing-error? ] must-fail-with diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 49b9820574..4f1d621df7 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -1,11 +1,14 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays kernel sequences namespaces math -math.order combinators init alien alien.c-types alien.data -alien.strings libc continuations destructors summary splitting -assocs random math.parser locals unicode.case openssl -openssl.libcrypto openssl.libssl io.backend io.ports io.pathnames -io.encodings.8-bit.latin1 io.timeouts io.sockets.secure ; +USING: accessors alien alien.c-types alien.data alien.strings +assocs byte-arrays classes.struct combinators destructors fry io +io.backend io.buffers io.encodings.8-bit.latin1 +io.encodings.utf8 io.files io.pathnames io.ports io.sockets +io.sockets.secure io.timeouts kernel libc + +locals math math.order math.parser namespaces openssl +openssl.libcrypto openssl.libssl random sequences splitting +unicode.case ; IN: io.sockets.secure.openssl GENERIC: ssl-method ( symbol -- method ) @@ -23,9 +26,17 @@ TUPLE: openssl-context < secure-context aliens sessions ; [ 32 random-bits >hex dup length SSL_CTX_set_session_id_context ssl-error ] bi ; +ERROR: file-expected path ; + +: ensure-exists ( path -- path ) + dup exists? [ file-expected ] unless ; inline + +: ssl-file-path ( path -- path' ) + absolute-path ensure-exists ; + : load-certificate-chain ( ctx -- ) dup config>> key-file>> [ - [ handle>> ] [ config>> key-file>> absolute-path ] bi + [ handle>> ] [ config>> key-file>> ssl-file-path ] bi SSL_CTX_use_certificate_chain_file ssl-error ] [ drop ] if ; @@ -55,7 +66,8 @@ TUPLE: openssl-context < secure-context aliens sessions ; : use-private-key-file ( ctx -- ) dup config>> key-file>> [ - [ handle>> ] [ config>> key-file>> absolute-path ] bi + [ handle>> ] + [ config>> key-file>> ssl-file-path ] bi SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file ssl-error ] [ drop ] if ; @@ -65,8 +77,8 @@ TUPLE: openssl-context < secure-context aliens sessions ; [ handle>> ] [ config>> - [ ca-file>> dup [ absolute-path ] when ] - [ ca-path>> dup [ absolute-path ] when ] bi + [ ca-file>> dup [ ssl-file-path ] when ] + [ ca-path>> dup [ ssl-file-path ] when ] bi ] bi SSL_CTX_load_verify_locations ] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ; @@ -151,6 +163,12 @@ SYMBOL: default-secure-context ] initialize-alien ] unless* ; +: get-session ( addrspec -- session/f ) + current-secure-context sessions>> at ; + +: save-session ( session addrspec -- ) + current-secure-context sessions>> set-at ; + : ( fd -- ssl ) [ ssl-handle new-disposable |dispose @@ -159,6 +177,103 @@ SYMBOL: default-secure-context swap >>file ] with-destructors ; +: ( winsock -- ssl ) + [ + socket-handle BIO_NOCLOSE BIO_new_socket dup ssl-error + ] keep + [ handle>> swap dup SSL_set_bio ] keep ; + +! Error handling +: syscall-error ( r -- event ) + ERR_get_error [ + { + { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] } + ! OpenSSL docs say this it is an error condition for + ! a server to not send a close notify, but web + ! servers in the wild don't seem to do this, for + ! example https://www.google.com. + { 0 [ f ] } + } case + ] [ nip (ssl-error) ] if-zero ; + +: check-ssl-error ( ssl ret exra-cases/f -- event/f ) + [ swap over SSL_get_error ] dip + { + { SSL_ERROR_NONE [ drop f ] } + { SSL_ERROR_WANT_READ [ drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ drop (ssl-error) ] } + } append [ [ execute( -- n ) ] dip ] assoc-map + at [ call( x -- y ) ] [ no-cond ] if* ; + +! Accept +: do-ssl-accept-once ( ssl -- event/f ) + dup SSL_accept { + { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] } + { SSL_ERROR_WANT_ACCEPT [ drop +input+ ] } + } check-ssl-error ; + +: do-ssl-accept ( ssl-handle -- ) + dup handle>> do-ssl-accept-once + [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ drop ] if* ; + +: maybe-handshake ( ssl-handle -- ) + dup connected>> [ drop ] [ + t >>connected + [ do-ssl-accept ] with-timeout + ] if ; + +! Input ports +: do-ssl-read ( buffer ssl -- event/f ) + 2dup swap [ buffer-end ] [ buffer-capacity ] bi SSL_read [ + { { SSL_ERROR_ZERO_RETURN [ drop f ] } } check-ssl-error + ] keep swap [ 2nip ] [ swap n>buffer f ] if* ; + +M: ssl-handle refill ( port handle -- event/f ) + dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-read ; + +! Output ports +: do-ssl-write ( buffer ssl -- event/f ) + 2dup swap [ buffer@ ] [ buffer-length ] bi SSL_write + [ f check-ssl-error ] keep swap [ 2nip ] [ swap buffer-consume f ] if* ; + +M: ssl-handle drain ( port handle -- event/f ) + dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-write ; + +! Connect +: do-ssl-connect-once ( ssl -- event/f ) + dup SSL_connect f check-ssl-error ; + +: do-ssl-connect ( ssl-handle -- ) + dup handle>> do-ssl-connect-once + [ dupd wait-for-fd do-ssl-connect ] [ drop ] if* ; + +: resume-session ( ssl-handle ssl-session -- ) + [ [ handle>> ] dip SSL_set_session ssl-error ] + [ drop do-ssl-connect ] + 2bi ; + +: begin-session ( ssl-handle addrspec -- ) + [ drop do-ssl-connect ] + [ [ handle>> SSL_get1_session ] dip save-session ] + 2bi ; + +: secure-connection ( client-out addrspec -- ) + [ handle>> ] dip + [ + '[ + _ dup get-session + [ resume-session ] [ begin-session ] ?if + ] with-timeout + ] [ drop t >>connected drop ] 2bi ; + +M: ssl-handle timeout + drop secure-socket-timeout get ; + +M: ssl-handle cancel-operation + file>> cancel-operation ; + M: ssl-handle dispose* [ ! Free file>> after SSL_free @@ -170,32 +285,71 @@ M: ssl-handle dispose* SSL_get_verify_result dup X509_V_OK = [ drop ] [ verify-message certificate-verify-error ] if ; -: common-name ( certificate -- host ) - X509_get_subject_name +: x509name>string ( x509name -- string ) NID_commonName 256 [ 256 X509_NAME_get_text_by_NID ] keep swap -1 = [ drop f ] [ latin1 alien>string ] if ; -: common-names-match? ( expected actual -- ? ) +: subject-name ( certificate -- host ) + X509_get_subject_name x509name>string ; + +: issuer-name ( certificate -- issuer ) + X509_get_issuer_name x509name>string ; + +: name-stack>sequence ( name-stack -- seq ) + dup sk_num iota [ sk_value GENERAL_NAME_st memory>struct ] with map ; + +: alternative-dns-names ( certificate -- dns-names ) + NID_subject_alt_name f f X509_get_ext_d2i + [ name-stack>sequence ] [ f ] if* + [ type>> GEN_DNS = ] filter + [ d>> dNSName>> data>> utf8 alien>string ] map ; + +: subject-names-match? ( host subject -- ? ) [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ; -: check-common-name ( host ssl-handle -- ) - SSL_get_peer_certificate common-name - 2dup common-names-match? - [ 2drop ] [ common-name-verify-error ] if ; +: check-subject-name ( host ssl-handle -- ) + SSL_get_peer_certificate [ + [ alternative-dns-names ] [ subject-name ] bi suffix + 2dup [ subject-names-match? ] with any? + [ 2drop ] [ subject-name-verify-error ] if + ] [ certificate-missing-error ] if* ; M: openssl check-certificate ( host ssl -- ) current-secure-context config>> verify>> [ handle>> [ nip check-verify-result ] - [ check-common-name ] + [ check-subject-name ] 2bi ] [ 2drop ] if ; -: get-session ( addrspec -- session/f ) - current-secure-context sessions>> at ; +: check-buffer ( port -- port ) + dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ; -: save-session ( session addrspec -- ) - current-secure-context sessions>> set-at ; +: input/output-ports ( -- input output ) + input-stream output-stream + [ get underlying-port check-buffer ] bi@ + 2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ; + +: make-input/output-secure ( input output -- ) + dup handle>> non-ssl-socket? [ upgrade-on-non-socket ] unless + [ ] change-handle + handle>> >>handle drop ; + +: (send-secure-handshake) ( output -- ) + remote-address get [ upgrade-on-non-socket ] unless* + secure-connection ; + +M: openssl send-secure-handshake + input/output-ports + [ make-input/output-secure ] keep + [ (send-secure-handshake) ] keep + remote-address get dup inet? [ + host>> swap handle>> check-certificate + ] [ 2drop ] if ; + +M: openssl accept-secure-handshake ( -- ) + input/output-ports + make-input/output-secure ; openssl secure-socket-backend set-global diff --git a/basis/io/sockets/secure/secure-docs.factor b/basis/io/sockets/secure/secure-docs.factor index 139e036241..dc9b3a6abd 100644 --- a/basis/io/sockets/secure/secure-docs.factor +++ b/basis/io/sockets/secure/secure-docs.factor @@ -126,8 +126,8 @@ HELP: premature-close HELP: certificate-verify-error { $error-description "Thrown if certificate verification failed. The " { $snippet "result" } " slot contains an object identifying the low-level error that occurred." } ; -HELP: common-name-verify-error -{ $error-description "Thrown during certificate verification if the host name on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $slot "expected" } " and " { $slot "got" } " slots contain the mismatched host names." } ; +HELP: subject-name-verify-error +{ $error-description "Thrown during certificate verification if the subject names on the certificate does not match the host name the socket was connected to. This indicates a potential man-in-the-middle attack. The " { $slot "expected" } " and " { $slot "got" } " slots contain the mismatched host names." } ; HELP: upgrade-on-non-socket { $error-description "Thrown if " { $link send-secure-handshake } " or " { $link accept-secure-handshake } " is called with the " { $link input-stream } " and " { $link output-stream } " variables not set to a socket. This error can also indicate that the connection has already been upgraded to a secure connection." } ; @@ -141,7 +141,7 @@ ARTICLE: "ssl-errors" "Secure socket errors" { $subsections premature-close certificate-verify-error - common-name-verify-error + subject-name-verify-error } "The " { $link send-secure-handshake } " word can throw one of two errors:" { $subsections diff --git a/basis/io/sockets/secure/secure-tests.factor b/basis/io/sockets/secure/secure-tests.factor index b5af130168..79d2ceaf46 100644 --- a/basis/io/sockets/secure/secure-tests.factor +++ b/basis/io/sockets/secure/secure-tests.factor @@ -1,5 +1,5 @@ IN: io.sockets.secure.tests -USING: accessors kernel io.sockets io.sockets.secure tools.test ; +USING: accessors kernel io.sockets io.sockets.secure system tools.test ; [ "hello" 24 ] [ "hello" 24 [ host>> ] [ port>> ] bi ] unit-test @@ -10,3 +10,5 @@ USING: accessors kernel io.sockets io.sockets.secure tools.test ; "password" >>password [ ] with-secure-context ] unit-test + +[ t ] [ os windows? ssl-certificate-verification-supported? or ] unit-test diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor index c0d0598adb..9e6f55569e 100644 --- a/basis/io/sockets/secure/secure.factor +++ b/basis/io/sockets/secure/secure.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel namespaces continuations destructors io -debugger io.sockets io.sockets.private sequences summary -calendar delegate system vocabs combinators present ; +USING: accessors calendar combinators delegate destructors io +io.sockets io.sockets.private kernel namespaces present +sequences summary system vocabs ; IN: io.sockets.secure SYMBOL: secure-socket-timeout @@ -12,8 +12,10 @@ SYMBOL: secure-socket-timeout SYMBOL: secure-socket-backend HOOK: ssl-supported? secure-socket-backend ( -- ? ) +HOOK: ssl-certificate-verification-supported? secure-socket-backend ( -- ? ) M: object ssl-supported? f ; +M: object ssl-certificate-verification-supported? f ; SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ; @@ -30,7 +32,7 @@ ephemeral-key-bits ; secure-config new SSLv23 >>method 1024 >>ephemeral-key-bits - t >>verify ; + ssl-certificate-verification-supported? >>verify ; TUPLE: secure-context < disposable config handle ; @@ -77,10 +79,15 @@ ERROR: certificate-verify-error result ; M: certificate-verify-error summary drop "Certificate verification failed" ; -ERROR: common-name-verify-error expected got ; +ERROR: subject-name-verify-error expected got ; -M: common-name-verify-error summary - drop "Common name verification failed" ; +M: subject-name-verify-error summary + drop "Subject name verification failed" ; + +ERROR: certificate-missing-error ; + +M: certificate-missing-error summary + drop "Host did not present any certificate" ; ERROR: upgrade-on-non-socket ; @@ -95,11 +102,15 @@ M: upgrade-buffers-full summary drop "send-secure-handshake can only be used if buffers are empty" ; +HOOK: non-ssl-socket? os ( obj -- ? ) + +HOOK: socket-handle os ( obj -- ? ) + HOOK: send-secure-handshake secure-socket-backend ( -- ) HOOK: accept-secure-handshake secure-socket-backend ( -- ) { { [ os unix? ] [ "io.sockets.secure.unix" require ] } - { [ os windows? ] [ "openssl" require ] } + { [ os windows? ] [ "io.sockets.secure.windows" require ] } } cond diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index 0fb4a44dc5..125e442e61 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -1,109 +1,18 @@ ! Copyright (C) 2007, 2011, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors unix byte-arrays kernel sequences namespaces -math math.order combinators init alien alien.c-types -alien.strings libc continuations destructors openssl -openssl.libcrypto openssl.libssl io io.files io.ports -io.backend.unix io.sockets.unix io.encodings.ascii io.buffers -io.sockets io.sockets.private io.sockets.secure -io.sockets.secure.openssl io.timeouts system summary fry -unix.ffi ; +USING: accessors combinators destructors io.backend.unix +io.files io.sockets.private io.sockets.secure +io.sockets.secure.openssl io.timeouts kernel math openssl +openssl.libssl system ; FROM: io.ports => shutdown ; IN: io.sockets.secure.unix M: openssl ssl-supported? t ; +M: openssl ssl-certificate-verification-supported? t ; M: ssl-handle handle-fd file>> handle-fd ; -: syscall-error ( handle r -- event ) - nip - ERR_get_error [ - { - { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] } - ! OpenSSL docs say this it is an error condition for - ! a server to not send a close notify, but web - ! servers in the wild don't seem to do this, for - ! example https://www.google.com. - { 0 [ f ] } - } case - ] [ nip (ssl-error) ] if-zero ; - -: check-accept-response ( handle r -- event ) - over handle>> over SSL_get_error - { - { SSL_ERROR_NONE [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -: do-ssl-accept ( ssl-handle -- ) - dup dup handle>> SSL_accept check-accept-response dup - [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ; - -: maybe-handshake ( ssl-handle -- ) - dup connected>> [ drop ] [ - t >>connected - [ do-ssl-accept ] with-timeout - ] if ; - -: check-response ( port r -- port r n ) - over handle>> handle>> over SSL_get_error ; inline - -! Input ports -: check-read-response ( port r -- event ) - check-response - { - { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } - { SSL_ERROR_ZERO_RETURN [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -M: ssl-handle refill - dup maybe-handshake - handle>> ! ssl - over buffer>> - [ buffer-end ] ! buf - [ buffer-capacity ] bi ! len - SSL_read - check-read-response ; - -! Output ports -: check-write-response ( port r -- event ) - check-response - { - { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -M: ssl-handle drain - dup maybe-handshake - handle>> ! ssl - over buffer>> - [ buffer@ ] ! buf - [ buffer-length ] bi ! len - SSL_write - check-write-response ; - -M: ssl-handle cancel-operation - file>> cancel-operation ; - -M: ssl-handle timeout - drop secure-socket-timeout get ; - -! Client sockets -: ( fd -- ssl ) - [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep - [ handle>> swap dup SSL_set_bio ] keep ; +M: unix socket-handle fd>> ; M: secure ((client)) ( addrspec -- handle ) addrspec>> ((client)) ; @@ -112,39 +21,6 @@ M: secure parse-sockaddr addrspec>> parse-sockaddr ; M: secure (get-local-address) addrspec>> (get-local-address) ; -: check-connect-response ( ssl-handle r -- event ) - over handle>> over SSL_get_error - { - { SSL_ERROR_NONE [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -: do-ssl-connect ( ssl-handle -- ) - dup dup handle>> SSL_connect check-connect-response dup - [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ; - -: resume-session ( ssl-handle ssl-session -- ) - [ [ handle>> ] dip SSL_set_session ssl-error ] - [ drop do-ssl-connect ] - 2bi ; - -: begin-session ( ssl-handle addrspec -- ) - [ drop do-ssl-connect ] - [ [ handle>> SSL_get1_session ] dip save-session ] - 2bi ; - -: secure-connection ( client-out addrspec -- ) - [ handle>> ] dip - [ - '[ - _ dup get-session - [ resume-session ] [ begin-session ] ?if - ] with-timeout - ] [ drop t >>connected drop ] 2bi ; - M: secure establish-connection ( client-out remote -- ) addrspec>> [ establish-connection ] [ secure-connection ] 2bi ; @@ -165,7 +41,7 @@ M: secure (accept) { SSL_ERROR_NONE [ 2drop f ] } { SSL_ERROR_WANT_READ [ 2drop +input+ ] } { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ [ drop f ] [ syscall-error ] if-zero ] } + { SSL_ERROR_SYSCALL [ [ drop f ] [ nip syscall-error ] if-zero ] } { SSL_ERROR_SSL [ (ssl-error) ] } } case ; @@ -178,31 +54,4 @@ M: ssl-handle shutdown f >>connected [ (shutdown) ] with-timeout ] [ drop ] if ; -: check-buffer ( port -- port ) - dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ; - -: input/output-ports ( -- input output ) - input-stream output-stream - [ get underlying-port check-buffer ] bi@ - 2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ; - -: make-input/output-secure ( input output -- ) - dup handle>> fd? [ upgrade-on-non-socket ] unless - [ ] change-handle - handle>> >>handle drop ; - -: (send-secure-handshake) ( output -- ) - remote-address get [ upgrade-on-non-socket ] unless* - secure-connection ; - -M: openssl send-secure-handshake - input/output-ports - [ make-input/output-secure ] keep - [ (send-secure-handshake) ] keep - remote-address get dup inet? [ - host>> swap handle>> check-certificate - ] [ 2drop ] if ; - -M: openssl accept-secure-handshake - input/output-ports - make-input/output-secure ; +M: unix non-ssl-socket? ( obj -- ? ) fd? ; diff --git a/basis/io/sockets/secure/windows/platforms.txt b/basis/io/sockets/secure/windows/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/basis/io/sockets/secure/windows/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/basis/io/sockets/secure/windows/windows.factor b/basis/io/sockets/secure/windows/windows.factor new file mode 100644 index 0000000000..95525a170e --- /dev/null +++ b/basis/io/sockets/secure/windows/windows.factor @@ -0,0 +1,26 @@ +USING: accessors alien io.ports io.sockets.private io.sockets.secure +io.sockets.secure.openssl io.sockets.windows kernel locals openssl +openssl.libcrypto openssl.libssl windows.winsock system ; +IN: io.sockets.secure.windows + +M: openssl ssl-supported? t ; +M: openssl ssl-certificate-verification-supported? f ; + +M: windows socket-handle handle>> alien-address ; + +M: secure ((client)) ( addrspec -- handle ) + addrspec>> ((client)) ; + +M: secure (get-local-address) ( handle remote -- sockaddr ) + [ file>> ] [ addrspec>> ] bi* (get-local-address) ; + +M: secure parse-sockaddr addrspec>> parse-sockaddr ; + +M:: secure establish-connection ( client-out addrspec -- ) + client-out handle>> file>> :> socket + socket FIONBIO 1 set-ioctl-socket + socket addrspec addrspec>> establish-connection + client-out addrspec secure-connection + socket FIONBIO 0 set-ioctl-socket ; + +M: windows non-ssl-socket? win32-socket? ; diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index 7fae4677fa..d40991991b 100644 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.backend threads -strings byte-arrays continuations destructors quotations ; +strings byte-arrays continuations destructors quotations math ; IN: io.sockets ARTICLE: "network-addressing" "Address specifiers" @@ -154,7 +154,16 @@ HELP: HELP: with-client { $values { "remote" "an address specifier" } { "encoding" "an encoding descriptor" } { "quot" quotation } } { $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is connected to is stored in the " { $link local-address } " variable, and the remote address is stored in the " { $link remote-address } " variable." } -{ $errors "Throws an error if the connection cannot be established." } ; +{ $errors "Throws an error if the connection cannot be established." } +{ $examples + { $code + "T{ inet f \"www.factorcode.org\" 80 } ascii" + "[" + " \"GET / HTTP/1.1\\r\\nhost: www.factorcode.org\\r\\n\\r\\n\" write flush" + " read-?crlf" + "] with-client" + } +} ; HELP: { $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } @@ -218,7 +227,14 @@ HELP: send HELP: resolve-host { $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } } -{ $description "Resolves host names to IP addresses." } ; +{ $description "Resolves host names to IP addresses." } +{ $errors "Throws an " { $link addrinfo-error } " if the host name cannot be resolved." } +{ $examples + { $code + "\"www.facebook.com\" resolve-host . " + "{ T{ ipv4 { host \"31.13.64.32\" } } }" + } +} ; HELP: with-local-address { $values { "addr" "an " { $link inet4 } " or " { $link inet6 } " address specifier" } { "quot" quotation } } @@ -233,3 +249,7 @@ HELP: with-local-address } { $code "\"192.168.0.1\" 23000 [ ] with-local-address" } } ; + +HELP: protocol-port +{ $values { "protocol" "a protocol string" } { "port" { $maybe integer } } } +{ $description "Outputs the port number associated with a protocol, or " { $link f } " if the protocol is unknown." } ; diff --git a/basis/io/sockets/sockets-tests.factor b/basis/io/sockets/sockets-tests.factor index 685d5a649a..a309a0afc3 100644 --- a/basis/io/sockets/sockets-tests.factor +++ b/basis/io/sockets/sockets-tests.factor @@ -1,5 +1,5 @@ -USING: io.sockets io.sockets.private sequences math tools.test -namespaces accessors kernel destructors calendar io.timeouts +USING: continuations io.sockets io.sockets.private sequences math +tools.test namespaces accessors kernel destructors calendar io.timeouts io.encodings.utf8 io concurrency.promises threads io.streams.string present system ; IN: io.sockets.tests @@ -169,3 +169,8 @@ os unix? [ ! Binding to all interfaces should work [ ] [ f 0 dispose ] unit-test [ ] [ f 0 dispose ] unit-test + +[ 80 ] [ "http" protocol-port ] unit-test +[ f ] [ f protocol-port ] unit-test + +[ "you-cant-resolve-me!" resolve-host ] [ addrinfo-error? ] must-fail-with diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 596b6bfc22..0a7287fc53 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -228,6 +228,8 @@ M: inet6 present M: inet6 protocol drop 0 ; +ERROR: addrinfo-error n string ; + addrspec ] map sift ; -HOOK: addrinfo-error io-backend ( n -- ) +HOOK: addrinfo-error-string io-backend ( n -- string ) : prepare-addrinfo ( -- addrinfo ) addrinfo @@ -407,8 +409,11 @@ M: inet present C: inet M: string resolve-host - f prepare-addrinfo f void* - [ getaddrinfo addrinfo-error ] keep void* deref addrinfo memory>struct + f prepare-addrinfo f void* [ + getaddrinfo [ + dup addrinfo-error-string addrinfo-error + ] unless-zero + ] keep void* deref addrinfo memory>struct [ parse-addrinfo-list ] keep freeaddrinfo ; M: string with-port ; @@ -464,6 +469,9 @@ M: invalid-local-address summary [ invalid-local-address ] if ] dip with-variable ; inline +: protocol-port ( protocol -- port ) + [ f getservbyname [ port>> htons ] [ f ] if* ] [ f ] if* ; + { { [ os unix? ] [ "io.sockets.unix" require ] } { [ os windows? ] [ "io.sockets.windows" require ] } diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index 88af95c309..73fa906085 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. +! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.data alien.strings -classes.struct combinators destructors io.backend.unix -io.encodings.utf8 io.pathnames io.sockets.private kernel libc -locals math namespaces sequences system unix unix.ffi vocabs ; +arrays classes.struct combinators destructors io.backend.unix +io.encodings.utf8 io.files io.pathnames io.sockets.private kernel +libc locals math namespaces sequences system unix +unix.ffi vocabs ; EXCLUDE: io => read write ; EXCLUDE: io.sockets => accept ; IN: io.sockets.unix @@ -14,8 +15,8 @@ IN: io.sockets.unix : set-socket-option ( fd level opt -- ) [ handle-fd ] 2dip 1 int dup byte-length setsockopt io-error ; -M: unix addrinfo-error ( n -- ) - [ gai_strerror throw ] unless-zero ; +M: unix addrinfo-error-string ( n -- string ) + gai_strerror ; M: unix sockaddr-of-family ( alien af -- addrspec ) { diff --git a/basis/io/sockets/windows/windows-tests.factor b/basis/io/sockets/windows/windows-tests.factor new file mode 100644 index 0000000000..562585b8e4 --- /dev/null +++ b/basis/io/sockets/windows/windows-tests.factor @@ -0,0 +1,20 @@ +USING: accessors continuations io.sockets io.sockets.windows kernel sequences tools.test +urls windows.winsock ; +IN: io.sockets.windows.tests + +: google-socket ( -- socket ) + URL" http://www.google.com" url-addr resolve-host first + SOCK_STREAM open-socket ; + +{ } [ + google-socket + { FIONBIO FIONREAD } [ + google-socket swap execute( -- x ) + [ 1 set-ioctl-socket ] [ 0 set-ioctl-socket ] 2bi + ] each drop +] unit-test + +{ t } [ + [ google-socket 1337 -8 set-ioctl-socket ] + [ [ winsock-exception? ] [ n>> 10045 = ] bi and ] recover +] unit-test diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor index ee70e74cce..7eaf2c2713 100755 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -2,17 +2,20 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.data classes.struct combinators destructors io.backend io.files.windows io.ports -io.sockets io.sockets.icmp io.sockets.private kernel libc math -sequences system windows.handles windows.kernel32 windows.types -windows.winsock locals ; +io.sockets io.sockets.icmp io.sockets.private kernel libc locals +math sequences system windows.errors windows.handles +windows.kernel32 windows.types windows.winsock ; FROM: namespaces => get ; IN: io.sockets.windows : set-socket-option ( handle level opt -- ) [ handle>> ] 2dip 1 int dup byte-length setsockopt socket-error ; -M: windows addrinfo-error ( n -- ) - winsock-return-check ; +: set-ioctl-socket ( handle cmd arg -- ) + [ handle>> ] 2dip ulong ioctlsocket socket-error ; + +M: windows addrinfo-error-string ( n -- string ) + n>win32-error-string ; M: windows sockaddr-of-family ( alien af -- addrspec ) { diff --git a/basis/io/standard-paths/unix/unix-tests.factor b/basis/io/standard-paths/unix/unix-tests.factor index 8b5298d9fb..c161d5e03f 100644 --- a/basis/io/standard-paths/unix/unix-tests.factor +++ b/basis/io/standard-paths/unix/unix-tests.factor @@ -1,8 +1,20 @@ ! Copyright (C) 2011 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.standard-paths io.standard-paths.unix tools.test ; +USING: environment io.standard-paths io.standard-paths.unix +sequences tools.test ; IN: io.standard-paths.unix.tests -[ f ] [ "" find-in-path ] unit-test -[ "/bin/ls" ] [ "ls" find-in-path ] unit-test -[ "/sbin/ifconfig" ] [ "ifconfig" find-in-path ] unit-test +{ f } [ "" find-in-path ] unit-test +{ t } [ + "ls" find-in-path { "/bin/ls" "/usr/bin/ls" } member? +] unit-test + +{ t } [ + ! On Ubuntu, the path is ``/sbin/ifconfig``, however + ! find-in-path uses the PATH environment variable which does + ! not include this directory, so we do. + "/sbin:" "PATH" os-env append "PATH" [ + "ifconfig" find-in-path + { "/sbin/ifconfig" "/usr/bin/ifconfig" } member? + ] with-os-env +] unit-test diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index e5ef78a61e..7e9893deff 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -1,7 +1,7 @@ USING: accessors continuations destructors io io.encodings io.encodings.ascii io.encodings.binary io.encodings.string io.encodings.utf8 io.files io.pipes -io.streams.byte-array io.streams.limited io.streams.string +io.streams.byte-array io.streams.duplex io.streams.limited io.streams.string kernel namespaces strings tools.test system io.encodings.8-bit.latin1 ; IN: io.streams.limited.tests @@ -56,28 +56,32 @@ IN: io.streams.limited.tests ! pipes are duplex and not seekable [ "as" ] [ - latin1 [ 2 ] change-in - "asdf" over stream-write dup stream-flush - 2 swap stream-read + latin1 [ + input-stream [ 2 ] change + "asdf" write flush 2 read + ] with-stream ] unit-test [ "as" ] [ - latin1 [ 2 ] change-in - "asdf" over stream-write dup stream-flush - 3 swap stream-read + latin1 [ + input-stream [ 2 ] change + "asdf" write flush 3 read + ] with-stream ] unit-test ! test seeking on limited unseekable streams [ "as" ] [ - latin1 [ 2 ] change-in - "asdf" over stream-write dup stream-flush - 2 swap stream-read + latin1 [ + input-stream [ 2 ] change + "asdf" write flush 2 read + ] with-stream ] unit-test [ "as" ] [ - latin1 [ 2 ] change-in - "asdf" over stream-write dup stream-flush - 3 swap stream-read + latin1 [ + input-stream [ 2 ] change + "asdf" write flush 3 read + ] with-stream ] unit-test [ t ] @@ -125,4 +129,3 @@ IN: io.streams.limited.tests { 4 } [ B{ 0 1 2 3 4 5 } binary 4 stream-length ] unit-test { 6 } [ B{ 0 1 2 3 4 5 } binary 8 stream-length ] unit-test - diff --git a/basis/io/streams/string/string-tests.factor b/basis/io/streams/string/string-tests.factor index fe01626dec..b202dccd75 100644 --- a/basis/io/streams/string/string-tests.factor +++ b/basis/io/streams/string/string-tests.factor @@ -6,58 +6,53 @@ IN: io.streams.string.tests [ "line 1" CHAR: l ] [ - "line 1\nline 2\nline 3" - dup stream-readln swap stream-read1 + "line 1\nline 2\nline 3" [ readln read1 ] with-string-reader ] unit-test -[ f ] -[ "" stream-readln ] -unit-test +{ { "line 1" "line 2" "line 3" } } [ + "line 1\nline 2\nline 3" [ lines ] with-string-reader +] unit-test + +{ { "" "foo" "bar" "baz" } } [ + "\rfoo\r\nbar\rbaz\n" [ lines ] with-string-reader +] unit-test + +[ f ] [ "" [ readln ] with-string-reader ] unit-test [ "xyzzy" ] [ [ "xyzzy" write ] with-string-writer ] unit-test -[ "a" ] [ 1 "abc" stream-read ] unit-test -[ "ab" ] [ 2 "abc" stream-read ] unit-test -[ "abc" ] [ 3 "abc" stream-read ] unit-test -[ "abc" ] [ 4 "abc" stream-read ] unit-test -[ "abc" f ] [ - 3 "abc" [ stream-read ] keep stream-read1 -] unit-test +[ "a" ] [ "abc" [ 1 read ] with-string-reader ] unit-test +[ "ab" ] [ "abc" [ 2 read ] with-string-reader ] unit-test +[ "abc" ] [ "abc" [ 3 read ] with-string-reader ] unit-test +[ "abc" ] [ "abc" [ 4 read ] with-string-reader ] unit-test +[ "abc" f ] [ "abc" [ 3 read read1 ] with-string-reader ] unit-test [ - { - { "It seems " CHAR: J } - { "obs has lost h" CHAR: i } - { "s grasp on reality again.\n" f } - } + { "It seems " CHAR: J } + { "obs has lost h" CHAR: i } + { "s grasp on reality again.\n" f } ] [ - [ - "It seems Jobs has lost his grasp on reality again.\n" - [ - "J" read-until 2array , - "i" read-until 2array , - "X" read-until 2array , - ] with-input-stream - ] { } make + "It seems Jobs has lost his grasp on reality again.\n" [ + "J" read-until 2array + "i" read-until 2array + "X" read-until 2array + ] with-string-reader +] unit-test + +{ "" CHAR: \r } [ "\r\n" [ "\r" read-until ] with-string-reader ] unit-test +{ f f } [ "" [ "\r" read-until ] with-string-reader ] unit-test + +[ "hello" "hi" ] [ + "hello\nhi" [ readln 2 read ] with-string-reader ] unit-test [ "hello" "hi" ] [ - "hello\nhi" - dup stream-readln - 2 rot stream-read + "hello\r\nhi" [ readln 2 read ] with-string-reader ] unit-test [ "hello" "hi" ] [ - "hello\r\nhi" - dup stream-readln - 2 rot stream-read -] unit-test - -[ "hello" "hi" ] [ - "hello\rhi" - dup stream-readln - 2 rot stream-read + "hello\rhi" [ readln 2 read ] with-string-reader ] unit-test ! Issue #70 github diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor index 29bd602cc9..bb16e7ec81 100644 --- a/basis/io/streams/string/string.factor +++ b/basis/io/streams/string/string.factor @@ -1,41 +1,43 @@ ! Copyright (C) 2003, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io kernel math namespaces sequences sbufs -strings generic splitting continuations destructors sequences.private -io.streams.plain io.encodings math.order growable io.streams.sequence -io.private ; +USING: accessors destructors io io.encodings io.streams.sequence +kernel math sbufs sequences sequences.private strings ; IN: io.streams.string ! Readers TUPLE: string-reader { underlying string read-only } { i array-capacity } ; INSTANCE: string-reader input-stream -M: string-reader stream-element-type drop +character+ ; +M: string-reader stream-element-type drop +character+ ; inline + M: string-reader stream-read-unsafe sequence-read-unsafe ; M: string-reader stream-read1 sequence-read1 ; M: string-reader stream-read-until sequence-read-until ; +M: string-reader stream-readln + dup >sequence-stream< bounds-check? [ + "\r\n" over sequence-read-until CHAR: \r eq? [ + over >sequence-stream< dupd ?nth CHAR: \n eq? + [ 1 + pick i<< ] [ drop ] if + ] when nip "" or + ] [ drop f ] if ; + M: string-reader stream-tell i>> ; -M: string-reader stream-seek (stream-seek) ; +M: string-reader stream-seek sequence-seek ; M: string-reader stream-seekable? drop t ; inline M: string-reader stream-length underlying>> length ; M: string-reader dispose drop ; - - : ( str -- stream ) - 0 string-reader boa null-encoding ; + 0 string-reader boa ; : with-string-reader ( str quot -- ) [ ] dip with-input-stream ; inline ! Writers -M: sbuf stream-element-type drop +character+ ; +M: sbuf stream-element-type drop +character+ ; inline : ( -- stream ) - 512 ; + 512 ; inline : with-string-writer ( quot -- str ) [ diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor index 437bcfe9bb..3b3ed75572 100644 --- a/basis/io/styles/styles-docs.factor +++ b/basis/io/styles/styles-docs.factor @@ -158,7 +158,7 @@ ARTICLE: "table-styles" "Table styles" } ; HELP: write-object -{ $values { "str" string } { "obj" "an object" } } +{ $values { "str" string } { "obj" object } } { $description "Writes a string to " { $link output-stream } ", associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." } $io-error ; diff --git a/basis/io/timeouts/timeouts-docs.factor b/basis/io/timeouts/timeouts-docs.factor index 3ae3b62c5d..626f0c24c0 100644 --- a/basis/io/timeouts/timeouts-docs.factor +++ b/basis/io/timeouts/timeouts-docs.factor @@ -7,14 +7,22 @@ HELP: timeout HELP: set-timeout { $values { "dt/f" { $maybe duration } } { "obj" object } } -{ $contract "Sets an object's timeout." } ; +{ $contract "Sets an object's timeout." } +{ $examples "Waits five seconds for a process that sleeps for ten seconds:" + { $unchecked-example + "USING: calendar io.launcher io.timeouts kernel ;" + "\"sleep 10\" >process 5 seconds over set-timeout run-process" + "Process was killed as a result of a call to" + "kill-process, or a timeout" + } +} ; HELP: cancel-operation { $values { "obj" object } } { $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ; HELP: with-timeout -{ $values { "obj" object } { "quot" { $quotation "( obj -- )" } } } +{ $values { "obj" object } { "quot" { $quotation ( obj -- ) } } } { $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ; ARTICLE: "io.timeouts" "I/O timeout protocol" diff --git a/basis/json/writer/writer-docs.factor b/basis/json/writer/writer-docs.factor index 6445f0a7cb..9588a20d1c 100644 --- a/basis/json/writer/writer-docs.factor +++ b/basis/json/writer/writer-docs.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax ; +USING: help.markup help.syntax kernel ; IN: json.writer HELP: >json -{ $values { "obj" "an object" } { "string" "the object converted to JSON format" } } +{ $values { "obj" object } { "string" "the object converted to JSON format" } } { $description "Serializes the object into a JSON formatted string." } { $see-also json-print } ; HELP: json-print -{ $values { "obj" "an object" } } +{ $values { "obj" object } } { $description "Serializes the object into a JSON formatted string and outputs it to the standard output stream. By default, tuples and hashtables are serialized into Javascript-friendly JSON formatted output by converting keys containing dashes into underscores. This behaviour can be modified by setting the dynamic variable " { $strong "jsvar-encode?" } " to false." } diff --git a/basis/lcs/lcs-docs.factor b/basis/lcs/lcs-docs.factor index d2c4e01bf8..4272b87c6c 100644 --- a/basis/lcs/lcs-docs.factor +++ b/basis/lcs/lcs-docs.factor @@ -1,16 +1,16 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup sequences ; IN: lcs HELP: levenshtein -{ $values { "old" "a sequence" } { "new" "a sequence" } { "n" "the Levenshtein distance" } } +{ $values { "old" sequence } { "new" sequence } { "n" "the Levenshtein distance" } } { $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ; HELP: lcs -{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "lcs" "a longest common subsequence" } } +{ $values { "seq1" sequence } { "seq2" sequence } { "lcs" "a longest common subsequence" } } { $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ; HELP: diff -{ $values { "old" "a sequence" } { "new" "a sequence" } { "diff" "an edit script" } } +{ $values { "old" sequence } { "new" sequence } { "diff" "an edit script" } } { $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ; HELP: retain diff --git a/basis/libc/libc-tests.factor b/basis/libc/libc-tests.factor index 3dcebb5e7a..5bc0ed2232 100644 --- a/basis/libc/libc-tests.factor +++ b/basis/libc/libc-tests.factor @@ -1,11 +1,13 @@ -IN: libc.tests -USING: libc libc.private tools.test namespaces assocs -destructors kernel ; - -100 malloc "block" set - -[ t ] [ "block" get malloc-exists? ] unit-test - -[ ] [ [ "block" get &free drop ] with-destructors ] unit-test - -[ f ] [ "block" get malloc-exists? ] unit-test +IN: libc.tests +USING: destructors kernel libc libc.private namespaces +tools.test ; + +100 malloc "block" set + +[ t ] [ "block" get malloc-exists? ] unit-test + +[ ] [ [ "block" get &free drop ] with-destructors ] unit-test + +[ f ] [ "block" get malloc-exists? ] unit-test + +[ "Operation not permitted" ] [ 1 strerror ] unit-test diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 95ed73c7e6..b7a69cd3f1 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -2,11 +2,13 @@ ! Copyright (C) 2007, 2010 Slava Pestov ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax assocs continuations -alien.destructors kernel namespaces accessors sets summary -destructors destructors.private ; +USING: accessors alien alien.c-types alien.destructors +alien.syntax destructors destructors.private kernel math +namespaces sequences sets summary system vocabs ; IN: libc +HOOK: strerror os ( errno -- str ) + LIBRARY: factor FUNCTION-ALIAS: errno @@ -35,6 +37,18 @@ FUNCTION-ALIAS: (free) FUNCTION-ALIAS: (realloc) void* realloc ( void* alien, size_t size ) ; +FUNCTION-ALIAS: strerror_unsafe + char* strerror ( int errno ) ; + +! Add a default strerror even though it's not threadsafe +M: object strerror strerror_unsafe ; + +ERROR: libc-error errno message ; + +: (io-error) ( -- * ) errno dup strerror libc-error ; + +: io-error ( n -- ) 0 < [ (io-error) ] when ; + > append require >> diff --git a/basis/libc/linux/linux.factor b/basis/libc/linux/linux.factor new file mode 100644 index 0000000000..aa872866c2 --- /dev/null +++ b/basis/libc/linux/linux.factor @@ -0,0 +1,178 @@ +USING: alien.c-types alien.syntax destructors kernel system ; +IN: libc + +LIBRARY: libc + +CONSTANT: EPERM 1 +CONSTANT: ENOENT 2 +CONSTANT: ESRCH 3 +CONSTANT: EINTR 4 +CONSTANT: EIO 5 +CONSTANT: ENXIO 6 +CONSTANT: E2BIG 7 +CONSTANT: ENOEXEC 8 +CONSTANT: EBADF 9 +CONSTANT: ECHILD 10 +CONSTANT: EAGAIN 11 +CONSTANT: ENOMEM 12 +CONSTANT: EACCES 13 +CONSTANT: EFAULT 14 +CONSTANT: ENOTBLK 15 +CONSTANT: EBUSY 16 +CONSTANT: EEXIST 17 +CONSTANT: EXDEV 18 +CONSTANT: ENODEV 19 +CONSTANT: ENOTDIR 20 +CONSTANT: EISDIR 21 +CONSTANT: EINVAL 22 +CONSTANT: ENFILE 23 +CONSTANT: EMFILE 24 +CONSTANT: ENOTTY 25 +CONSTANT: ETXTBSY 26 +CONSTANT: EFBIG 27 +CONSTANT: ENOSPC 28 +CONSTANT: ESPIPE 29 +CONSTANT: EROFS 30 +CONSTANT: EMLINK 31 +CONSTANT: EPIPE 32 +CONSTANT: EDOM 33 +CONSTANT: ERANGE 34 +CONSTANT: EDEADLK 35 +CONSTANT: ENAMETOOLONG 36 +CONSTANT: ENOLCK 37 +CONSTANT: ENOSYS 38 +CONSTANT: ENOTEMPTY 39 +CONSTANT: ELOOP 40 +ALIAS: EWOULDBLOCK EAGAIN +CONSTANT: ENOMSG 42 +CONSTANT: EIDRM 43 +CONSTANT: ECHRNG 44 +CONSTANT: EL2NSYNC 45 +CONSTANT: EL3HLT 46 +CONSTANT: EL3RST 47 +CONSTANT: ELNRNG 48 +CONSTANT: EUNATCH 49 +CONSTANT: ENOCSI 50 +CONSTANT: EL2HLT 51 +CONSTANT: EBADE 52 +CONSTANT: EBADR 53 +CONSTANT: EXFULL 54 +CONSTANT: ENOANO 55 +CONSTANT: EBADRQC 56 +CONSTANT: EBADSLT 57 +ALIAS: EDEADLOCK EDEADLK +CONSTANT: EBFONT 59 +CONSTANT: ENOSTR 60 +CONSTANT: ENODATA 61 +CONSTANT: ETIME 62 +CONSTANT: ENOSR 63 +CONSTANT: ENONET 64 +CONSTANT: ENOPKG 65 +CONSTANT: EREMOTE 66 +CONSTANT: ENOLINK 67 +CONSTANT: EADV 68 +CONSTANT: ESRMNT 69 +CONSTANT: ECOMM 70 +CONSTANT: EPROTO 71 +CONSTANT: EMULTIHOP 72 +CONSTANT: EDOTDOT 73 +CONSTANT: EBADMSG 74 +CONSTANT: EOVERFLOW 75 +CONSTANT: ENOTUNIQ 76 +CONSTANT: EBADFD 77 +CONSTANT: EREMCHG 78 +CONSTANT: ELIBACC 79 +CONSTANT: ELIBBAD 80 +CONSTANT: ELIBSCN 81 +CONSTANT: ELIBMAX 82 +CONSTANT: ELIBEXEC 83 +CONSTANT: EILSEQ 84 +CONSTANT: ERESTART 85 +CONSTANT: ESTRPIPE 86 +CONSTANT: EUSERS 87 +CONSTANT: ENOTSOCK 88 +CONSTANT: EDESTADDRREQ 89 +CONSTANT: EMSGSIZE 90 +CONSTANT: EPROTOTYPE 91 +CONSTANT: ENOPROTOOPT 92 +CONSTANT: EPROTONOSUPPORT 93 +CONSTANT: ESOCKTNOSUPPORT 94 +CONSTANT: EOPNOTSUPP 95 +CONSTANT: EPFNOSUPPORT 96 +CONSTANT: EAFNOSUPPORT 97 +CONSTANT: EADDRINUSE 98 +CONSTANT: EADDRNOTAVAIL 99 +CONSTANT: ENETDOWN 100 +CONSTANT: ENETUNREACH 101 +CONSTANT: ENETRESET 102 +CONSTANT: ECONNABORTED 103 +CONSTANT: ECONNRESET 104 +CONSTANT: ENOBUFS 105 +CONSTANT: EISCONN 106 +CONSTANT: ENOTCONN 107 +CONSTANT: ESHUTDOWN 108 +CONSTANT: ETOOMANYREFS 109 +CONSTANT: ETIMEDOUT 110 +CONSTANT: ECONNREFUSED 111 +CONSTANT: EHOSTDOWN 112 +CONSTANT: EHOSTUNREACH 113 +CONSTANT: EALREADY 114 +CONSTANT: EINPROGRESS 115 +CONSTANT: ESTALE 116 +CONSTANT: EUCLEAN 117 +CONSTANT: ENOTNAM 118 +CONSTANT: ENAVAIL 119 +CONSTANT: EISNAM 120 +CONSTANT: EREMOTEIO 121 +CONSTANT: EDQUOT 122 +CONSTANT: ENOMEDIUM 123 +CONSTANT: EMEDIUMTYPE 124 +CONSTANT: ECANCELED 125 +CONSTANT: ENOKEY 126 +CONSTANT: EKEYEXPIRED 127 +CONSTANT: EKEYREVOKED 128 +CONSTANT: EKEYREJECTED 129 +CONSTANT: EOWNERDEAD 130 +CONSTANT: ENOTRECOVERABLE 131 + +CONSTANT: SIGHUP 1 +CONSTANT: SIGINT 2 +CONSTANT: SIGQUIT 3 +CONSTANT: SIGILL 4 +CONSTANT: SIGTRAP 5 +CONSTANT: SIGABRT 6 +CONSTANT: SIGIOT 6 +CONSTANT: SIGBUS 7 +CONSTANT: SIGFPE 8 +CONSTANT: SIGKILL 9 +CONSTANT: SIGUSR1 10 +CONSTANT: SIGSEGV 11 +CONSTANT: SIGUSR2 12 +CONSTANT: SIGPIPE 13 +CONSTANT: SIGALRM 14 +CONSTANT: SIGTERM 15 +CONSTANT: SIGSTKFLT 16 +CONSTANT: SIGCHLD 17 +ALIAS: SIGCLD SIGCHLD +CONSTANT: SIGCONT 18 +CONSTANT: SIGSTOP 19 +CONSTANT: SIGTSTP 20 +CONSTANT: SIGTTIN 21 +CONSTANT: SIGTTOU 22 +CONSTANT: SIGURG 23 +CONSTANT: SIGXCPU 24 +CONSTANT: SIGXFSZ 25 +CONSTANT: SIGVTALRM 26 +CONSTANT: SIGPROF 27 +CONSTANT: SIGWINCH 28 +CONSTANT: SIGIO 29 +ALIAS: SIGPOLL SIGIO +CONSTANT: SIGPWR 30 +CONSTANT: SIGSYS 31 + +FUNCTION: c-string strerror_r ( int errno, char* buf, size_t buflen ) ; + +M: linux strerror ( errno -- str ) + [ + 1024 [ malloc &free ] keep strerror_r + ] with-destructors ; diff --git a/basis/libc/linux/platforms.txt b/basis/libc/linux/platforms.txt new file mode 100644 index 0000000000..a08e1f35eb --- /dev/null +++ b/basis/libc/linux/platforms.txt @@ -0,0 +1 @@ +linux diff --git a/basis/libc/macosx/macosx.factor b/basis/libc/macosx/macosx.factor new file mode 100644 index 0000000000..5740836f0a --- /dev/null +++ b/basis/libc/macosx/macosx.factor @@ -0,0 +1,150 @@ +USING: alien.c-types alien.strings alien.syntax destructors +kernel system ; +IN: libc + +LIBRARY: libc + +CONSTANT: EPERM 1 +CONSTANT: ENOENT 2 +CONSTANT: ESRCH 3 +CONSTANT: EINTR 4 +CONSTANT: EIO 5 +CONSTANT: ENXIO 6 +CONSTANT: E2BIG 7 +CONSTANT: ENOEXEC 8 +CONSTANT: EBADF 9 +CONSTANT: ECHILD 10 +CONSTANT: EDEADLK 11 +CONSTANT: ENOMEM 12 +CONSTANT: EACCES 13 +CONSTANT: EFAULT 14 +CONSTANT: ENOTBLK 15 +CONSTANT: EBUSY 16 +CONSTANT: EEXIST 17 +CONSTANT: EXDEV 18 +CONSTANT: ENODEV 19 +CONSTANT: ENOTDIR 20 +CONSTANT: EISDIR 21 +CONSTANT: EINVAL 22 +CONSTANT: ENFILE 23 +CONSTANT: EMFILE 24 +CONSTANT: ENOTTY 25 +CONSTANT: ETXTBSY 26 +CONSTANT: EFBIG 27 +CONSTANT: ENOSPC 28 +CONSTANT: ESPIPE 29 +CONSTANT: EROFS 30 +CONSTANT: EMLINK 31 +CONSTANT: EPIPE 32 +CONSTANT: EDOM 33 +CONSTANT: ERANGE 34 +CONSTANT: EAGAIN 35 +ALIAS: EWOULDBLOCK EAGAIN +CONSTANT: EINPROGRESS 36 +CONSTANT: EALREADY 37 +CONSTANT: ENOTSOCK 38 +CONSTANT: EDESTADDRREQ 39 +CONSTANT: EMSGSIZE 40 +CONSTANT: EPROTOTYPE 41 +CONSTANT: ENOPROTOOPT 42 +CONSTANT: EPROTONOSUPPORT 43 +CONSTANT: ESOCKTNOSUPPORT 44 +CONSTANT: ENOTSUP 45 +CONSTANT: EPFNOSUPPORT 46 +CONSTANT: EAFNOSUPPORT 47 +CONSTANT: EADDRINUSE 48 +CONSTANT: EADDRNOTAVAIL 49 +CONSTANT: ENETDOWN 50 +CONSTANT: ENETUNREACH 51 +CONSTANT: ENETRESET 52 +CONSTANT: ECONNABORTED 53 +CONSTANT: ECONNRESET 54 +CONSTANT: ENOBUFS 55 +CONSTANT: EISCONN 56 +CONSTANT: ENOTCONN 57 +CONSTANT: ESHUTDOWN 58 +CONSTANT: ETOOMANYREFS 59 +CONSTANT: ETIMEDOUT 60 +CONSTANT: ECONNREFUSED 61 +CONSTANT: ELOOP 62 +CONSTANT: ENAMETOOLONG 63 +CONSTANT: EHOSTDOWN 64 +CONSTANT: EHOSTUNREACH 65 +CONSTANT: ENOTEMPTY 66 +CONSTANT: EPROCLIM 67 +CONSTANT: EUSERS 68 +CONSTANT: EDQUOT 69 +CONSTANT: ESTALE 70 +CONSTANT: EREMOTE 71 +CONSTANT: EBADRPC 72 +CONSTANT: ERPCMISMATCH 73 +CONSTANT: EPROGUNAVAIL 74 +CONSTANT: EPROGMISMATCH 75 +CONSTANT: EPROCUNAVAIL 76 +CONSTANT: ENOLCK 77 +CONSTANT: ENOSYS 78 +CONSTANT: EFTYPE 79 +CONSTANT: EAUTH 80 +CONSTANT: ENEEDAUTH 81 +CONSTANT: EPWROFF 82 +CONSTANT: EDEVERR 83 +CONSTANT: EOVERFLOW 84 +CONSTANT: EBADEXEC 85 +CONSTANT: EBADARCH 86 +CONSTANT: ESHLIBVERS 87 +CONSTANT: EBADMACHO 88 +CONSTANT: ECANCELED 89 +CONSTANT: EIDRM 90 +CONSTANT: ENOMSG 91 +CONSTANT: EILSEQ 92 +CONSTANT: ENOATTR 93 +CONSTANT: EBADMSG 94 +CONSTANT: EMULTIHOP 95 +CONSTANT: ENODATA 96 +CONSTANT: ENOLINK 97 +CONSTANT: ENOSR 98 +CONSTANT: ENOSTR 99 +CONSTANT: EPROTO 100 +CONSTANT: ETIME 101 +CONSTANT: EOPNOTSUPP 102 +CONSTANT: ENOPOLICY 103 + +CONSTANT: SIGHUP 1 +CONSTANT: SIGINT 2 +CONSTANT: SIGQUIT 3 +CONSTANT: SIGILL 4 +CONSTANT: SIGTRAP 5 +CONSTANT: SIGABRT 6 +CONSTANT: SIGEMT 7 +CONSTANT: SIGFPE 8 +CONSTANT: SIGKILL 9 +CONSTANT: SIGBUS 10 +CONSTANT: SIGSEGV 11 +CONSTANT: SIGSYS 12 +CONSTANT: SIGPIPE 13 +CONSTANT: SIGALRM 14 +CONSTANT: SIGTERM 15 +CONSTANT: SIGURG 16 +CONSTANT: SIGSTOP 17 +CONSTANT: SIGTSTP 18 +CONSTANT: SIGCONT 19 +CONSTANT: SIGCHLD 20 +CONSTANT: SIGTTIN 21 +CONSTANT: SIGTTOU 22 +CONSTANT: SIGIO 23 +CONSTANT: SIGXCPU 24 +CONSTANT: SIGXFSZ 25 +CONSTANT: SIGVTALRM 26 +CONSTANT: SIGPROF 27 +CONSTANT: SIGWINCH 28 +CONSTANT: SIGINFO 29 +CONSTANT: SIGUSR1 30 +CONSTANT: SIGUSR2 31 + +FUNCTION: int strerror_r ( int errno, char* buf, size_t buflen ) ; + +M: macosx strerror ( errno -- str ) + [ + 1024 [ malloc &free ] keep [ strerror_r ] 2keep drop nip + alien>native-string + ] with-destructors ; diff --git a/basis/libc/macosx/platforms.txt b/basis/libc/macosx/platforms.txt new file mode 100644 index 0000000000..6e806f449e --- /dev/null +++ b/basis/libc/macosx/platforms.txt @@ -0,0 +1 @@ +macosx diff --git a/basis/libc/windows/platforms.txt b/basis/libc/windows/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/basis/libc/windows/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/basis/libc/windows/windows.factor b/basis/libc/windows/windows.factor new file mode 100644 index 0000000000..85d25cadd8 --- /dev/null +++ b/basis/libc/windows/windows.factor @@ -0,0 +1,116 @@ +USING: alien.c-types alien.strings alien.syntax destructors +io.encodings.utf8 kernel libc system ; +IN: libc + +LIBRARY: libc + +! From errno.h in msvc 10: +CONSTANT: EPERM 1 +CONSTANT: ENOENT 2 +CONSTANT: ESRCH 3 +CONSTANT: EINTR 4 +CONSTANT: EIO 5 +CONSTANT: ENXIO 6 +CONSTANT: E2BIG 7 +CONSTANT: ENOEXEC 8 +CONSTANT: EBADF 9 +CONSTANT: ECHILD 10 +CONSTANT: EAGAIN 11 +CONSTANT: ENOMEM 12 +CONSTANT: EACCES 13 +CONSTANT: EFAULT 14 +CONSTANT: EBUSY 16 +CONSTANT: EEXIST 17 +CONSTANT: EXDEV 18 +CONSTANT: ENODEV 19 +CONSTANT: ENOTDIR 20 +CONSTANT: EISDIR 21 +CONSTANT: ENFILE 23 +CONSTANT: EMFILE 24 +CONSTANT: ENOTTY 25 +CONSTANT: EFBIG 27 +CONSTANT: ENOSPC 28 +CONSTANT: ESPIPE 29 +CONSTANT: EROFS 30 +CONSTANT: EMLINK 31 +CONSTANT: EPIPE 32 +CONSTANT: EDOM 33 +CONSTANT: EDEADLK 36 +CONSTANT: ENAMETOOLONG 38 +CONSTANT: ENOLCK 39 +CONSTANT: ENOSYS 40 +CONSTANT: ENOTEMPTY 41 + +! Error codes used in the Secure CRT functions +CONSTANT: EINVAL 22 +CONSTANT: ERANGE 34 +CONSTANT: EILSEQ 42 +CONSTANT: STRUNCATE 80 + +! Support EDEADLOCK for compatibility with older MS-C versions +ALIAS: EDEADLOCK EDEADLK + +! POSIX SUPPLEMENT +CONSTANT: EADDRINUSE 100 +CONSTANT: EADDRNOTAVAIL 101 +CONSTANT: EAFNOSUPPORT 102 +CONSTANT: EALREADY 103 +CONSTANT: EBADMSG 104 +CONSTANT: ECANCELED 105 +CONSTANT: ECONNABORTED 106 +CONSTANT: ECONNREFUSED 107 +CONSTANT: ECONNRESET 108 +CONSTANT: EDESTADDRREQ 109 +CONSTANT: EHOSTUNREACH 110 +CONSTANT: EIDRM 111 +CONSTANT: EINPROGRESS 112 +CONSTANT: EISCONN 113 +CONSTANT: ELOOP 114 +CONSTANT: EMSGSIZE 115 +CONSTANT: ENETDOWN 116 +CONSTANT: ENETRESET 117 +CONSTANT: ENETUNREACH 118 +CONSTANT: ENOBUFS 119 +CONSTANT: ENODATA 120 +CONSTANT: ENOLINK 121 +CONSTANT: ENOMSG 122 +CONSTANT: ENOPROTOOPT 123 +CONSTANT: ENOSR 124 +CONSTANT: ENOSTR 125 +CONSTANT: ENOTCONN 126 +CONSTANT: ENOTRECOVERABLE 127 +CONSTANT: ENOTSOCK 128 +CONSTANT: ENOTSUP 129 +CONSTANT: EOPNOTSUPP 130 +CONSTANT: EOTHER 131 +CONSTANT: EOVERFLOW 132 +CONSTANT: EOWNERDEAD 133 +CONSTANT: EPROTO 134 +CONSTANT: EPROTONOSUPPORT 135 +CONSTANT: EPROTOTYPE 136 +CONSTANT: ETIME 137 +CONSTANT: ETIMEDOUT 138 +CONSTANT: ETXTBSY 139 +CONSTANT: EWOULDBLOCK 140 + +! From signal.h in msvc 10: +CONSTANT: SIGINT 2 +CONSTANT: SIGILL 4 +CONSTANT: SIGFPE 8 +CONSTANT: SIGSEGV 11 +CONSTANT: SIGTERM 15 +CONSTANT: SIGBREAK 21 +CONSTANT: SIGABRT 22 + +CONSTANT: SIGABRT_COMPAT 6 + +LIBRARY: libc + +FUNCTION: int strerror_s ( char *buffer, size_t numberOfElements, int errnum ) ; + +M: windows strerror ( errno -- str ) + [ + [ 1024 [ malloc &free ] keep ] dip + [ strerror_s drop ] 3keep 2drop + utf8 alien>string + ] with-destructors ; diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor index a7a8512669..cb39253f6a 100644 --- a/basis/linked-assocs/linked-assocs-tests.factor +++ b/basis/linked-assocs/linked-assocs-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences assocs tools.test linked-assocs math ; +USING: accessors assocs kernel linked-assocs math sequences +tools.test ; IN: linked-assocs.test { { 1 2 3 } } [ @@ -63,3 +64,18 @@ IN: linked-assocs.test 3 "cx" pick set-at >alist ] unit-test + +{ t V{ { 1 20 } { 3 40 } { 5 60 } } } [ + { { 1 2 } { 3 4 } { 5 6 } } >linked-hash + [ 10 * ] assoc-map [ linked-assoc? ] [ >alist ] bi +] unit-test + +{ V{ { 1 2 } { 3 4 } { 5 6 } } } [ + { { 1 2 } { 3 4 } { 5 6 } } + { } assoc-like >alist +] unit-test + +{ t } [ + { { "a" "b" } { "c" "d" } } + [ >linked-hash ] [ >linked-hash ] bi = +] unit-test diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor index 8af3cdc854..3d3ce4942d 100644 --- a/basis/linked-assocs/linked-assocs.factor +++ b/basis/linked-assocs/linked-assocs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov, James Cash. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs deques dlists fry kernel +USING: accessors arrays assocs classes deques dlists fry kernel sequences sequences.private ; IN: linked-assocs @@ -45,8 +45,18 @@ M: linked-assoc >alist M: linked-assoc clear-assoc [ assoc>> clear-assoc ] [ dlist>> clear-deque ] bi ; -M: linked-assoc clone - [ assoc>> clone ] [ dlist>> clone ] bi - linked-assoc boa ; +M: linked-assoc clone + [ assoc>> clone ] [ dlist>> clone ] bi linked-assoc boa ; INSTANCE: linked-assoc assoc + +: >linked-hash ( assoc -- assoc ) + [ ] dip assoc-union! ; + +M: linked-assoc assoc-like + over linked-assoc? + [ 2dup [ assoc>> ] bi@ class-of instance? ] [ f ] if + [ drop ] [ assoc>> swap assoc-union! ] if ; + +M: linked-assoc equal? + over linked-assoc? [ [ dlist>> ] bi@ = ] [ 2drop f ] if ; diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 59ddff1f75..1e5f38e093 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -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 source-files.errors locals vocabs vocabs.loader -parser.notes ; +USING: accessors colors colors.constants +combinators.short-circuit compiler.units continuations debugger +fry io io.styles kernel lexer locals math math.parser namespaces +parser parser.notes prettyprint sequences sets +source-files.errors vocabs vocabs.loader vocabs.parser ; IN: listener GENERIC: stream-read-quot ( stream -- quot/f ) @@ -16,8 +15,10 @@ GENERIC# prompt. 1 ( stream prompt -- ) auto-use? get [ " auto-use" append ] when ; M: object prompt. - nip H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl - flush ; + nip H{ + { background T{ rgba f 1 0.7 0.7 1 } } + { foreground COLOR: black } + } format bl flush ; : parse-lines-interactive ( lines -- quot/f ) [ parse-lines ] with-compilation-unit ; @@ -187,14 +188,18 @@ SYMBOL: interactive-vocabs "words" } interactive-vocabs set-global -: use-loaded-vocabs ( vocabs -- ) - [ lookup-vocab ] filter - [ - lookup-vocab +: loaded-vocab? ( vocab-spec -- ? ) + { [ find-vocab-root not ] - [ source-loaded?>> +done+ eq? ] bi or - ] filter - [ use-vocab ] each ; + [ source-loaded?>> +done+ eq? ] + } 1|| ; + +: use-loaded-vocabs ( vocabs -- ) + [ + lookup-vocab [ + dup loaded-vocab? [ use-vocab ] [ drop ] if + ] when* + ] each ; : with-interactive-vocabs ( quot -- ) [ diff --git a/basis/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor index f18dba0592..56c2554381 100644 --- a/basis/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax sequences strings lists ; -IN: lists.lazy +USING: help.markup help.syntax kernel lists math sequences +strings ; +IN: lists.lazy ABOUT: "lists.lazy" @@ -58,33 +59,33 @@ ARTICLE: { "lists.lazy" "manipulation" } "Manipulating lazy lists" } ; HELP: lazy-cons -{ $values { "car" { $quotation "( -- elt )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } -{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } +{ $values { "car" { $quotation ( -- elt ) } } { "cdr" { $quotation ( -- cons ) } } { "promise" "the resulting cons object" } } +{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } { $see-also cons car cdr nil nil? } ; { 1lazy-list 2lazy-list 3lazy-list } related-words HELP: 1lazy-list -{ $values { "a" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } } +{ $values { "a" { $quotation ( -- X ) } } { "lazy-cons" "a lazy-cons object" } } { $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ; HELP: 2lazy-list -{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } } +{ $values { "a" { $quotation ( -- X ) } } { "b" { $quotation ( -- X ) } } { "lazy-cons" "a lazy-cons object" } } { $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ; HELP: 3lazy-list -{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "c" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } } +{ $values { "a" { $quotation ( -- X ) } } { "b" { $quotation ( -- X ) } } { "c" { $quotation ( -- X ) } } { "lazy-cons" "a lazy-cons object" } } { $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ; HELP: { $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } } -{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } +{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } { $see-also cons car cdr nil nil? } ; { lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lazy-map -{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } } +{ $values { "list" "a cons object" } { "quot" { $quotation ( obj -- X ) } } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: ltake @@ -92,15 +93,15 @@ HELP: ltake { $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: lfilter -{ $values { "list" "a cons object" } { "quot" { $quotation "( -- X )" } } { "result" "resulting cons object" } } +{ $values { "list" "a cons object" } { "quot" { $quotation ( -- X ) } } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: lwhile -{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } } +{ $values { "list" "a cons object" } { "quot" { $quotation ( x -- ? ) } } { "result" "resulting cons object" } } { $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: luntil -{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } } +{ $values { "list" "a cons object" } { "quot" { $quotation ( x -- ? ) } } { "result" "resulting cons object" } } { $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; HELP: lappend @@ -108,23 +109,18 @@ HELP: lappend { $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ; HELP: lfrom-by -{ $values { "n" "an integer" } { "quot" { $quotation "( n -- o )" } } { "lazy-from-by" "a lazy list of integers" } } +{ $values { "n" integer } { "quot" { $quotation ( n -- o ) } } { "lazy-from-by" "a lazy list of integers" } } { $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to the previous value." } ; HELP: lfrom -{ $values { "n" "an integer" } { "list" "a lazy list of integers" } } +{ $values { "n" integer } { "list" "a lazy list of integers" } } { $description "Return an infinite lazy list of incrementing integers starting from n." } ; HELP: sequence-tail>list -{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } } +{ $values { "index" "an integer 0 or greater" } { "seq" sequence } { "list" "a list" } } { $description "Convert the sequence into a list, starting from " { $snippet "index" } "." } { $see-also >list } ; -HELP: >list -{ $values { "object" "an object" } { "list" "a list" } } -{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link sequence-tail>list } " and other objects cause an error to be thrown." } -{ $see-also sequence-tail>list } ; - { leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lconcat @@ -140,11 +136,11 @@ HELP: lcartesian-product* { $description "Given a list of lists, return a list containing the cartesian product of those lists." } ; HELP: lcomp -{ $values { "list" "a list of lists" } { "quot" { $quotation "( seq -- X )" } } { "result" "the resulting list" } } +{ $values { "list" "a list of lists" } { "quot" { $quotation ( seq -- X ) } } { "result" "the resulting list" } } { $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ; HELP: lcomp* -{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation "( seq -- X )" } } { "result" "a list" } } +{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation ( seq -- X ) } } { "result" "a list" } } { $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." } { $examples { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" } @@ -152,17 +148,17 @@ HELP: lcomp* HELP: lmerge { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } } -{ $description "Return the result of merging the two lists in a lazy manner." } +{ $description "Return the result of merging the two lists in a lazy manner." } { $examples { $example "USING: lists lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" } } ; HELP: lcontents { $values { "stream" "a stream" } { "result" string } } -{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." } +{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." } { $see-also llines } ; HELP: llines { $values { "stream" "a stream" } { "result" "a list" } } -{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." } +{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." } { $see-also lcontents } ; diff --git a/basis/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor index 55d29ddb94..924c6f3fbe 100644 --- a/basis/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Matthew Willis and Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.encodings.utf8 io.files kernel lists lists.lazy -math sequences tools.test ; +USING: destructors io io.encodings.utf8 io.files kernel lists +lists.lazy math sequences tools.test ; IN: lists.lazy.tests [ { 1 2 3 4 } ] [ @@ -16,15 +16,15 @@ IN: lists.lazy.tests { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array ] unit-test -[ { 5 6 6 7 7 8 } ] [ +[ { 5 6 6 7 7 8 } ] [ { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array ] unit-test -[ { 5 6 7 8 } ] [ +[ { 5 6 7 8 } ] [ { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array ] unit-test -[ { 4 5 6 } ] [ +[ { 4 5 6 } ] [ 3 { 1 2 3 } >list [ + ] with lazy-map list>array ] unit-test @@ -41,5 +41,13 @@ IN: lists.lazy.tests [ { 1 2 3 } ] [ { 1 2 3 4 5 } >list [ 2 > ] luntil list>array ] unit-test -[ ] [ "resource:license.txt" utf8 llines list>array drop ] unit-test -[ ] [ "resource:license.txt" utf8 lcontents list>array drop ] unit-test +[ ] [ + "resource:license.txt" utf8 [ + llines list>array drop + ] with-disposal +] unit-test +[ ] [ + "resource:license.txt" utf8 [ + lcontents list>array drop + ] with-disposal +] unit-test diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 696d49b07f..a6d1dfd20c 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators io kernel lists math -promises quotations sequences summary vectors ; +promises quotations sequences ; IN: lists.lazy M: promise car ( promise -- car ) @@ -12,14 +12,14 @@ M: promise cdr ( promise -- cdr ) M: promise nil? ( cons -- ? ) force nil? ; - + ! Both 'car' and 'cdr' are promises TUPLE: lazy-cons-state car cdr ; : lazy-cons ( car cdr -- promise ) [ T{ promise f f t f } clone ] 2dip - [ ] bi@ \ lazy-cons-state boa - >>value ; + [ ] bi@ \ lazy-cons-state boa + >>value ; M: lazy-cons-state car ( lazy-cons -- car ) car>> force ; @@ -241,17 +241,7 @@ M: sequence-cons cdr ( sequence-cons -- cdr ) M: sequence-cons nil? ( sequence-cons -- ? ) drop f ; -ERROR: list-conversion-error object ; - -M: list-conversion-error summary - drop "Could not convert object to list" ; - -: >list ( object -- list ) - { - { [ dup sequence? ] [ 0 swap sequence-tail>list ] } - { [ dup list? ] [ ] } - [ list-conversion-error ] - } cond ; +M: sequence >list 0 swap sequence-tail>list ; TUPLE: lazy-concat car cdr ; @@ -263,7 +253,7 @@ DEFER: lconcat over nil? [ nip lconcat ] [ ] if ; : lconcat ( list -- result ) - dup nil? [ drop nil ] [ uncons (lconcat) ] if ; + dup nil? [ drop nil ] [ uncons (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) car>> car ; diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor index c22faa5c00..f0cdf4c2e7 100644 --- a/basis/lists/lists-docs.factor +++ b/basis/lists/lists-docs.factor @@ -87,7 +87,7 @@ HELP: nil { $description "Returns a symbol representing the empty list" } ; HELP: nil? -{ $values { "object" object } { "?" "a boolean" } } +{ $values { "object" object } { "?" boolean } } { $description "Return true if the cons object is the nil cons." } ; { nil nil? } related-words @@ -95,15 +95,15 @@ HELP: nil? { 1list 2list 3list } related-words HELP: 1list -{ $values { "obj" "an object" } { "cons" list } } +{ $values { "obj" object } { "cons" list } } { $description "Create a list with 1 element." } ; HELP: 2list -{ $values { "a" "an object" } { "b" "an object" } { "cons" list } } +{ $values { "a" object } { "b" object } { "cons" list } } { $description "Create a list with 2 elements." } ; HELP: 3list -{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" list } } +{ $values { "a" object } { "b" object } { "c" object } { "cons" list } } { $description "Create a list with 3 elements." } ; HELP: lnth @@ -127,19 +127,19 @@ HELP: unswons { leach foldl lmap>array } related-words HELP: leach -{ $values { "list" list } { "quot" { $quotation "( ... elt -- ... )" } } } +{ $values { "list" list } { "quot" { $quotation ( ... elt -- ... ) } } } { $description "Call the quotation for each item in the list." } ; HELP: foldl -{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } } +{ $values { "list" list } { "identity" object } { "quot" { $quotation ( ... prev elt -- ... next ) } } { "result" "the final result" } } { $description "Combines successive elements of the list (in a left-associative order) using a binary operation and outputs the final result." } ; HELP: foldr -{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( ... prev elt -- ... next )" } } { "result" "the final result" } } +{ $values { "list" list } { "identity" object } { "quot" { $quotation ( ... prev elt -- ... next ) } } { "result" "the final result" } } { $description "Combines successive elements of the list (in a right-associative order) using a binary operation, and outputs the final result." } ; HELP: lmap -{ $values { "list" list } { "quot" { $quotation "( ... elt -- ... newelt )" } } { "result" "the final result" } } +{ $values { "list" list } { "quot" { $quotation ( ... elt -- ... newelt ) } } { "result" "the final result" } } { $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; HELP: lreverse @@ -169,3 +169,6 @@ HELP: lmap>array { $values { "list" list } { "quot" quotation } { "array" array } } { $description "Executes the quotation on each element of the list, collecting the results in an array." } ; +HELP: >list +{ $values { "object" object } { "list" "a list" } } +{ $description "Converts the object into a list." } ; diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 966f062d51..1b106b0002 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash, Daniel Ehrenberg, Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences accessors math arrays vectors classes words -combinators.short-circuit combinators locals ; +USING: accessors combinators.short-circuit kernel locals math +sequences ; IN: lists ! List Protocol @@ -9,7 +9,7 @@ MIXIN: list GENERIC: car ( cons -- car ) GENERIC: cdr ( cons -- cdr ) GENERIC: nil? ( object -- ? ) - + TUPLE: cons-state { car read-only } { cdr read-only } ; C: cons cons-state @@ -41,9 +41,9 @@ M: object nil? drop f ; : 3list ( a b c -- cons ) 2list cons ; inline : cadr ( list -- elt ) cdr car ; inline - + : 2car ( list -- car caar ) [ car ] [ cadr ] bi ; inline - + : 3car ( list -- car cadr caddr ) [ car ] [ cadr ] [ cdr cadr ] tri ; inline : lnth ( n list -- elt ) swap [ cdr ] times car ; inline @@ -84,14 +84,18 @@ PRIVATE> [ [ unswons ] dip cons ] times lreverse swap ; -: sequence>list ( sequence -- list ) +: sequence>list ( sequence -- list ) nil [ swons ] reduce ; : lmap>array ( ... list quot: ( ... elt -- ... newelt ) -- ... array ) collector [ leach ] dip { } like ; inline -: list>array ( list -- array ) +: list>array ( list -- array ) [ ] lmap>array ; INSTANCE: cons-state list INSTANCE: +nil+ list + +GENERIC: >list ( object -- list ) + +M: list >list ; diff --git a/basis/logging/logging-tests.factor b/basis/logging/logging-tests.factor index a7cc6c6f5f..a2e67bfd62 100644 --- a/basis/logging/logging-tests.factor +++ b/basis/logging/logging-tests.factor @@ -1,5 +1,6 @@ IN: logging.tests -USING: tools.test logging logging.analysis io math ; +USING: tools.test logging logging.analysis logging.server io +io.files.temp math ; : input-logging-test ( a b -- c ) + ; @@ -13,14 +14,16 @@ USING: tools.test logging logging.analysis io math ; \ error-logging-test ERROR add-error-logging -"logging-test" [ - [ 4 ] [ 1 3 input-logging-test ] unit-test - - [ 4 ] [ 1 3 output-logging-test ] unit-test - - [ 4/3 ] [ 4 3 error-logging-test ] unit-test - - [ f ] [ 1 0 error-logging-test ] unit-test -] with-logging +temp-directory [ + "logging-test" [ + [ 4 ] [ 1 3 input-logging-test ] unit-test -[ ] [ "logging-test" { "input-logging-test" } analyze-log-file ] unit-test + [ 4 ] [ 1 3 output-logging-test ] unit-test + + [ 4/3 ] [ 4 3 error-logging-test ] unit-test + + [ f ] [ 1 0 error-logging-test ] unit-test + ] with-logging + + [ ] [ "logging-test" { "input-logging-test" } analyze-log-file ] unit-test +] with-log-root diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index ae85af8def..ab35bc5006 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -21,11 +21,11 @@ log-level [ DEBUG ] initialize { WARNING 20 } { ERROR 30 } { CRITICAL 40 } - } ; + } ; inline ERROR: undefined-log-level ; -: log-level<=> ( log-level log-level -- ? ) +: log-level<=> ( log-level log-level -- <=> ) [ log-levels at* [ undefined-log-level ] unless ] compare ; : log? ( log-level -- ? ) diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 0a7daf310f..28fbe22e7b 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel io io.files io.pathnames io.directories -io.encodings.utf8 calendar calendar.format sequences continuations -destructors prettyprint assocs math.parser words debugger math -combinators concurrency.messaging threads arrays init math.ranges -strings ; +USING: assocs calendar calendar.format combinators +concurrency.messaging continuations debugger destructors init io +io.directories io.encodings.utf8 io.files io.pathnames kernel +locals math math.parser math.ranges namespaces sequences +strings threads ; IN: logging.server : log-root ( -- string ) - \ log-root get "logs" resource-path or ; + \ log-root get-global [ "logs" resource-path ] unless* ; : log-path ( service -- path ) log-root prepend-path ; @@ -26,32 +26,35 @@ SYMBOL: log-files : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; -: multiline-header ( -- string ) 20 CHAR: - ; foldable +: close-log-streams ( -- ) + log-files get [ values dispose-each ] [ clear-assoc ] bi ; -: (write-message) ( msg word-name level multi? -- ) - [ - "[" write multiline-header write "] " write - ] [ - "[" write now (timestamp>rfc3339) "] " write - ] if - write bl write ": " write print ; +:: with-log-root ( path quot -- ) + [ close-log-streams path \ log-root set-global quot call ] + \ log-root get-global + [ \ log-root set-global close-log-streams ] curry + [ ] cleanup ; inline + +: timestamp-header. ( -- ) + "[" write now (timestamp>rfc3339) "] " write ; + +: multiline-header ( -- str ) 20 CHAR: - ; foldable + +: multiline-header. ( -- ) + "[" write multiline-header write "] " write ; : write-message ( msg word-name level -- ) - [ harvest ] 2dip { - { [ pick empty? ] [ 3drop ] } - { [ pick length 1 = ] [ [ first ] 2dip f (write-message) ] } - [ - [ [ first ] 2dip f (write-message) ] - [ [ rest ] 2dip [ t (write-message) ] 2curry each ] - 3bi - ] - } cond ; + [ harvest ] 2dip pick empty? [ 3drop ] [ + timestamp-header. + [ write bl write ": " write print ] 2curry + [ multiline-header. ] swap interleave + ] if ; : (log-message) ( msg -- ) #! msg: { msg word-name level service } first4 log-stream [ write-message flush ] with-output-stream* ; -: try-dispose ( stream -- ) +: try-dispose ( obj -- ) [ dispose ] curry [ error. ] recover ; : close-log ( service -- ) @@ -67,7 +70,8 @@ CONSTANT: keep-logs 10 : ?delete-file ( path -- ) dup exists? [ delete-file ] [ drop ] if ; -: delete-oldest ( service -- ) keep-logs log# ?delete-file ; +: delete-oldest ( service -- ) + keep-logs log# ?delete-file ; : ?move-file ( old new -- ) over exists? [ move-file ] [ 2drop ] if ; diff --git a/basis/match/match-tests.factor b/basis/match/match-tests.factor index e31f01f1b3..f24e5f7bf4 100644 --- a/basis/match/match-tests.factor +++ b/basis/match/match-tests.factor @@ -8,39 +8,39 @@ MATCH-VARS: ?a ?b ; [ f ] [ { ?a ?a } { 1 2 } match ] unit-test [ H{ { ?a 1 } { ?b 2 } } ] [ - { ?a ?b } { 1 2 } match + { ?a ?b } { 1 2 } match ] unit-test -[ { 1 2 } ] [ - { 1 2 } - { - { { ?a ?b } [ ?a ?b 2array ] } - } match-cond +[ { 1 2 } ] [ + { 1 2 } + { + { { ?a ?b } [ ?a ?b 2array ] } + } match-cond ] unit-test -[ t ] [ - { 1 2 } - { - { { 1 2 } [ t ] } - { f [ f ] } - } match-cond +[ t ] [ + { 1 2 } + { + { { 1 2 } [ t ] } + { f [ f ] } + } match-cond ] unit-test -[ t ] [ - { 1 3 } - { - { { 1 2 } [ t ] } - { { 1 3 } [ t ] } - } match-cond +[ t ] [ + { 1 3 } + { + { { 1 2 } [ t ] } + { { 1 3 } [ t ] } + } match-cond ] unit-test -[ f ] [ - { 1 5 } - { - { { 1 2 } [ t ] } - { { 1 3 } [ t ] } - { _ [ f ] } - } match-cond +[ f ] [ + { 1 5 } + { + { { 1 2 } [ t ] } + { { 1 3 } [ t ] } + { _ [ f ] } + } match-cond ] unit-test TUPLE: foo a b ; @@ -48,31 +48,29 @@ TUPLE: foo a b ; C: foo { 1 2 } [ - 1 2 T{ foo f ?a ?b } match [ - ?a ?b - ] with-variables + 1 2 T{ foo f ?a ?b } match [ + ?a ?b + ] with-variables ] unit-test { 1 2 } [ - 1 2 \ ?a \ ?b match [ - ?a ?b - ] with-variables + 1 2 \ ?a \ ?b match [ + ?a ?b + ] with-variables ] unit-test -{ H{ { ?a ?a } } } [ - \ ?a \ ?a match +{ H{ { ?a ?a } } } [ + \ ?a \ ?a match ] unit-test -[ "match" ] [ - "abcd" { - { ?a [ "match" ] } - } match-cond +[ "match" ] [ + "abcd" { + { ?a [ "match" ] } + } match-cond ] unit-test -[ - { 2 1 } -] [ - { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace +{ { 2 1 } } [ + { "a" 1 2 "b" } { _ ?a ?b _ } { ?b ?a } match-replace ] unit-test TUPLE: match-replace-test a b ; @@ -80,8 +78,8 @@ TUPLE: match-replace-test a b ; [ T{ match-replace-test f 2 1 } ] [ - T{ match-replace-test f 1 2 } - T{ match-replace-test f ?a ?b } - T{ match-replace-test f ?b ?a } - match-replace + T{ match-replace-test f 1 2 } + T{ match-replace-test f ?a ?b } + T{ match-replace-test f ?b ?a } + match-replace ] unit-test diff --git a/basis/math/bits/bits-docs.factor b/basis/math/bits/bits-docs.factor index ecf53b6a08..5babf8c0bf 100644 --- a/basis/math/bits/bits-docs.factor +++ b/basis/math/bits/bits-docs.factor @@ -5,29 +5,32 @@ IN: math.bits ABOUT: "math.bits" -ARTICLE: "math.bits" "Number bits virtual sequence" -"The " { $vocab-link "math.bits" } " vocabulary implements a virtual sequence which presents an integer as a sequence of bits, with the first element of the sequence being the least significant bit of the integer." +ARTICLE: "math.bits" "Integer virtual sequences" +"The " { $vocab-link "math.bits" } " vocabulary implements words that represent a positive integer as a virtual sequence of bits in order of ascending significance, e.g. " { $snippet "{ f f f t }" } " is " { $snippet "8" } "." { $subsections bits make-bits + bits>number } ; HELP: bits -{ $class-description "Virtual sequence class of bits of a number. The first bit is the least significant bit. This can be constructed with " { $link } " or " { $link make-bits } "." } ; +{ $class-description "Tuple representing a number as a virtual sequence of booleans. The first bit is the least significant bit. Constructors are " { $link } " or " { $link make-bits } "." } ; HELP: { $values { "number" integer } { "length" integer } { "bits" bits } } -{ $description "Creates a virtual sequence of bits of a number in little endian order, with the given length." } ; +{ $description "Constructor for a " { $link bits } " tuple." } ; HELP: make-bits { $values { "number" integer } { "bits" bits } } -{ $description "Creates a " { $link bits } " object out of the given number, using its log base 2 as the length. This implies that the last element, corresponding to the most significant bit, will be 1." } +{ $description "Creates a sequence of " { $link bits } " in ascending significance. Throws an error on negative numbers." } { $examples { $example "USING: math.bits prettyprint arrays ;" "0b1101 make-bits >array ." "{ t f t t }" } - { $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" } + { $example "USING: math.bits prettyprint arrays ;" "64 make-bits >array ." "{ f f f f f f t }" } } ; +{ make-bits } related-words -HELP: unbits +HELP: bits>number { $values { "seq" sequence } { "number" integer } } -{ $description "Turns a sequence of booleans, of the same format made by the " { $link bits } " class, and calculates the number that it represents as little-endian." } ; +{ $description "Converts a sequence of booleans in ascending significance into a number." } ; +{ make-bits bits>number } related-words diff --git a/basis/math/bits/bits-tests.factor b/basis/math/bits/bits-tests.factor index 6a39488bdb..a4b3794697 100644 --- a/basis/math/bits/bits-tests.factor +++ b/basis/math/bits/bits-tests.factor @@ -11,9 +11,8 @@ IN: math.bits.tests [ 6 ] [ 0b111111 make-bits length ] unit-test [ 0 ] [ 0 make-bits length ] unit-test [ 2 ] [ 3 make-bits length ] unit-test -[ 2 ] [ -3 make-bits length ] unit-test [ 1 ] [ 1 make-bits length ] unit-test -[ 1 ] [ -1 make-bits length ] unit-test +[ -3 make-bits length ] [ non-negative-integer-expected? ] must-fail-with ! Odd bug [ t ] [ @@ -30,5 +29,5 @@ IN: math.bits.tests 1067811677921310779 >bignum make-bits last ] unit-test -[ 6 ] [ 6 make-bits unbits ] unit-test -[ 6 ] [ 6 3 >array unbits ] unit-test +[ 6 ] [ 6 make-bits bits>number ] unit-test +[ 6 ] [ 6 3 >array bits>number ] unit-test diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 4de49c06a7..4b94a3c733 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -6,7 +6,11 @@ IN: math.bits TUPLE: bits { number read-only } { length read-only } ; C: bits +: check-negative-bits ( n -- n ) + dup 0 < [ non-negative-integer-expected ] when ; inline + : make-bits ( number -- bits ) + check-negative-bits [ T{ bits f 0 0 } ] [ dup abs log2 1 + ] if-zero ; inline M: bits length length>> ; inline @@ -15,5 +19,5 @@ M: bits nth-unsafe number>> swap bit? ; inline INSTANCE: bits immutable-sequence -: unbits ( seq -- number ) +: bits>number ( seq -- number ) 0 [ [ 1 shift ] dip [ 1 + ] when ] reduce ; diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index 039fe860fc..f1d515b4e2 100644 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -51,24 +51,7 @@ HELP: bitroll { $example "USING: math.bitwise prettyprint ;" "0xffff0000 8 32 bitroll .h" "ff0000ff" } } ; -HELP: bit-clear? -{ $values - { "x" integer } { "n" integer } - { "?" "a boolean" } -} -{ $description "Returns " { $link t } " if the nth bit is set to zero." } -{ $examples - { $example "USING: math.bitwise prettyprint ;" - "0xff 8 bit-clear? ." - "t" - } - { $example "USING: math.bitwise prettyprint ;" - "0xff 7 bit-clear? ." - "f" - } -} ; - -{ bit? bit-clear? set-bit clear-bit } related-words +{ bit? set-bit clear-bit } related-words HELP: bit-count { $values @@ -201,7 +184,7 @@ HELP: >signed HELP: mask { $values { "x" integer } { "n" integer } - { "?" "a boolean" } + { "y" integer } } { $description "After the operation, only the bits that were set in both the mask and the original number are set." } { $examples @@ -227,7 +210,7 @@ HELP: mask-bit HELP: mask? { $values { "x" integer } { "n" integer } - { "?" "a boolean" } + { "?" boolean } } { $description "Returns true if all of the bits in the mask " { $snippet "n" } " are set in the integer input " { $snippet "x" } "." } { $examples @@ -314,7 +297,7 @@ HELP: shift-mod HELP: unmask { $values { "x" integer } { "n" integer } - { "?" "a boolean" } + { "y" integer } } { $description "Clears the bits in " { $snippet "x" } " if they are set in the mask " { $snippet "n" } "." } { $examples @@ -327,7 +310,7 @@ HELP: unmask HELP: unmask? { $values { "x" integer } { "n" integer } - { "?" "a boolean" } + { "?" boolean } } { $description "Tests whether unmasking the bits in " { $snippet "x" } " would return an integer greater than zero." } { $examples @@ -441,10 +424,9 @@ $nl set-bit clear-bit } -"Testing if bits are set or clear:" +"Testing if bits are set:" { $subsections bit? - bit-clear? } "Extracting bits from an integer:" { $subsections diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index e17ddbeec6..164106a966 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -64,6 +64,8 @@ SPECIALIZED-ARRAY: uint-4 [ 3 ] [ 3 >odd ] unit-test [ 5 ] [ 4 >odd ] unit-test +[ t ] [ 0b111 0b110 mask? ] unit-test +[ f ] [ 0b101 0b110 mask? ] unit-test [ t ] [ 0xff 1 mask? ] unit-test [ f ] [ 0x0 1 mask? ] unit-test @@ -73,10 +75,8 @@ SPECIALIZED-ARRAY: uint-4 [ 6 ] [ 5 next-even ] unit-test [ 8 ] [ 6 next-even ] unit-test -[ f ] [ 0x1 0 bit-clear? ] unit-test -[ t ] [ 0x0 1 bit-clear? ] unit-test - -[ -1 bit-count ] [ invalid-bit-count-target? ] must-fail-with +[ -1 bit-count ] [ non-negative-integer-expected? ] must-fail-with +[ -1 bit-length ] [ non-negative-integer-expected? ] must-fail-with { 0b1111 } [ 4 on-bits ] unit-test { 0 } [ 0 on-bits ] unit-test @@ -101,10 +101,18 @@ SPECIALIZED-ARRAY: uint-4 { 0 } [ 0 0 toggle-bit 0 toggle-bit ] unit-test { 0 } [ 0 1 toggle-bit 1 toggle-bit ] unit-test - { 0 } [ 0b1111 33 33 bit-range ] unit-test { 0 } [ 0b1111 33 20 bit-range ] unit-test { 0b11 } [ 0b1111 3 2 bit-range ] unit-test [ 0b1111 2 3 bit-range ] [ T{ bit-range-error f 0b1111 2 3 } = ] must-fail-with [ 0b1111 -2 -4 bit-range ] [ T{ bit-range-error f 0b1111 -2 -4 } = ] must-fail-with +{ 0 } [ 0b0 bit-length ] unit-test +{ 1 } [ 0b1 bit-length ] unit-test +{ 1 } [ 0b01 bit-length ] unit-test +{ 2 } [ 0b10 bit-length ] unit-test +{ 2 } [ 0b11 bit-length ] unit-test +{ 3 } [ 0b100 bit-length ] unit-test +{ 3 } [ 0b101 bit-length ] unit-test +{ 3 } [ 0b110 bit-length ] unit-test +{ 3 } [ 0b111 bit-length ] unit-test diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 2d78dd856d..93765116df 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -10,19 +10,17 @@ IN: math.bitwise ! utilities : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline : set-bit ( x n -- y ) 2^ bitor ; inline -: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline -: unmask ( x n -- ? ) bitnot bitand ; inline +: unmask ( x n -- y ) bitnot bitand ; inline : unmask? ( x n -- ? ) unmask zero? not ; inline -: mask ( x n -- ? ) bitand ; inline -: mask? ( x n -- ? ) mask zero? not ; inline +: mask ( x n -- y ) bitand ; inline +: mask? ( x n -- ? ) [ mask ] [ = ] bi ; inline : wrap ( m n -- m' ) 1 - bitand ; inline : on-bits ( m -- n ) dup 0 <= [ drop 0 ] [ 2^ 1 - ] if ; inline : bits ( m n -- m' ) on-bits mask ; inline : mask-bit ( m n -- m' ) 2^ mask ; inline : toggle-bit ( m n -- m' ) 2^ bitxor ; inline : >signed ( x n -- y ) - [ bits ] keep 2dup neg 1 + shift - 1 number= [ 2^ - ] [ drop ] if ; + [ bits ] keep 2dup 1 - bit? [ 2^ - ] [ drop ] if ; inline : >odd ( m -- n ) 0 set-bit ; foldable : >even ( m -- n ) 0 clear-bit ; foldable : next-even ( m -- n ) >even 2 + ; foldable @@ -120,16 +118,14 @@ M: bignum (bit-count) ] if-zero ; : byte-array-bit-count ( byte-array -- n ) - 0 [ byte-bit-count + ] reduce ; inline + [ byte-bit-count ] map-sum ; inline PRIVATE> -ERROR: invalid-bit-count-target object ; - GENERIC: bit-count ( obj -- n ) M: integer bit-count - dup 0 < [ invalid-bit-count-target ] when (bit-count) ; inline + dup 0 < [ non-negative-integer-expected ] when (bit-count) ; inline M: byte-array bit-count byte-array-bit-count ; @@ -137,6 +133,11 @@ M: byte-array bit-count M: object bit-count binary-object uchar byte-array-bit-count ; +: bit-length ( x -- n ) + dup 0 < [ non-negative-integer-expected ] [ + dup 1 > [ log2 1 + ] when + ] if ; + : even-parity? ( obj -- ? ) bit-count even? ; : odd-parity? ( obj -- ? ) bit-count odd? ; diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 105fbe5103..776ab37916 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -40,6 +40,10 @@ HELP: { $values { "seq" sequence } { "permutations" sequence } } { $description "An efficient sequence containing the lexicographical permutations of " { $snippet "seq" } "." } ; +HELP: +{ $values { "seq" sequence } { "k" integer } { "permutations" sequence } } +{ $description "An efficient sequence containing the " { $snippet "k" } " lexicographical permutations of " { $snippet "seq" } "." } ; + HELP: all-permutations { $values { "seq" sequence } { "seq'" sequence } } { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } @@ -49,7 +53,7 @@ HELP: all-permutations } ; HELP: each-permutation -{ $values { "seq" sequence } { "quot" { $quotation "( ... elt -- ... )" } } } +{ $values { "seq" sequence } { "quot" { $quotation ( ... elt -- ... ) } } } { $description "Applies the quotation to each permutation of " { $snippet "seq" } " in order." } ; HELP: inverse-permutation @@ -94,7 +98,7 @@ HELP: all-combinations }""" } } ; HELP: each-combination -{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( ... elt -- ... )" } } } +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation ( ... elt -- ... ) } } } { $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ; diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 89809f2d3e..8605a137f8 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -1,4 +1,5 @@ -USING: kernel math math.combinatorics math.combinatorics.private tools.test sequences ; +USING: arrays kernel math math.combinatorics +math.combinatorics.private tools.test sequences ; IN: math.combinatorics.tests [ 1 ] [ -1 factorial ] unit-test ! required by other math.combinatorics words @@ -99,3 +100,9 @@ IN: math.combinatorics.tests { f } [ { 1 2 3 } [ last 4 = ] find-permutation ] unit-test { { 2 1 3 } } [ { 1 2 3 } [ first 2 = ] find-permutation ] unit-test + +{ { { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } } } +[ 3 iota >array ] unit-test + +{ { "as" "ad" "af" "sa" "sd" "sf" "da" "ds" "df" "fa" "fs" "fd" } } +[ "asdf" 2 >array ] unit-test diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 1da0ad100d..904b42c53a 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,14 +1,26 @@ ! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer, John Benediktsson. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs binary-search classes.tuple fry -kernel locals math math.order math.ranges memoize namespaces -sequences sequences.private sorting ; +USING: accessors arrays assocs binary-search classes.tuple +combinators fry hints kernel kernel.private locals math +math.order math.ranges memoize namespaces sequences +sequences.private sorting strings vectors ; FROM: sequences => change-nth ; IN: math.combinatorics ( seq k -- permutations ) + seq length :> n + n k nPk :> len + { + { [ len k [ zero? ] either? ] [ { } ] } + { [ n k = ] [ seq ] } + [ len n factorial over /i k seq k-permutations boa ] + } cond ; + +M: k-permutations length length>> ; inline +M: k-permutations nth-unsafe + [ skip>> * ] + [ seq>> [ permutation-indices ] keep ] + [ k>> swap [ head ] dip nths-unsafe ] tri ; +M: k-permutations hashcode* tuple-hashcode ; + +INSTANCE: k-permutations immutable-sequence + DEFER: next-permutation : all-permutations ( seq -- seq' ) [ ] map-permutations ; +: all-permutations? ( ... seq quot: ( ... elt -- ... ? ) -- ... ? ) + permutations-quot all? ; inline + : find-permutation ( ... seq quot: ( ... elt -- ... ? ) -- ... elt/f ) [ permutations-quot find drop ] [ drop over [ permutation ] [ 2drop f ] if ] 2bi ; inline @@ -100,13 +135,13 @@ PRIVATE> ] keep swap ] find-last drop nip ; + [ last ] keep [ [ > ] keep swap ] find-last drop nip ; inline : greater-from-last ( n seq -- i ) - [ nip ] [ nth ] 2bi [ > ] curry find-last drop ; + [ nip ] [ nth ] 2bi [ > ] curry find-last drop ; inline : reverse-tail! ( n seq -- seq ) - [ swap 1 + tail-slice reverse! drop ] keep ; + [ swap 1 + tail-slice reverse! drop ] keep ; inline : (next-permutation) ( seq -- seq ) dup cut-point [ @@ -114,6 +149,8 @@ PRIVATE> [ exchange ] [ reverse-tail! nip ] 3bi ] [ reverse! ] if* ; +HINTS: (next-permutation) array ; + PRIVATE> : next-permutation ( seq -- seq ) @@ -162,21 +199,21 @@ INSTANCE: combinations immutable-sequence = ] find-index drop ; + over length - '[ _ + >= ] find-index drop ; inline : increment-rest ( i seq -- ) [ nth ] [ swap tail-slice ] 2bi - [ drop 1 + dup ] map! 2drop ; + [ drop 1 + dup ] map! 2drop ; inline : increment-last ( seq -- ) - [ [ length 1 - ] keep [ 1 + ] change-nth ] unless-empty ; + [ [ length 1 - ] keep [ 1 + ] change-nth ] unless-empty ; inline :: next-combination ( seq n -- seq ) seq n find-max-index [ 1 [-] seq increment-rest ] [ seq increment-last - ] if* seq ; + ] if* seq ; inline :: combinations-quot ( seq k quot -- seq quot' ) seq length :> n @@ -200,6 +237,9 @@ PRIVATE> : all-combinations ( seq k -- seq' ) [ ] map-combinations ; +: all-combinations? ( ... seq k quot: ( ... elt -- ... ? ) -- ... ? ) + combinations-quot all? ; inline + : find-combination ( ... seq k quot: ( ... elt -- ... ? ) -- ... elt/f ) [ combinations-quot find drop ] [ drop pick [ combination ] [ 3drop f ] if ] 3bi ; inline @@ -221,4 +261,3 @@ PRIVATE> : selections ( seq n -- selections ) dup 0 > [ (selections) ] [ 2drop { } ] if ; - diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index df4e9e3d11..af02a9ddd0 100755 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -1,7 +1,7 @@ USING: kernel math math.floats.env math.floats.env.private -math.functions math.libm sequences tools.test locals +math.functions math.libm literals sequences tools.test locals compiler.units kernel.private fry compiler.test math.private -words system memory ; +words system memory kernel.private ; IN: math.floats.env.tests : set-default-fp-env ( -- ) @@ -111,7 +111,7 @@ os linux? cpu x86.64? and [ ] unit-test : fp-trap-error? ( error -- ? ) - 2 head { "kernel-error" 17 } = ; + 2 head ${ "kernel-error" ERROR-FP-TRAP } = ; : test-traps ( traps inputs quot -- quot' fail-quot ) append '[ _ _ with-fp-traps ] [ fp-trap-error? ] ; diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index f495dbcebb..32efeaa52c 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -116,6 +116,11 @@ HELP: frexp { $values { "x" number } { "y" float } { "exp" integer } } { $description "Break the number " { $snippet "x" } " into a normalized fraction " { $snippet "y" } " and an integral power of 2 " { $snippet "e^" } "." $nl "The function returns a number " { $snippet "y" } " in the interval [1/2, 1) or 0, and a number " { $snippet "exp" } " such that " { $snippet "x = y*(2**exp)" } "." } ; +HELP: ldexp +{ $values { "x" number } { "exp" number } { "y" number } } +{ $description "Multiply " { $snippet "x" } " by " { $snippet "2^exp" } "." } +{ $notes { $link ldexp } " is the inverse of " { $link frexp } "." } ; + HELP: log { $values { "x" number } { "y" number } } { $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ; @@ -251,7 +256,7 @@ HELP: polar> { $description "Converts an absolute value and argument (polar form) to a complex number." } ; HELP: [-1,1]? -{ $values { "x" number } { "?" "a boolean" } } +{ $values { "x" number } { "?" boolean } } { $description "Tests if " { $snippet "x" } " is a real number between -1 and 1, inclusive." } ; HELP: abs @@ -281,7 +286,7 @@ HELP: gcd { $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ; HELP: divisor? -{ $values { "m" integer } { "n" integer } { "?" "a boolean" } } +{ $values { "m" integer } { "n" integer } { "?" boolean } } { $description "Tests if " { $snippet "n" } " is a divisor of " { $snippet "m" } ". This is the same thing as asking if " { $snippet "m" } " is divisible by " { $snippet "n" } "." } { $notes "Returns t for both negative and positive divisors, as well as for trivial and non-trivial divisors." } ; @@ -299,7 +304,7 @@ HELP: ^mod { $description "Outputs the result of computing " { $snippet "x^y mod n" } "." } ; HELP: ~ -{ $values { "x" real } { "y" real } { "epsilon" real } { "?" "a boolean" } } +{ $values { "x" real } { "y" real } { "epsilon" real } { "?" boolean } } { $description "Tests if " { $snippet "x" } " and " { $snippet "y" } " are approximately equal to each other. There are three possible comparison tests, chosen based on the sign of " { $snippet "epsilon" } ":" { $list { { $snippet "epsilon" } " is zero: exact comparison." } diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 5063040ae5..bf275341f8 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -55,6 +55,16 @@ IN: math.functions.tests [ 0.75 10,002 t ] [ 3 10,000 2^ * [ frexp ] [ bignum? ] bi ] unit-test [ -0.75 10,002 t ] [ -3 10,000 2^ * [ frexp ] [ bignum? ] bi ] unit-test +{ 0.0 } [ 0.0 1 ldexp ] unit-test +{ -0.0 } [ -0.0 1 ldexp ] unit-test +{ 1/0. } [ 1/0. 1 ldexp ] unit-test +{ -1/0. } [ -1/0. 1 ldexp ] unit-test +{ t } [ NAN: 90210 dup 1 ldexp [ fp-nan-payload ] same? ] unit-test +{ 49152.0 } [ 12.0 12 ldexp ] unit-test +{ 0x1.8p-9 } [ 12.0 -12 ldexp ] unit-test +{ 49152 } [ 12 12 ldexp ] unit-test +{ 0 } [ 12 -12 ldexp ] unit-test + [ 0.0 ] [ 1 log ] unit-test [ 0.0 ] [ 1.0 log ] unit-test [ 1.0 ] [ e log ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 29b10a49c7..5dd3877e7d 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -204,6 +204,28 @@ M: integer frexp ] [ 1 + ] bi [ * ] dip ] if-zero ; inline +DEFER: copysign + +GENERIC# ldexp 1 ( x exp -- y ) + +M: float ldexp + over fp-special? [ over zero? ] unless* [ drop ] [ + [ double>bits dup -52 shift 0x7ff bitand 1023 - ] dip + + { + { [ dup -1074 < ] [ drop 0 copysign ] } + { [ dup 1023 > ] [ drop 0 < -1/0. 1/0. ? ] } + [ + dup -1022 < [ 52 + -52 2^ ] [ 1 ] if + [ -0x7ff0,0000,0000,0001 bitand ] + [ 1023 + 52 shift bitor bits>double ] + [ * ] tri* + ] + } cond + ] if ; + +M: integer ldexp + 2dup [ zero? ] either? [ 2drop 0 ] [ shift ] if ; + GENERIC: log ( x -- y ) M: float log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline @@ -388,7 +410,7 @@ M: float round dup sgn 2 /f + truncate ; : roots ( x t -- seq ) [ [ log ] [ recip ] bi* * e^ ] [ recip 2pi * 0 swap complex boa e^ ] - [ iota [ ^ * ] with with map ] tri ; + [ iota [ ^ * ] 2with map ] tri ; : sigmoid ( x -- y ) neg e^ 1 + recip ; inline diff --git a/basis/math/intervals/intervals-docs.factor b/basis/math/intervals/intervals-docs.factor index fd6a72807f..309e1ca074 100644 --- a/basis/math/intervals/intervals-docs.factor +++ b/basis/math/intervals/intervals-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax math math.order ; +USING: help.markup help.syntax kernel math math.order ; IN: math.intervals ARTICLE: "math-intervals-new" "Creating intervals" @@ -227,7 +227,7 @@ HELP: interval-log2 { $description "Integer-valued Base-2 logarithm of an interval." } ; HELP: interval-intersect -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } +{ $values { "i1" interval } { "i2" interval } { "i3" { $maybe interval } } } { $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ; HELP: interval-union @@ -235,11 +235,11 @@ HELP: interval-union { $description "Outputs the smallest interval containing the set-theoretic union of " { $snippet "i1" } " and " { $snippet "i2" } " (the union itself may not be an interval)." } ; HELP: interval-subset? -{ $values { "i1" interval } { "i2" interval } { "?" "a boolean" } } +{ $values { "i1" interval } { "i2" interval } { "?" boolean } } { $description "Tests if every point of " { $snippet "i1" } " is contained in " { $snippet "i2" } "." } ; HELP: interval-contains? -{ $values { "x" real } { "int" interval } { "?" "a boolean" } } +{ $values { "x" real } { "int" interval } { "?" boolean } } { $description "Tests if " { $snippet "x" } " is contained in " { $snippet "int" } "." } ; HELP: interval-closure @@ -335,7 +335,7 @@ HELP: assume<= { $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are less or equal to all points in " { $snippet "i2" } "." } ; HELP: assume> -{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } } +{ $values { "i1" interval } { "i2" interval } { "i3" { $maybe interval } } } { $description "Outputs the interval consisting of points from " { $snippet "i1" } " which are greater than all points in " { $snippet "i2" } ". If the resulting interval is empty, outputs " { $link f } "." } ; HELP: assume>= diff --git a/basis/math/matrices/elimination/elimination-docs.factor b/basis/math/matrices/elimination/elimination-docs.factor new file mode 100644 index 0000000000..9ea3f607d6 --- /dev/null +++ b/basis/math/matrices/elimination/elimination-docs.factor @@ -0,0 +1,38 @@ +USING: help.markup help.syntax math sequences ; + +IN: math.matrices.elimination + +HELP: inverse +{ $values { "matrix" sequence } } +{ $description "Computes the multiplicative inverse of a matrix. Assuming the matrix is invertible." } +{ $examples + "A matrix multiplied by its inverse is the identity matrix." + { $example + "USING: kernel math.matrices math.matrices.elimination prettyprint ;" + "{ { 3 4 } { 7 9 } } dup inverse m. 2 identity-matrix = ." + "t" + } +} ; + +HELP: echelon +{ $values { "matrix" sequence } { "matrix'" sequence } } +{ $description "Computes the reduced row-echelon form of the matrix." } ; + +HELP: nonzero-rows +{ $values { "matrix" sequence } { "matrix'" sequence } } +{ $description "Removes all all-zero rows from the matrix" } +{ $examples + { $example + "USING: math.matrices.elimination prettyprint ;" + "{ { 0 0 } { 5 6 } { 0 0 } { 4 0 } } nonzero-rows ." + "{ { 5 6 } { 4 0 } }" + } +} ; + +HELP: leading +{ $values + { "seq" sequence } + { "n" "the index of the first match, or " { $snippet f } "." } + { "elt" "the first non-zero element, or " { $snippet f } "." } +} +{ $description "Find the first non-zero element of a sequence." } ; diff --git a/basis/math/matrices/matrices-docs.factor b/basis/math/matrices/matrices-docs.factor index 9a83d438db..2242715c93 100644 --- a/basis/math/matrices/matrices-docs.factor +++ b/basis/math/matrices/matrices-docs.factor @@ -1,5 +1,4 @@ USING: help.markup help.syntax math sequences ; - IN: math.matrices HELP: zero-matrix @@ -14,6 +13,50 @@ HELP: identity-matrix { $values { "n" integer } { "matrix" sequence } } { $description "Creates an identity matrix of size " { $snippet "n x n" } ", where the diagonal values are all ones." } ; +HELP: m.v +{ $values { "m" sequence } { "v" sequence } } +{ $description "Computes the dot product between a matrix and a vector." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 1 -1 2 } { 0 -3 1 } } { 2 1 0 } m.v ." + "{ 1 -3 }" + } +} ; + +HELP: m. +{ $values { "m" sequence } } +{ $description "Computes the dot product between two matrices, i.e multiplies them." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 1 -1 2 } { 0 -3 1 } } { { 3 7 } { 9 12 } } m. ." + "{ { -6 -5 } { -27 -36 } }" + } +} ; + +HELP: m+ +{ $values { "m" sequence } } +{ $description "Adds the matrices component-wise." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 1 2 } { 3 4 } } { { 5 6 } { 7 8 } } m+ ." + "{ { 6 8 } { 10 12 } }" + } +} ; + +HELP: m- +{ $values { "m" sequence } } +{ $description "Subtracts the matrices component-wise." } +{ $examples + { $example + "USING: math.matrices prettyprint ;" + "{ { 5 9 } { 15 17 } } { { 3 2 } { 4 9 } } m- ." + "{ { 2 7 } { 11 8 } }" + } +} ; + HELP: kron { $values { "m1" sequence } { "m2" sequence } { "m" sequence } } { $description "Calculates the Kronecker product of two matrices." } diff --git a/basis/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor index 2870385093..e7a1124d0d 100644 --- a/basis/math/matrices/matrices-tests.factor +++ b/basis/math/matrices/matrices-tests.factor @@ -208,6 +208,7 @@ IN: math.matrices.tests [ { { 4181 6765 } { 6765 10946 } } ] [ { { 0 1 } { 1 1 } } 20 m^n ] unit-test +[ { { 0 1 } { 1 1 } } -20 m^n ] [ negative-power-matrix? ] must-fail-with { { { 0 5 0 10 } { 6 7 12 14 } { 0 15 0 20 } { 18 21 24 28 } } @@ -377,3 +378,8 @@ CONSTANT: test-points { { 5 6 } square-cols ] unit-test +{ t } [ { } square-matrix? ] unit-test +{ t } [ { { 1 } } square-matrix? ] unit-test +{ t } [ { { 1 2 } { 3 4 } } square-matrix? ] unit-test +{ f } [ { { 1 } { 2 3 } } square-matrix? ] unit-test +{ f } [ { { 1 2 } } square-matrix? ] unit-test diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index efeb0ef6e0..58e205fcfd 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -167,10 +167,15 @@ IN: math.matrices : norm-gram-schmidt ( seq -- orthonormal ) gram-schmidt [ normalize ] map ; -: m^n ( m n -- n ) +ERROR: negative-power-matrix m n ; + +: (m^n) ( m n -- n ) make-bits over first length identity-matrix [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ; +: m^n ( m n -- n ) + dup 0 >= [ (m^n) ] [ negative-power-matrix ] if ; + : stitch ( m -- m' ) [ ] [ [ append ] 2map ] map-reduce ; @@ -197,7 +202,6 @@ IN: math.matrices : set-indices ( object sequence matrix -- ) '[ _ set-index ] with each ; inline - : matrix-map ( matrix quot -- ) '[ _ map ] map ; inline @@ -224,24 +228,24 @@ IN: math.matrices GENERIC: square-rows ( object -- matrix ) M: integer square-rows iota square-rows ; -M: sequence square-rows dup [ nip ] cartesian-map ; +M: sequence square-rows + [ length ] keep >array '[ _ clone ] { } replicate-as ; GENERIC: square-cols ( object -- matrix ) M: integer square-cols iota square-cols ; -M: sequence square-cols dup [ drop ] cartesian-map ; +M: sequence square-cols + [ length ] keep [ ] with { } map-as ; : make-matrix-with-indices ( m n quot -- matrix ) [ [ iota ] bi@ ] dip '[ @ ] cartesian-map ; inline -: null-matrix? ( matrix -- ? ) empty? ; +: null-matrix? ( matrix -- ? ) empty? ; inline : well-formed-matrix? ( matrix -- ? ) - dup null-matrix? [ - drop t - ] [ + [ t ] [ [ ] [ first length ] bi '[ length _ = ] all? - ] if ; + ] if-empty ; : dim ( matrix -- pair/f ) [ 2 0 ] @@ -262,7 +266,6 @@ M: sequence square-cols dup [ drop ] cartesian-map ; : lower-matrix-indices ( matrix -- matrix' ) dimension-range [ head-slice >array ] 2map concat ; - : make-lower-matrix ( object m n -- matrix ) zero-matrix [ lower-matrix-indices ] [ set-indices ] [ ] tri ; diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor index ce00fcb495..05005c58b5 100644 --- a/basis/math/polynomials/polynomials-docs.factor +++ b/basis/math/polynomials/polynomials-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax math sequences ; +USING: help.markup help.syntax kernel math sequences ; IN: math.polynomials ARTICLE: "polynomials" "Polynomials" @@ -31,7 +31,7 @@ HELP: powers { $examples { $example "USING: math.polynomials prettyprint ;" "4 2 powers ." "{ 1 2 4 8 }" } } ; HELP: p= -{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "?" "a boolean" } } +{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "?" boolean } } { $description "Tests if two polynomials are equal." } { $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 } { 0 1 0 } p= ." "t" } } ; diff --git a/basis/math/polynomials/polynomials-tests.factor b/basis/math/polynomials/polynomials-tests.factor index 43217b452c..4ea6bb11e8 100644 --- a/basis/math/polynomials/polynomials-tests.factor +++ b/basis/math/polynomials/polynomials-tests.factor @@ -17,6 +17,7 @@ IN: math.polynomials.tests [ { 4 8 0 12 } ] [ 4 { 1 2 0 3 } n*p ] unit-test [ { 1 4 4 0 0 } ] [ { 1 2 0 } p-sq ] unit-test [ { 1 6 12 8 0 0 0 } ] [ { 1 2 0 } 3 p^ ] unit-test +[ { 1 2 0 } -3 p^ ] [ negative-power-polynomial? ] must-fail-with [ { 1 } ] [ { 1 2 0 } 0 p^ ] unit-test [ { 1 4 7 6 0 0 0 0 0 } ] [ { 1 2 3 0 0 0 } { 1 2 0 0 } p* ] unit-test [ V{ 7 -2 1 } V{ -20 0 0 } ] [ { 1 1 1 1 } { 3 1 } p/mod ] unit-test diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 045b661602..1212f63051 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -46,9 +46,7 @@ ERROR: negative-power-polynomial p n ; make-bits { 1 } [ [ over p* ] when [ p-sq ] dip ] reduce nip ; : p^ ( p n -- p^n ) - dup 0 >= - [ (p^) ] - [ negative-power-polynomial ] if ; + dup 0 >= [ (p^) ] [ negative-power-polynomial ] if ; array ] unit-test @@ -51,3 +51,8 @@ IN: math.ranges.tests [ 100 ] [ 1 100 [a,b] [ 2^ [1,b] ] map members length ] unit-test + +{ t } [ -10 10 1 [ sum ] [ >array sum ] bi = ] unit-test +{ t } [ -10 10 2 [ sum ] [ >array sum ] bi = ] unit-test +{ t } [ 10 -10 -1 [ sum ] [ >array sum ] bi = ] unit-test +{ t } [ 10 -10 -2 [ sum ] [ >array sum ] bi = ] unit-test diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index d257a7dff2..4c63fd3f3c 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -32,6 +32,8 @@ M: range hashcode* tuple-hashcode ; INSTANCE: range immutable-sequence +M: range sum [ length ] [ first ] [ last ] tri + * 2 / ; + -1 1 ? ; inline diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index cb6dc29760..70969cad43 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -77,3 +77,5 @@ M: ratio /i scale /i ; M: ratio /f scale /f ; M: ratio mod scale+d [ mod ] [ / ] bi* ; M: ratio /mod scale+d [ /mod ] [ / ] bi* ; +M: ratio abs dup neg? [ >fraction [ neg ] dip fraction> ] when ; +M: ratio neg? numerator neg? ; inline diff --git a/basis/math/rectangles/rectangles-docs.factor b/basis/math/rectangles/rectangles-docs.factor index 1ca6c2e584..50d7c2a483 100644 --- a/basis/math/rectangles/rectangles-docs.factor +++ b/basis/math/rectangles/rectangles-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax kernel ; IN: math.rectangles HELP: rect @@ -39,11 +39,11 @@ HELP: rect-intersect { $description "Computes the intersection of two rectangles." } ; HELP: contains-rect? -{ $values { "rect1" rect } { "rect2" rect } { "?" "a boolean" } } +{ $values { "rect1" rect } { "rect2" rect } { "?" boolean } } { $description "Tests if two rectangles have a non-empty intersection." } ; HELP: contains-point? -{ $values { "point" "a pair of integers" } { "rect" rect } { "?" "a boolean" } } +{ $values { "point" "a pair of integers" } { "rect" rect } { "?" boolean } } { $description "Tests if a rectangle contains a point." } ; HELP: diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor index f3d20b50a0..f6e66793e9 100644 --- a/basis/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -94,7 +94,7 @@ HELP: histogram HELP: histogram-by { $values { "seq" sequence } - { "quot" { $quotation "( x -- bin )" } } + { "quot" { $quotation ( x -- bin ) } } { "hashtable" hashtable } } { $description "Returns a hashtable where the keys are the elements of the sequence binned by being passed through " { $snippet "quot" } ", and the values are the number of times members of each bin appeared in that sequence." } @@ -134,7 +134,7 @@ HELP: sorted-histogram HELP: sequence>assoc { $values - { "seq" sequence } { "map-quot" $quotation } { "insert-quot" quotation } { "exemplar" "an exemplar assoc" } + { "seq" sequence } { "map-quot" quotation } { "insert-quot" quotation } { "exemplar" "an exemplar assoc" } { "assoc" assoc } } { $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } ". The " { $snippet "map-quot" } " gets passed each element from the sequence. Its outputs are passed along with the assoc being constructed to the " { $snippet "insert-quot" } ", which can modify the assoc in response." } @@ -204,6 +204,16 @@ HELP: cum-product } } ; +HELP: cum-mean +{ $values { "seq" sequence } { "seq'" sequence } } +{ $description "Returns the cumulative mean of " { $snippet "seq" } "." } +{ $examples + { $example "USING: math.statistics prettyprint ;" + "{ 1.0 2.0 3.0 } cum-mean ." + "{ 1.0 1.5 2.0 }" + } +} ; + HELP: cum-min { $values { "seq" sequence } { "seq'" sequence } } { $description "Returns the cumulative min of " { $snippet "seq" } "." } @@ -238,7 +248,7 @@ HELP: rescale HELP: collect-by { $values - { "seq" sequence } { "quot" { $quotation "( obj -- ? )" } } + { "seq" sequence } { "quot" { $quotation ( ... obj -- ... key ) } } { "hashtable" hashtable } } { $description "Applies a quotation to each element in the input sequence and returns a " { $snippet "hashtable" } " of like elements. The keys of this " { $snippet "hashtable" } " are the output of " { $snippet "quot" } " and the values at each key are the elements that transformed to that key." } @@ -254,7 +264,7 @@ HELP: collect-by HELP: collect-index-by { $values - { "seq" sequence } { "quot" { $quotation "( obj -- ? )" } } + { "seq" sequence } { "quot" { $quotation ( ... obj -- ... key ) } } { "hashtable" hashtable } } { $description "Applies a quotation to each element in the input sequence and returns a " { $snippet "hashtable" } " of like elements. The keys of this " { $snippet "hashtable" } " are the output of " { $snippet "quot" } " and the values at each key are the indices for the elements that transformed to that key." } diff --git a/basis/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor index 7e22222225..f082711d2d 100644 --- a/basis/math/statistics/statistics-tests.factor +++ b/basis/math/statistics/statistics-tests.factor @@ -1,4 +1,4 @@ -USING: assocs kernel math math.functions math.statistics sequences +USING: arrays assocs kernel math math.functions math.statistics sequences math.order tools.test math.vectors ; FROM: math.ranges => [a,b] ; IN: math.statistics.tests @@ -8,9 +8,11 @@ IN: math.statistics.tests [ 1 ] [ { 1 } mean ] unit-test [ 0 ] [ { } mean ] unit-test [ 3/2 ] [ { 1 2 } mean ] unit-test -[ 0 ] [ { 0 0 0 } geometric-mean ] unit-test +[ 0.0 ] [ { 0 0 0 } geometric-mean ] unit-test [ t ] [ { 2 2 2 2 } geometric-mean 2.0 .0001 ~ ] unit-test [ 1.0 ] [ { 1 1 1 } geometric-mean ] unit-test +[ t ] [ 1000 1000 geometric-mean 1000 .01 ~ ] unit-test +[ t ] [ 100000 100000 geometric-mean 100000 .01 ~ ] unit-test [ 1/3 ] [ { 1 1 1 } harmonic-mean ] unit-test [ 5+1/4 ] [ { 1 3 5 7 } contraharmonic-mean ] unit-test [ 18 ] [ { 4 8 15 16 23 42 } 0 trimmed-mean ] unit-test @@ -117,6 +119,7 @@ IN: math.statistics.tests [ { 1 1 2 6 } ] [ { 1 1 2 3 } cum-product ] unit-test [ { 5 3 3 1 } ] [ { 5 3 4 1 } cum-min ] unit-test [ { 1 3 3 5 } ] [ { 1 3 1 5 } cum-max ] unit-test +[ { 1.0 1.5 2.0 } ] [ { 1.0 2.0 3.0 } cum-mean ] unit-test { t } [ @@ -223,3 +226,11 @@ IN: math.statistics.tests H{ { 0 V{ 0 3 6 9 } } { 1 V{ 1 4 7 10 } } { 2 V{ 2 5 8 } } } } [ 600 610 [a,b] [ 3 mod ] collect-index-by ] unit-test + + +{ { 1 } } [ + { 1 2 3 4 5 10 21 12 12 12 12203 3403 030 3022 2 2 } + { 1/1000 } quantile5 +] unit-test + +{ 15+1/2 } [ { 4 8 15 16 23 42 } trimean ] unit-test diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 713ff46494..bf1abf7017 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Doug Coleman, Michael Judge. +! Copyright (C) 2008 Doug Coleman, Michael Judge, Loryn Jenkins. ! See http://factorcode.org/license.txt for BSD license. USING: assocs combinators generalizations kernel locals math -math.functions math.order math.vectors sequences +math.functions math.order math.vectors math.ranges sequences sequences.private sorting fry arrays grouping sets splitting.monotonic ; IN: math.statistics @@ -12,7 +12,7 @@ IN: math.statistics ! Delta in degrees-of-freedom : mean-ddof ( seq ddof -- x ) [ [ sum ] [ length ] bi ] dip - - dup zero? [ 2drop 0 ] [ / ] if ; inline + [ drop 0 ] [ / ] if-zero ; inline : mean ( seq -- x ) 0 mean-ddof ; inline @@ -33,7 +33,7 @@ IN: math.statistics [ sum-of-squares ] [ length ] bi / sqrt ; inline : geometric-mean ( seq -- x ) - [ length ] [ product ] bi nth-root ; inline + [ [ log ] map-sum ] [ length ] bi /f e^ ; inline : harmonic-mean ( seq -- x ) [ recip ] map-sum recip ; inline @@ -70,7 +70,7 @@ PRIVATE> seq length 1 - :> m! [ l m < ] [ - k seq nth x! + k seq nth-unsafe x! l i! m j! [ i j <= ] @@ -87,18 +87,17 @@ PRIVATE> j k < [ i l! ] when k i < [ j m! ] when ] while - k seq nth ; inline + k seq nth-unsafe ; inline : (kth-object) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt ) #! The algorithm modifiers seq, so we clone it - [ clone ] 4dip ((kth-object)) ; inline + [ >array ] 4dip ((kth-object)) ; inline : kth-object-unsafe ( seq k quot: ( x y -- ? ) -- elt ) [ [ nth-unsafe ] [ exchange-unsafe ] ] dip (kth-object) ; inline : kth-objects-unsafe ( seq kths quot: ( x y -- ? ) -- elts ) - [ clone ] 2dip - '[ [ nth-unsafe ] [ exchange-unsafe ] _ ((kth-object)) ] with map ; inline + '[ _ kth-object-unsafe ] with map ; inline PRIVATE> @@ -106,8 +105,7 @@ PRIVATE> [ [ nth ] [ exchange ] ] dip (kth-object) ; inline : kth-objects ( seq kths quot: ( x y -- ? ) -- elts ) - [ clone ] 2dip - '[ [ nth ] [ exchange ] _ ((kth-object)) ] with map ; inline + '[ _ kth-object ] with map ; inline : kth-smallests ( seq kths -- elts ) [ < ] kth-objects-unsafe ; @@ -166,15 +164,15 @@ PRIVATE> : frac ( x -- x' ) >fraction [ /mod nip ] keep / ; inline -:: quantile-indices ( seq qs a b c d -- seq ) +:: quantile-indices ( seq qs a b -- seq ) qs [ [ a b seq length ] dip quantile-x ] map ; :: qabcd ( y-floor y-ceiling x c d -- qabcd ) y-floor y-ceiling y-floor - c d x frac * + * + ; :: quantile-abcd ( seq qs a b c d -- quantile ) - seq qs a b c d quantile-indices :> indices - indices [ [ floor ] [ ceiling ] bi 2array ] map + seq qs a b quantile-indices :> indices + indices [ [ floor 0 max ] [ ceiling seq length 1 - min ] bi 2array ] map concat :> index-pairs seq index-pairs kth-smallests @@ -207,6 +205,9 @@ PRIVATE> : quartile ( seq -- seq' ) { 1/4 1/2 3/4 } quantile5 ; +: trimean ( seq -- x ) + quartile first3 [ 2 * ] dip + + 4 / ; + assoc) ( seq map-quot insert-quot assoc -- assoc ) @@ -247,18 +248,17 @@ PRIVATE> : normalized-histogram ( seq -- alist ) [ histogram ] [ length ] bi '[ _ / ] assoc-map ; -: collect-index-by ( seq quot -- hashtable ) - [ swap ] prepose [ push-at ] sequence-index>hashtable ; inline +: collect-index-by ( ... seq quot: ( ... obj -- ... key ) -- ... hashtable ) + [ dip swap ] curry [ push-at ] sequence-index>hashtable ; inline -: collect-by ( seq quot -- hashtable ) - [ dup ] prepose [ push-at ] sequence>hashtable ; inline +: collect-by ( ... seq quot: ( ... obj -- ... key ) -- ... hashtable ) + [ keep swap ] curry [ push-at ] sequence>hashtable ; inline : equal-probabilities ( n -- array ) dup recip ; inline : mode ( seq -- x ) - histogram >alist - [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ; + histogram >alist [ second ] supremum-by first ; : minmax ( seq -- min max ) [ first dup ] keep [ [ min ] [ max ] bi-curry bi* ] each ; @@ -340,7 +340,7 @@ ALIAS: std sample-std : sample-corr ( {x} {y} -- corr ) 1 corr-ddof ; inline -: cum-map ( seq identity quot -- seq' ) +: cum-map ( seq identity quot: ( prev elt -- next ) -- seq' ) swapd [ dup ] compose map nip ; inline : cum-sum ( seq -- seq' ) @@ -352,6 +352,9 @@ ALIAS: std sample-std : cum-product ( seq -- seq' ) 1 [ * ] cum-map ; +: cum-mean ( seq -- seq' ) + 0 swap [ [ + dup ] dip 1 + / ] map-index nip ; + : cum-count ( seq quot -- seq' ) [ 0 ] dip '[ _ call [ 1 + ] when ] cum-map ; inline @@ -380,18 +383,16 @@ ALIAS: std sample-std flip [ standardize ] map flip ; : differences ( u -- v ) - [ 1 tail-slice ] keep v- ; + [ rest-slice ] keep v- ; : rescale ( u -- v ) dup minmax over - [ v-n ] [ v/n ] bi* ; +: rankings ( histogram -- assoc ) + sort-keys 0 swap [ rot [ + ] keep swapd ] H{ } assoc-map-as nip ; + : rank-values ( seq -- seq' ) - [ - [ ] [ length iota ] bi zip sort-keys - [ [ first ] bi@ = ] monotonic-split - [ values ] map [ 0 [ length + ] accumulate nip ] [ ] bi zip - ] [ length f ] bi - [ '[ first2 [ _ set-nth ] with each ] each ] keep ; + dup histogram rankings '[ _ at ] map ; : z-score ( seq -- n ) [ demean ] [ sample-std ] bi v/n ; diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor index 97b32fd8e6..a784a77449 100644 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor @@ -160,7 +160,7 @@ PRIVATE> SIMD-INTRINSIC: (simd-v+) ( a b rep -- c ) [ + ] components-2map ; SIMD-INTRINSIC: (simd-v-) ( a b rep -- c ) [ - ] components-2map ; SIMD-INTRINSIC: (simd-vneg) ( a rep -- c ) [ neg ] components-map ; -SIMD-INTRINSIC:: (simd-v+-) ( a b rep -- c ) +SIMD-INTRINSIC:: (simd-v+-) ( a b rep -- c ) a b rep 2byte>rep-array :> ( a' b' ) rep :> c' 0 rep rep-length [ 1 - 2 ] [ 2 /i ] bi [| n | @@ -201,7 +201,7 @@ SIMD-INTRINSIC: (simd-vmax) ( a b rep -- c ) [ max ] components-2ma ! XXX SIMD-INTRINSIC: (simd-v.) ( a b rep -- n ) [ 2byte>rep-array [ [ first ] bi@ * ] 2keep ] keep - 1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] with with each ; + 1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] 2with each ; SIMD-INTRINSIC: (simd-vsqrt) ( a rep -- c ) [ fsqrt ] components-map ; SIMD-INTRINSIC: (simd-vsad) ( a b rep -- c ) 2byte>rep-array [ - abs ] [ + ] 2map-reduce ; SIMD-INTRINSIC: (simd-sum) ( a rep -- n ) [ + ] components-reduce ; @@ -245,7 +245,7 @@ SIMD-INTRINSIC:: (simd-vmerge-tail) ( a b rep -- c ) ] unrolled-each-integer c' underlying>> ; SIMD-INTRINSIC: (simd-v<=) ( a b rep -- c ) - dup rep-tf-values '[ <= _ _ ? ] components-2map ; + dup rep-tf-values '[ <= _ _ ? ] components-2map ; SIMD-INTRINSIC: (simd-v<) ( a b rep -- c ) dup rep-tf-values '[ < _ _ ? ] components-2map ; SIMD-INTRINSIC: (simd-v=) ( a b rep -- c ) @@ -276,18 +276,18 @@ SIMD-INTRINSIC: (simd-vpack-unsigned) ( a b rep -- c ) [ [ 2byte>rep-array cord-append ] [ rep-length 2 * ] bi ] [ narrow-vector-rep >uint-vector-rep [ ] [ rep-component-type ] bi ] bi '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ; -SIMD-INTRINSIC: (simd-vunpack-head) ( a rep -- c ) +SIMD-INTRINSIC: (simd-vunpack-head) ( a rep -- c ) [ byte>rep-array ] [ widen-vector-rep [ rep-length ] [ '[ _ >rep-array ] ] bi ] bi [ head-slice ] dip call( a' -- c' ) underlying>> ; SIMD-INTRINSIC: (simd-vunpack-tail) ( a rep -- c ) [ byte>rep-array ] [ widen-vector-rep [ rep-length ] [ '[ _ >rep-array ] ] bi ] bi [ tail-slice ] dip call( a' -- c' ) underlying>> ; SIMD-INTRINSIC: (simd-with) ( n rep -- v ) - [ rep-length swap '[ _ ] ] [ ] bi replicate-as + [ rep-length swap '[ _ ] ] [ ] bi replicate-as underlying>> ; SIMD-INTRINSIC: (simd-gather-2) ( m n rep -- v ) [ 2 set-firstn-unsafe ] keep underlying>> ; SIMD-INTRINSIC: (simd-gather-4) ( m n o p rep -- v ) [ 4 set-firstn-unsafe ] keep underlying>> ; -SIMD-INTRINSIC: (simd-select) ( a n rep -- x ) [ swap ] dip byte>rep-array nth-unsafe ; +SIMD-INTRINSIC: (simd-select) ( a n rep -- x ) swapd byte>rep-array nth-unsafe ; SIMD-INTRINSIC: alien-vector ( c-ptr n rep -- value ) [ swap ] dip rep-size memory>byte-array ; diff --git a/basis/math/vectors/vectors-docs.factor b/basis/math/vectors/vectors-docs.factor index 0e0d05f5e9..9859f643eb 100644 --- a/basis/math/vectors/vectors-docs.factor +++ b/basis/math/vectors/vectors-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax math math.functions sequences ; +USING: help.markup help.syntax kernel math math.functions +sequences ; IN: math.vectors ARTICLE: "math-vectors-arithmetic" "Vector arithmetic" @@ -214,45 +215,45 @@ HELP: vtruncate { $description "Truncates each element of " { $snippet "u" } "." } ; HELP: n+v -{ $values { "n" "a number" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $values { "n" number } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } { $description "Adds " { $snippet "n" } " to each element of " { $snippet "v" } "." } ; HELP: v+n -{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "w" "a sequence of numbers" } } +{ $values { "u" "a sequence of numbers" } { "n" number } { "w" "a sequence of numbers" } } { $description "Adds " { $snippet "n" } " to each element of " { $snippet "u" } "." } ; HELP: n-v -{ $values { "n" "a number" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $values { "n" number } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } { $description "Subtracts each element of " { $snippet "v" } " from " { $snippet "n" } "." } ; HELP: v-n -{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "w" "a sequence of numbers" } } +{ $values { "u" "a sequence of numbers" } { "n" number } { "w" "a sequence of numbers" } } { $description "Subtracts " { $snippet "n" } " from each element of " { $snippet "u" } "." } ; HELP: n*v -{ $values { "n" "a number" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $values { "n" number } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } { $description "Multiplies each element of " { $snippet "v" } " by " { $snippet "n" } "." } ; HELP: v*n -{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "w" "a sequence of numbers" } } +{ $values { "u" "a sequence of numbers" } { "n" number } { "w" "a sequence of numbers" } } { $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; HELP: n/v -{ $values { "n" "a number" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $values { "n" number } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } { $description "Divides " { $snippet "n" } " by each element of " { $snippet "v" } "." } { $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ; HELP: v/n -{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "w" "a sequence of numbers" } } +{ $values { "u" "a sequence of numbers" } { "n" number } { "w" "a sequence of numbers" } } { $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." } { $errors "May throw an error if a division by zero occurs; see " { $link "division-by-zero" } "." } ; HELP: n^v -{ $values { "n" "a number" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $values { "n" number } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } { $description "Raises " { $snippet "n" } " to the power of each element of " { $snippet "v" } "." } ; HELP: v^n -{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "w" "a sequence of numbers" } } +{ $values { "u" "a sequence of numbers" } { "n" number } { "w" "a sequence of numbers" } } { $description "Raises each element of " { $snippet "u" } " to the power of " { $snippet "n" } "." } ; HELP: v+ @@ -376,7 +377,7 @@ HELP: hrshift { $description "Shifts the entire SIMD array to the right by " { $snippet "n" } " bytes, filling the vacated left-hand bits with zeroes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ; HELP: vmerge -{ $values { "u" "a sequence" } { "v" "a sequence" } { "w" "a sequence" } } +{ $values { "u" sequence } { "v" sequence } { "w" sequence } } { $description "Creates a new sequence of the same type as and twice the length of " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements of " { $snippet "u" } " and " { $snippet "v" } "." } { $examples { $example """USING: kernel math.vectors prettyprint ; @@ -386,7 +387,7 @@ HELP: vmerge } } ; HELP: (vmerge) -{ $values { "u" "a sequence" } { "v" "a sequence" } { "h" "a sequence" } { "t" "a sequence" } } +{ $values { "u" sequence } { "v" sequence } { "h" sequence } { "t" sequence } } { $description "Creates two new sequences of the same type and size as " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements of " { $snippet "u" } " and " { $snippet "v" } "." } { $notes "For hardware-supported SIMD vector types this word compiles to a single instruction per output value." } { $examples @@ -398,7 +399,7 @@ HELP: (vmerge) } } ; HELP: (vmerge-head) -{ $values { "u" "a sequence" } { "v" "a sequence" } { "h" "a sequence" } } +{ $values { "u" sequence } { "v" sequence } { "h" sequence } } { $description "Creates a new sequence of the same type and size as " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements from the first half of " { $snippet "u" } " and " { $snippet "v" } "." } { $notes "For hardware-supported SIMD vector types this word compiles to a single instruction." } { $examples @@ -409,7 +410,7 @@ HELP: (vmerge-head) } } ; HELP: (vmerge-tail) -{ $values { "u" "a sequence" } { "v" "a sequence" } { "t" "a sequence" } } +{ $values { "u" sequence } { "v" sequence } { "t" sequence } } { $description "Creates a new sequence of the same type and size as " { $snippet "u" } " and " { $snippet "v" } " by interleaving the elements from the tail half of " { $snippet "u" } " and " { $snippet "v" } "." } { $notes "For hardware-supported SIMD vector types this word compiles to a single instruction." } { $examples @@ -550,7 +551,7 @@ HELP: v? { $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ; HELP: vif -{ $values { "mask" "a sequence of booleans" } { "true-quot" { $quotation "( -- vector )" } } { "false-quot" { $quotation "( -- vector )" } } { "result" "a sequence" } } +{ $values { "mask" "a sequence of booleans" } { "true-quot" { $quotation ( -- vector ) } } { "false-quot" { $quotation ( -- vector ) } } { "result" sequence } } { $description "If all of the elements of " { $snippet "mask" } " are true, " { $snippet "true-quot" } " is called and its output value returned. If all of the elements of " { $snippet "mask" } " are false, " { $snippet "false-quot" } " is called and its output value returned. Otherwise, both quotations are called and " { $snippet "mask" } " is used to select elements from each output as with " { $link v? } "." } { $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." $nl @@ -559,17 +560,17 @@ $nl { v? vif } related-words HELP: vany? -{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } } +{ $values { "v" "a sequence of booleans" } { "?" boolean } } { $description "Returns true if any element of " { $snippet "v" } " is true." } { $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs when using SIMD types." } ; HELP: vall? -{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } } +{ $values { "v" "a sequence of booleans" } { "?" boolean } } { $description "Returns true if every element of " { $snippet "v" } " is true." } { $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs when using SIMD types." } ; HELP: vnone? -{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } } +{ $values { "v" "a sequence of booleans" } { "?" boolean } } { $description "Returns true if every element of " { $snippet "v" } " is false." } { $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs when using SIMD types." } ; diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor index 36348c6bad..ff6a770715 100644 --- a/basis/mirrors/mirrors-tests.factor +++ b/basis/mirrors/mirrors-tests.factor @@ -59,3 +59,7 @@ TUPLE: color [ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test [ 1 ] [ "red" "mirror" get at ] unit-test + +{ 3 } [ { 1 2 3 } make-mirror assoc-size ] unit-test +{ 2 } [ "asdf" make-mirror assoc-size ] unit-test +{ 8 } [ \ + make-mirror assoc-size ] unit-test diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index 2fd4f07ab0..b267621918 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs hashtables kernel sequences generic words -arrays classes slots slots.private classes.tuple -classes.tuple.private math vectors math.vectors quotations -accessors combinators byte-arrays vocabs vocabs.loader ; +USING: accessors arrays assocs byte-arrays classes +classes.tuple classes.tuple.private combinators fry hashtables +kernel math quotations sequences slots slots.private strings +vectors ; IN: mirrors TUPLE: mirror { object read-only } ; @@ -35,23 +35,24 @@ M: mirror delete-at ( key mirror -- ) [ f ] 2dip set-at ; M: mirror clear-assoc ( mirror -- ) - [ object>> ] [ object-slots ] bi [ - [ initial>> ] [ offset>> ] bi swapd set-slot - ] with each ; + [ object-slots ] [ object>> ] bi '[ + [ initial>> ] [ offset>> _ swap set-slot ] bi + ] each ; M: mirror >alist ( mirror -- alist ) - [ object-slots [ [ name>> ] map ] [ [ offset>> ] map ] bi ] - [ object>> [ swap slot ] curry ] bi - map zip ; + [ object-slots ] [ object>> ] bi '[ + [ name>> ] [ offset>> _ swap slot ] bi + ] { } map>assoc ; M: mirror keys ( mirror -- keys ) object-slots [ name>> ] map ; M: mirror values ( mirror -- values ) - [ object-slots [ offset>> ] map ] - [ object>> [ swap slot ] curry ] bi map ; + [ object-slots ] [ object>> ] bi + '[ offset>> _ swap slot ] map ; -M: mirror assoc-size object>> layout-of second ; +M: mirror assoc-size + object>> class-of class-size ; INSTANCE: mirror assoc diff --git a/basis/models/arrow/arrow-docs.factor b/basis/models/arrow/arrow-docs.factor index 9bd6c4438d..2dbcda036f 100644 --- a/basis/models/arrow/arrow-docs.factor +++ b/basis/models/arrow/arrow-docs.factor @@ -15,7 +15,7 @@ HELP: arrow } ; HELP: -{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } { "arrow" "a new " { $link arrow } } } +{ $values { "model" model } { "quot" { $quotation ( obj -- newobj ) } } { "arrow" "a new " { $link arrow } } } { $description "Creates a new instance of " { $link arrow } ". The value of the new arrow model is computed by applying the quotation to the value." } { $examples "See the example in the documentation for " { $link arrow } "." } ; diff --git a/basis/models/arrow/smart/smart-docs.factor b/basis/models/arrow/smart/smart-docs.factor index b6d0ff4349..22f14c9fdc 100644 --- a/basis/models/arrow/smart/smart-docs.factor +++ b/basis/models/arrow/smart/smart-docs.factor @@ -2,7 +2,7 @@ IN: models.arrow.smart USING: help.syntax help.markup models.product ; HELP: -{ $values { "quot" { $quotation "( ... -- output )" } } } +{ $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:" @@ -18,4 +18,4 @@ 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" } "." { $subsections } ; -ABOUT: "models.arrow.smart" \ No newline at end of file +ABOUT: "models.arrow.smart" diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 480611b17d..aa0a8f3b87 100644 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -71,15 +71,15 @@ HELP: ?set-model { set-model change-model change-model* (change-model) push-model pop-model } related-words HELP: change-model -{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } } +{ $values { "model" model } { "quot" { $quotation ( ..a obj -- ..b newobj ) } } } { $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value, and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ; HELP: change-model* -{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b )" } } } +{ $values { "model" model } { "quot" { $quotation ( ..a obj -- ..b ) } } } { $description "Applies the quotation to the current value of the model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } " without actually changing the value of the model. This is useful for notifying observers of operations that mutate a value, as in " { $link push-model } " and " { $link pop-model } "." } ; HELP: (change-model) -{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } } +{ $values { "model" model } { "quot" { $quotation ( ..a obj -- ..b newobj ) } } } { $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." } { $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ; diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 0bc616cbb6..069c594b0d 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -1,25 +1,25 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces make parser lexer kernel sequences words -quotations math accessors locals ; +USING: accessors combinators kernel lexer locals make math +namespaces parser quotations sequences words ; IN: multiline ERROR: bad-heredoc identifier ; > ] [ column>> ] bi tail ; +: rest-of-line ( lexer -- seq ) + [ line-text>> ] [ column>> ] bi tail ; -: next-line-text ( -- str ) - lexer get dup next-line line-text>> ; +: next-line-text ( lexer -- str ? ) + [ next-line ] [ line-text>> ] [ still-parsing? ] tri ; -: (parse-here) ( -- ) - next-line-text [ +: (parse-here) ( lexer -- ) + dup next-line-text [ dup ";" = - [ drop lexer get next-line ] - [ % "\n" % (parse-here) ] if - ] [ ";" throw-unexpected-eof ] if* ; + [ drop next-line ] + [ % CHAR: \n , (parse-here) ] if + ] [ ";" throw-unexpected-eof ] if ; PRIVATE> @@ -27,7 +27,8 @@ ERROR: text-found-before-eol string ; : parse-here ( -- str ) [ - rest-of-line dup [ drop ] [ text-found-before-eol ] if-empty + lexer get + dup rest-of-line [ text-found-before-eol ] unless-empty (parse-here) ] "" make but-last ; @@ -38,59 +39,63 @@ SYNTAX: STRING: > :> text - text [ +:: (scan-multiline-string) ( i end lexer -- j ) + lexer line-text>> :> text + lexer still-parsing? [ end text i start* [| j | i j text subseq % j end length + ] [ text i short tail % CHAR: \n , - lexer get next-line - 0 end (scan-multiline-string) + lexer next-line + 0 end lexer (scan-multiline-string) ] if* ] [ end throw-unexpected-eof ] if ; -:: (parse-multiline-string) ( end-text skip-n-chars -- str ) +:: (parse-multiline-string) ( end-text lexer skip-n-chars -- str ) [ - lexer get - [ skip-n-chars + end-text (scan-multiline-string) ] + lexer + [ skip-n-chars + end-text lexer (scan-multiline-string) ] change-column drop ] "" make ; -:: advance-same-line ( text -- ) - lexer get [ text length + ] change-column drop ; +: advance-same-line ( lexer text -- ) + length [ + ] curry change-column drop ; -:: (parse-til-line-begins) ( begin-text -- ) - lexer get still-parsing? [ - lexer get line-text>> begin-text sequence= [ - begin-text advance-same-line +:: (parse-til-line-begins) ( begin-text lexer -- ) + lexer still-parsing? [ + lexer line-text>> begin-text sequence= [ + lexer begin-text advance-same-line ] [ - lexer get line-text>> % "\n" % - lexer get next-line - begin-text (parse-til-line-begins) + lexer line-text>> % CHAR: \n , + lexer next-line + begin-text lexer (parse-til-line-begins) ] if ] [ begin-text bad-heredoc ] if ; -: parse-til-line-begins ( begin-text -- seq ) +: parse-til-line-begins ( begin-text lexer -- seq ) [ (parse-til-line-begins) ] "" make ; PRIVATE> : parse-multiline-string ( end-text -- str ) - 1 (parse-multiline-string) ; + lexer get 1 (parse-multiline-string) ; SYNTAX: /* "*/" parse-multiline-string drop ; SYNTAX: HEREDOC: - lexer get skip-blank - rest-of-line - lexer get next-line - parse-til-line-begins suffix! ; + lexer get { + [ skip-blank ] + [ rest-of-line ] + [ next-line ] + [ parse-til-line-begins ] + } cleave suffix! ; SYNTAX: DELIMITED: - lexer get skip-blank - rest-of-line - lexer get next-line - 0 (parse-multiline-string) suffix! ; + lexer get { + [ skip-blank ] + [ rest-of-line ] + [ next-line ] + [ 0 (parse-multiline-string) ] + } cleave suffix! ; diff --git a/basis/opengl/capabilities/capabilities-docs.factor b/basis/opengl/capabilities/capabilities-docs.factor index 8b43c56f6d..159148f46c 100644 --- a/basis/opengl/capabilities/capabilities-docs.factor +++ b/basis/opengl/capabilities/capabilities-docs.factor @@ -11,7 +11,7 @@ HELP: gl-vendor-version { $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; HELP: has-gl-version? -{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $values { "version" "A version string" } { "?" boolean } } { $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; HELP: require-gl-version @@ -27,7 +27,7 @@ HELP: glsl-vendor-version { $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; HELP: has-glsl-version? -{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $values { "version" "A version string" } { "?" boolean } } { $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; HELP: require-glsl-version @@ -39,7 +39,7 @@ HELP: gl-extensions { $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ; HELP: has-gl-extensions? -{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } +{ $values { "extensions" "A sequence of extension name strings" } { "?" boolean } } { $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." } { $examples "Testing for framebuffer object and pixel buffer support:" { $code """{ @@ -49,7 +49,7 @@ HELP: has-gl-extensions? } ; HELP: has-gl-version-or-extensions? -{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } } +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" boolean } } { $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; HELP: require-gl-extensions diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor index b1b1731774..c7e2b9efb4 100644 --- a/basis/opengl/capabilities/capabilities.factor +++ b/basis/opengl/capabilities/capabilities.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces make sequences splitting opengl.gl -continuations math.parser math arrays sets strings math.order fry ; +USING: arrays fry kernel make math.order math.parser opengl.gl +sequences sets splitting strings system ; IN: opengl.capabilities : (require-gl) ( thing require-quot make-error-quot -- ) @@ -29,18 +29,22 @@ IN: opengl.capabilities : version-before? ( version1 version2 -- ? ) [ version-seq ] bi@ before=? ; -: (gl-version) ( -- version vendor ) +: (gl-version) ( -- version1 version2 ) GL_VERSION glGetString " " split1 ; -: gl-version ( -- version ) - (gl-version) drop ; -: gl-vendor-version ( -- version ) - (gl-version) nip ; -: gl-vendor ( -- name ) - GL_VENDOR glGetString ; +: gl-version ( -- version ) (gl-version) drop ; +: gl-vendor-version ( -- version ) (gl-version) nip ; +: gl-vendor ( -- vendor ) GL_VENDOR glGetString ; + : has-gl-version? ( version -- ? ) - gl-version version-before? ; + gl-version [ version-before? ] [ drop f ] if* ; + : (make-gl-version-error) ( required-version -- ) - "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ; + "Required OpenGL version " % % " not supported (" % gl-version "(null)" or % " available)" % + os linux = [ + "\nIf you have several libGL.so installed, Factor tried the first one in: ldconfig -p | grep libGL.so$" % + "\nYou can change the library used like so: LD_LIBRARY_PATH=/usr/lib/fglrx ./factor" % + ] when ; + : require-gl-version ( version -- ) [ has-gl-version? ] [ (make-gl-version-error) ] @@ -48,15 +52,13 @@ IN: opengl.capabilities : (glsl-version) ( -- version vendor ) GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ; -: glsl-version ( -- version ) - (glsl-version) drop ; -: glsl-vendor-version ( -- version ) - (glsl-version) nip ; -: has-glsl-version? ( version -- ? ) - glsl-version version-before? ; +: glsl-version ( -- version ) (glsl-version) drop ; +: glsl-vendor-version ( -- version ) (glsl-version) nip ; +: has-glsl-version? ( version -- ? ) glsl-version version-before? ; + : require-glsl-version ( version -- ) [ has-glsl-version? ] - [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] + [ "Required GLSL version " % % " not supported (" % glsl-version "(null)" or % " available)" % ] (require-gl) ; : has-gl-version-or-extensions? ( version extensions -- ? ) diff --git a/basis/opengl/framebuffers/framebuffers-docs.factor b/basis/opengl/framebuffers/framebuffers-docs.factor index 6efa63d04e..74f1b79e10 100644 --- a/basis/opengl/framebuffers/framebuffers-docs.factor +++ b/basis/opengl/framebuffers/framebuffers-docs.factor @@ -1,5 +1,4 @@ -USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs ; +USING: help.markup help.syntax math opengl.gl quotations ; IN: opengl.framebuffers HELP: gen-framebuffer @@ -29,7 +28,7 @@ HELP: check-framebuffer { $description "Checks the framebuffer currently bound by " { $link glBindFramebuffer } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ; HELP: with-framebuffer -{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } } +{ $values { "id" "The id of a framebuffer object." } { "quot" quotation } } { $description "Binds framebuffer " { $snippet "id" } " for drawing in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ; ABOUT: "gl-utilities" diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index ca4eec9dbd..4869928154 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -3,8 +3,9 @@ ! This file is based on the gl.h that comes with xorg-x11 6.8.2 -USING: alien alien.c-types alien.syntax combinators kernel parser -sequences system words opengl.gl.extensions io.encodings.ascii ; +USING: alien alien.c-types alien.libraries alien.syntax +combinators kernel parser sequences system words +opengl.gl.extensions io.encodings.ascii ; FROM: alien.c-types => short ; IN: opengl.gl @@ -628,6 +629,14 @@ CONSTANT: GL_CLIENT_ALL_ATTRIB_BITS 0xFFFFFFFF LIBRARY: gl +<< +"gl" { + { [ os windows? ] [ drop ] } + { [ os macosx? ] [ drop ] } + { [ os unix? ] [ "libGL.so" cdecl add-library ] } +} cond +>> + ! Miscellaneous FUNCTION: void glClearIndex ( GLfloat c ) ; diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 175d5ba413..7c3f56f1ba 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types alien.data assocs colors combinators.smart continuations fry init kernel locals macros math namespaces opengl.gl sequences sequences.generalizations -specialized-arrays ; +specialized-arrays words ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: uint @@ -53,7 +53,7 @@ TUPLE: gl-error-tuple function code string ; over glEnableClientState dip glDisableClientState ; inline : words>values ( word/value-seq -- value-seq ) - [ ?execute ] map ; + [ dup word? [ execute( -- x ) ] when ] map ; : (all-enabled) ( seq quot -- ) [ dup [ glEnable ] each ] dip diff --git a/basis/opengl/shaders/shaders-docs.factor b/basis/opengl/shaders/shaders-docs.factor index c3e4d045ef..ac938f3a48 100644 --- a/basis/opengl/shaders/shaders-docs.factor +++ b/basis/opengl/shaders/shaders-docs.factor @@ -40,7 +40,7 @@ HELP: { $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER " } "." } ; HELP: gl-shader-ok? -{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } } +{ $values { "shader" "A " { $link gl-shader } " object" } { "?" boolean } } { $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ; HELP: check-gl-shader @@ -79,7 +79,7 @@ HELP: { } related-words HELP: gl-program-ok? -{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } } +{ $values { "program" "A " { $link gl-program } " object" } { "?" boolean } } { $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ; HELP: check-gl-program diff --git a/basis/openssl/libcrypto/libcrypto-tests.factor b/basis/openssl/libcrypto/libcrypto-tests.factor new file mode 100644 index 0000000000..92b8dcc39f --- /dev/null +++ b/basis/openssl/libcrypto/libcrypto-tests.factor @@ -0,0 +1,27 @@ +USING: + byte-arrays + kernel + openssl.libcrypto + sequences + splitting + strings + tools.test ; +IN: openssl.libcrypto.tests + +[ t ] [ "factorcode.org:80" BIO_new_connect bio_st? ] unit-test + +[ 1 1 ] [ + "factorcode.org:80" BIO_new_connect [ + BIO_C_DO_STATE_MACHINE 0 f BIO_ctrl + ] keep BIO_free +] unit-test + +[ "HTTP/1.1 200 Document follows" 1 ] [ + "factorcode.org:80" BIO_new_connect [ + [ BIO_C_DO_STATE_MACHINE 0 f BIO_ctrl drop ] + [ + [ "GET / HTTP/1.1\r\nHost: factorcode.org\r\n\r\n" BIO_puts drop ] + [ 1024 dup swapd 1023 BIO_read drop ] bi + ] bi >string "\r\n" split first + ] keep BIO_free +] unit-test diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index 2a6d40035d..b1f796c959 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/basis/openssl/libcrypto/libcrypto.factor @@ -30,46 +30,77 @@ STRUCT: bio-method { destroy void* } { callback-ctrl void* } ; -STRUCT: bio - { method void* } - { callback void* } - { cb-arg void* } - { init int } - { shutdown int } - { flags int } - { retry-reason int } - { num int } - { ptr void* } - { next-bio void* } - { prev-bio void* } - { references int } - { num-read ulong } - { num-write ulong } - { crypto-ex-data-stack void* } - { crypto-ex-data-dummy int } ; - CONSTANT: BIO_NOCLOSE 0x00 CONSTANT: BIO_CLOSE 0x01 CONSTANT: RSA_3 0x3 CONSTANT: RSA_F4 0x10001 -CONSTANT: BIO_C_SET_SSL 109 -CONSTANT: BIO_C_GET_SSL 110 +CONSTANT: BIO_C_SET_CONNECT 100 +CONSTANT: BIO_C_DO_STATE_MACHINE 101 +CONSTANT: BIO_C_SET_NBIO 102 +CONSTANT: BIO_C_SET_PROXY_PARAM 103 +CONSTANT: BIO_C_SET_FD 104 +CONSTANT: BIO_C_GET_FD 105 +CONSTANT: BIO_C_SET_FILE_PTR 106 +CONSTANT: BIO_C_GET_FILE_PTR 107 +CONSTANT: BIO_C_SET_FILENAME 108 +CONSTANT: BIO_C_SET_SSL 109 +CONSTANT: BIO_C_GET_SSL 110 LIBRARY: libcrypto +! =============================================== +! crypto.h +! =============================================== +STRUCT: crypto_ex_data_st + { sk void* } + { dummy int } ; +TYPEDEF: crypto_ex_data_st CRYPTO_EX_DATA + ! =============================================== ! bio.h ! =============================================== +STRUCT: bio_method_st + { type int } + { name c-string } + { bwrite void* } + { bread void* } + { bputs void* } + { bgets void* } + { ctrl void* } + { create void* } + { destroy void* } + { callback_ctrl void* } ; +TYPEDEF: bio_method_st BIO_METHOD -FUNCTION: bio* BIO_new_file ( c-string filename, c-string mode ) ; +STRUCT: bio_st + { method BIO_METHOD* } + { callback void* } + { cb_arg c-string } + { init int } + { shutdown int } + { flags int } + { retry-reason int } + { num int } + { ptr void* } + { next-bio bio_st* } + { prev-bio bio_st* } + { references int } + { num-read ulong } + { num-write ulong } + { ex-data CRYPTO_EX_DATA } ; +TYPEDEF: bio_st BIO -FUNCTION: int BIO_printf ( bio* bio, c-string format ) ; +FUNCTION: BIO* BIO_new_file ( c-string filename, c-string mode ) ; + +FUNCTION: int BIO_printf ( BIO* bio, c-string format ) ; FUNCTION: long BIO_ctrl ( void* bio, int cmd, long larg, void* parg ) ; -FUNCTION: void* BIO_new_socket ( int fd, int close-flag ) ; +FUNCTION: BIO* BIO_new_socket ( int fd, int close-flag ) ; + +FUNCTION: BIO* BIO_new_connect ( c-string name ) ; FUNCTION: void* BIO_new ( void* method ) ; @@ -79,13 +110,13 @@ FUNCTION: int BIO_free ( void* bio ) ; FUNCTION: void* BIO_push ( void* bio, void* append ) ; -FUNCTION: int BIO_read ( void* b, void* buf, int len ) ; +FUNCTION: int BIO_read ( BIO* bio, void* buf, int len ) ; FUNCTION: int BIO_gets ( void* b, c-string buf, int size ) ; FUNCTION: int BIO_write ( void* b, void* buf, int len ) ; -FUNCTION: int BIO_puts ( void* bp, c-string buf ) ; +FUNCTION: int BIO_puts ( BIO* bio, c-string buf ) ; FUNCTION: ulong ERR_get_error ( ) ; @@ -128,7 +159,7 @@ FUNCTION: EVP_MD_CTX* EVP_MD_CTX_create ( ) ; FUNCTION: void EVP_MD_CTX_destroy ( EVP_MD_CTX* ctx ) ; -FUNCTION: int EVP_MD_CTX_copy_ex ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ; +FUNCTION: int EVP_MD_CTX_copy_ex ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ; FUNCTION: int EVP_DigestInit_ex ( EVP_MD_CTX* ctx, EVP_MD* type, ENGINE* impl ) ; @@ -138,7 +169,7 @@ FUNCTION: int EVP_DigestFinal_ex ( EVP_MD_CTX* ctx, void* md, uint* s ) ; FUNCTION: int EVP_Digest ( void* data, uint count, void* md, uint* size, EVP_MD* type, ENGINE* impl ) ; -FUNCTION: int EVP_MD_CTX_copy ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ; +FUNCTION: int EVP_MD_CTX_copy ( EVP_MD_CTX* out, EVP_MD_CTX* in ) ; FUNCTION: int EVP_DigestInit ( EVP_MD_CTX* ctx, EVP_MD* type ) ; diff --git a/basis/openssl/libssl/libssl-tests.factor b/basis/openssl/libssl/libssl-tests.factor new file mode 100644 index 0000000000..70650799a4 --- /dev/null +++ b/basis/openssl/libssl/libssl-tests.factor @@ -0,0 +1,47 @@ +USING: + arrays + kernel + math + openssl.libssl + sequences + tools.test ; +IN: openssl.libssl.tests + +: all-opts ( -- opts ) + { + SSL_OP_NO_SSLv2 + SSL_OP_NO_SSLv3 + SSL_OP_NO_TLSv1 + SSL_OP_NO_TLSv1_1 + SSL_OP_NO_TLSv1_2 + } [ execute( -- x ) ] map ; + +: set-opt ( ctx op -- ) + SSL_CTRL_OPTIONS swap f SSL_CTX_ctrl drop ; + +: has-opt ( ctx op -- ? ) + swap SSL_CTRL_OPTIONS 0 f SSL_CTX_ctrl bitand 0 > ; + +: new-ctx ( -- ctx ) + SSLv23_client_method SSL_CTX_new ; + +: new-ssl ( -- ssl ) + new-ctx SSL_new ; + +! Test default options +[ { f f f f f } ] [ new-ctx all-opts [ has-opt ] with map ] unit-test + +! Test setting options +[ 5 ] [ + new-ctx all-opts [ [ set-opt ] [ has-opt ] 2bi ] with map [ t = ] count +] unit-test + +! Initial state +[ { "before/connect initialization" "read header" 1 f } ] [ + new-ssl { + SSL_state_string_long + SSL_rstate_string_long + SSL_want + SSL_get_peer_certificate + } [ execute( x -- x ) ] with map +] unit-test diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index efef9f3bc5..f1c0d2459a 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -1,17 +1,17 @@ ! Copyright (C) 2007 Elie CHAFTARI ! Portions copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax combinators kernel -system namespaces assocs parser lexer sequences words +USING: alien alien.c-types alien.parser alien.syntax classes.struct combinators +kernel openssl.libcrypto system namespaces assocs parser lexer sequences words quotations math.bitwise alien.libraries literals ; IN: openssl.libssl -<< { - { [ os windows? ] [ "libssl" "ssleay32.dll" cdecl add-library ] } - { [ os macosx? ] [ "libssl" "libssl.dylib" cdecl add-library ] } - { [ os unix? ] [ "libssl" "libssl.so" cdecl add-library ] } -} cond >> +<< "libssl" { + { [ os windows? ] [ "ssleay32.dll" ] } + { [ os macosx? ] [ "libssl.dylib" ] } + { [ os unix? ] [ "libssl.so" ] } +} cond cdecl add-library >> CONSTANT: X509_FILETYPE_PEM 1 CONSTANT: X509_FILETYPE_ASN1 2 @@ -26,10 +26,10 @@ CONSTANT: SSL_CTRL_SET_TMP_DH 3 CONSTANT: SSL_CTRL_SET_TMP_RSA_CB 4 CONSTANT: SSL_CTRL_SET_TMP_DH_CB 5 -CONSTANT: SSL_CTRL_GET_SESSION_REUSED 6 -CONSTANT: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7 -CONSTANT: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8 -CONSTANT: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9 +CONSTANT: SSL_CTRL_GET_SESSION_REUSED 6 +CONSTANT: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7 +CONSTANT: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8 +CONSTANT: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9 CONSTANT: SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 10 CONSTANT: SSL_CTRL_GET_FLAGS 11 CONSTANT: SSL_CTRL_EXTRA_CHAIN_CERT 12 @@ -62,6 +62,12 @@ CONSTANT: SSL_CTRL_GET_SESS_CACHE_MODE 45 CONSTANT: SSL_CTRL_GET_MAX_CERT_LIST 50 CONSTANT: SSL_CTRL_SET_MAX_CERT_LIST 51 +CONSTANT: SSL_OP_NO_SSLv2 0x01000000 +CONSTANT: SSL_OP_NO_SSLv3 0x02000000 +CONSTANT: SSL_OP_NO_TLSv1 0x04000000 +CONSTANT: SSL_OP_NO_TLSv1_2 0x08000000 +CONSTANT: SSL_OP_NO_TLSv1_1 0x10000000 + CONSTANT: SSL_ERROR_NONE 0 CONSTANT: SSL_ERROR_SSL 1 CONSTANT: SSL_ERROR_WANT_READ 2 @@ -86,31 +92,191 @@ CONSTANT: SSL_ERROR_WANT_ACCEPT 8 { 8 "SSL_ERROR_WANT_ACCEPT" } } ; -TYPEDEF: void* ssl-method C-TYPE: SSL_CTX C-TYPE: SSL_SESSION -C-TYPE: SSL LIBRARY: libssl +! =============================================== +! stack.h +! =============================================== + +STRUCT: stack_st + { num int } + { data char** } + { sorted int } + { num_alloc int } + { comp void* } ; +TYPEDEF: stack_st _STACK + +! =============================================== +! asn1t.h +! =============================================== + +C-TYPE: ASN1_ITEM + +! =============================================== +! asn1.h +! =============================================== +C-TYPE: ASN1_VALUE +TYPEDEF: ASN1_ITEM ASN1_ITEM_EXP + +STRUCT: ASN1_STRING + { length int } + { type int } + { data uchar* } + { flags long } ; + +FUNCTION: int ASN1_STRING_cmp ( ASN1_STRING *a, ASN1_STRING *b ) ; + +FUNCTION: ASN1_VALUE* ASN1_item_d2i ( ASN1_VALUE** val, uchar **in, long len, ASN1_ITEM *it ) ; + +! =============================================== +! ossl_typ.h +! =============================================== +TYPEDEF: ASN1_STRING ASN1_OCTET_STRING + ! =============================================== ! x509.h ! =============================================== +STRUCT: X509_EXTENSION + { object void* } + { critical void* } + { value ASN1_OCTET_STRING* } ; + C-TYPE: X509_NAME C-TYPE: X509 -FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ; -FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ; +! =============================================== +! x509v3.h +! =============================================== +STRUCT: X509V3_EXT_METHOD + { ext_nid int } + { ext_flags int } + { it void* } ; + +FUNCTION: X509V3_EXT_METHOD* X509V3_EXT_get ( X509_EXTENSION* ext ) ; + +UNION-STRUCT: GENERAL_NAME_st_d + { ptr char* } + { otherName void* } + { rfc822Name void* } + { dNSName ASN1_STRING* } ; + +STRUCT: GENERAL_NAME_st + { type int } + { d GENERAL_NAME_st_d } ; + +CONSTANT: GEN_OTHERNAME 0 +CONSTANT: GEN_EMAIL 1 +CONSTANT: GEN_DNS 2 +CONSTANT: GEN_X400 3 +CONSTANT: GEN_DIRNAME 4 +CONSTANT: GEN_EDIPARTY 5 +CONSTANT: GEN_URI 6 +CONSTANT: GEN_IPADD 7 +CONSTANT: GEN_RID 8 ! =============================================== ! ssl.h ! =============================================== +STRUCT: ssl_method_st + { version int } + { ssl_new void* } + { ssl_clear void* } + { ssl_free void* } + { ssl_accept void* } + { ssl_connect void* } + { ssl_read void* } + { ssl_peek void* } + { ssl_write void* } + { ssl_shutdown void* } + { ssl_renegotiate void* } + { ssl_renegotiate_check void* } + { ssl_get_message void* } + { ssl_read_bytes void* } + { ssl_write_bytes void* } + { ssl_dispatch_alert void* } + { ssl_ctrl void* } + { ssl_ctx_ctrl void* } + { get_cipher_by_char void* } + { put_cipher_by_char void* } + { ssl_pending void* } + { num_ciphers void* } + { get_cipher void* } + { get_ssl_method void* } + { get_timeout void* } + { ssl3_enc void* } + { ssl_version void* } + { ssl_callback_ctrl void* } + { ssl_ctx_callback_ctrl void* } ; +TYPEDEF: ssl_method_st* ssl-method + +STRUCT: ssl_st + { version int } + { type int } + { method ssl_method_st* } + { rbio BIO* } + { wbio BIO* } + { bbio BIO* } + { rwstate int } + { in_handshake int } + { handshake_func void* } + { server int } + { new_session int } + { quiet_shutdown int } + { shutdown int } + { state int } + { rstate int } + { init_buf void* } + { init_msg void* } + { init_num int } + { init_off int } + { packet void* } + { packet_length int } + { s2 void* } + { s3 void* } + { d1 void* } + { read_ahead int } + { msg_callback void* } + { msg_callback_arg void* } + { hit int } + { param void* } + { cipher_list void* } + { cipher_list_by_id void* } + { mac_flags int } + { enc_read_ctx void* } + { read_hash void* } + { expand void* } + { enc_write_ctx void* } + { write_hash void* } + { compress void* } + { cert void* } + { sid_ctx_length uint } + { sid_ctx void* } + { session SSL_SESSION* } + { generate_session_id void* } + { verify_mode int } + { verify_callback void* } + { info_callback void* } + { error int } + { error_code int } + { kssl_ctx void* } + { psk_client_callback void* } + { psk_server_callback void* } + { ctx SSL_CTX* } ; +TYPEDEF: ssl_st SSL + FUNCTION: c-string SSL_get_version ( SSL* ssl ) ; ! Maps OpenSSL errors to strings FUNCTION: void SSL_load_error_strings ( ) ; +FUNCTION: c-string SSL_state_string ( SSL* ssl ) ; +FUNCTION: c-string SSL_rstate_string ( SSL* ssl ) ; +FUNCTION: c-string SSL_state_string_long ( SSL* ssl ) ; +FUNCTION: c-string SSL_rstate_string_long ( SSL* ssl ) ; ! Must be called before any other action takes place FUNCTION: int SSL_library_init ( ) ; @@ -150,6 +316,8 @@ FUNCTION: int SSL_set_fd ( SSL* ssl, int fd ) ; FUNCTION: void SSL_set_bio ( SSL* ssl, void* rbio, void* wbio ) ; FUNCTION: int SSL_set_session ( SSL* to, SSL_SESSION* session ) ; +FUNCTION: SSL_SESSION* SSL_get_session ( SSL* to ) ; +FUNCTION: SSL_SESSION* SSL_get1_session ( SSL* ssl ) ; FUNCTION: int SSL_get_error ( SSL* ssl, int ret ) ; @@ -174,8 +342,6 @@ FUNCTION: int SSL_get_shutdown ( SSL* ssl ) ; FUNCTION: int SSL_CTX_set_session_id_context ( SSL_CTX* ctx, c-string sid_ctx, uint len ) ; -FUNCTION: SSL_SESSION* SSL_get1_session ( SSL* ssl ) ; - FUNCTION: void SSL_free ( SSL* ssl ) ; FUNCTION: void SSL_SESSION_free ( SSL_SESSION* ses ) ; @@ -332,4 +498,29 @@ X509_V_: ERR_APPLICATION_VERIFICATION 50 ! obj_mac.h ! =============================================== -CONSTANT: NID_commonName 13 +CONSTANT: NID_commonName 13 +CONSTANT: NID_subject_alt_name 85 +CONSTANT: NID_issuer_alt_name 86 + +! =============================================== +! On Windows, some of the functions making up libssl are placed in the +! libeay32.dll and not in the similarily named ssleay32.dll file. +! =============================================== + +<< os windows? [ + "libssl-windows" + [ "libeay32.dll" cdecl add-library ] [ current-library set ] bi +] when >> + +! x509.h +FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ; +FUNCTION: int X509_get_ext_by_NID ( X509* a, int nid, int lastpos ) ; +FUNCTION: void* X509_get_ext_d2i ( X509 *a, int nid, int* crit, int* idx ) ; +FUNCTION: X509_NAME* X509_get_issuer_name ( X509* a ) ; +FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ; +FUNCTION: int X509_check_trust ( X509* a, int id, int flags ) ; +FUNCTION: X509_EXTENSION* X509_get_ext ( X509* a, int loc ) ; + +! stack.h +FUNCTION: int sk_num ( _STACK *s ) ; +FUNCTION: void* sk_value ( _STACK *s, int ) ; diff --git a/basis/pack/pack-tests.factor b/basis/pack/pack-tests.factor index 440d6a0369..5c8f8e3371 100644 --- a/basis/pack/pack-tests.factor +++ b/basis/pack/pack-tests.factor @@ -36,6 +36,9 @@ IN: pack.tests "cstiq" [ pack-native ] keep unpack-native ] unit-test +{ B{ 1 2 3 4 5 0 0 0 } } [ { 1 2 3 4 5 } "4ci" pack-le ] unit-test +{ { 1 2 3 4 5 } } [ B{ 1 2 3 4 5 0 0 0 } "4ci" unpack-le ] unit-test + [ 9 ] [ "iic" packed-length ] unit-test [ "iii" read-packed-le ] must-infer [ "iii" read-packed-be ] must-infer @@ -50,3 +53,8 @@ IN: pack.tests "iii" pack ; [ test-pack ] must-infer + +{ "c" } [ "1c" expand-pack-format ] unit-test +{ "cccc" } [ "4c" expand-pack-format ] unit-test +{ "cccccccccccc" } [ "12c" expand-pack-format ] unit-test +{ "iccqqq" } [ "1i2c3q" expand-pack-format ] unit-test diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index a330337c5e..5f15373790 100644 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -1,11 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays assocs byte-arrays io -io.binary io.streams.string kernel math math.parser namespaces -make parser quotations sequences strings vectors -words macros math.functions math.bitwise fry generalizations -combinators.smart io.streams.byte-array io.encodings.binary -math.vectors combinators multiline endian ; +USING: alien.c-types ascii assocs combinators combinators.smart +endian fry io kernel macros math math.vectors sequences strings ; IN: pack GENERIC: >n-byte-array ( obj n -- byte-array ) @@ -33,6 +29,13 @@ M: string >n-byte-array ( n string -- byte-array ) heap-size >n-byte-array ; ] bi* f swap ] if + ] { } map-as "" concat-as nip ; foldable + CONSTANT: pack-table H{ { CHAR: c s8>byte-array } @@ -90,6 +93,7 @@ CONSTANT: packed-length-table PRIVATE> MACRO: pack ( str -- quot ) + expand-pack-format [ pack-table at '[ _ execute ] ] { } map-as '[ [ [ _ spread ] input MACRO: unpack ( str -- quot ) + expand-pack-format [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map diff --git a/basis/pango/cairo/ffi/ffi.factor b/basis/pango/cairo/ffi/ffi.factor index d9038090d1..6537d86c3a 100644 --- a/basis/pango/cairo/ffi/ffi.factor +++ b/basis/pango/cairo/ffi/ffi.factor @@ -14,7 +14,7 @@ LIBRARY: pango.cairo "pango.cairo" { { [ os windows? ] [ "libpangocairo-1.0-0.dll" cdecl add-library ] } { [ os macosx? ] [ drop ] } - { [ os unix? ] [ drop ] } + { [ os unix? ] [ "libpangocairo-1.0.so" cdecl add-library ] } } cond >> diff --git a/basis/pango/ffi/ffi.factor b/basis/pango/ffi/ffi.factor index 5c7d99dc5e..21ccfa41d2 100644 --- a/basis/pango/ffi/ffi.factor +++ b/basis/pango/ffi/ffi.factor @@ -14,8 +14,9 @@ LIBRARY: pango << "pango" { { [ os windows? ] [ "libpango-1.0-0.dll" cdecl add-library ] } - { [ os unix? ] [ drop ] } -} cond + { [ os macosx? ] [ drop ] } + { [ os unix? ] [ "libpango-1.0.so" cdecl add-library ] } +} cond >> IMPLEMENT-STRUCTS: PangoRectangle ; diff --git a/basis/peg/debugger/debugger-tests.factor b/basis/peg/debugger/debugger-tests.factor new file mode 100644 index 0000000000..7968abfad1 --- /dev/null +++ b/basis/peg/debugger/debugger-tests.factor @@ -0,0 +1,7 @@ +USING: arrays continuations debugger io.streams.string peg tools.test ; +IN: peg.debugger.tests + +{ "Peg parsing error at character position 0.\nExpected 'A' or 'B'\nGot 'xxxx'\n" } [ + [ "xxxx" "A" token "B" token 2array choice parse ] [ ] recover + [ error. ] with-string-writer +] unit-test diff --git a/basis/peg/debugger/debugger.factor b/basis/peg/debugger/debugger.factor index 7e751b5110..4cb10ea2ea 100644 --- a/basis/peg/debugger/debugger.factor +++ b/basis/peg/debugger/debugger.factor @@ -1,12 +1,18 @@ -USING: io kernel accessors math.parser sequences prettyprint -debugger peg ; +USING: accessors debugger io kernel math.parser peg prettyprint +sequences ; IN: peg.debugger + M: parse-error error. - "Peg parsing error at character position " write dup position>> number>string write - "." print "Expected " write messages>> [ " or " write ] [ write ] interleave nl ; + [ + "Peg parsing error at character position " write + position>> number>string write + ] [ + ".\nExpected " write messages>> " or " join write + ] [ + "\nGot '" write got>> write "'" print + ] tri ; M: parse-failed error. - "The " write dup word>> pprint " word could not parse the following input:" print nl - input>> . ; - + "The " write dup word>> pprint " word could not parse the following input:" print nl + input>> . ; diff --git a/basis/peg/ebnf/ebnf-docs.factor b/basis/peg/ebnf/ebnf-docs.factor index 31d4961b98..39b48e99ab 100644 --- a/basis/peg/ebnf/ebnf-docs.factor +++ b/basis/peg/ebnf/ebnf-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup peg peg.search ; +USING: help.syntax help.markup peg peg.search words ; IN: peg.ebnf HELP: > ] [ remaining>> ] bi - >string + "beginend" "begin" token (parse) + [ ast>> ] [ remaining>> ] bi + >string ] unit-test [ - "" CHAR: a CHAR: z range parse + "" CHAR: a CHAR: z range parse ] must-fail [ - "1bcd" CHAR: a CHAR: z range parse + "1bcd" CHAR: a CHAR: z range parse ] must-fail { CHAR: a } [ - "abcd" CHAR: a CHAR: z range parse + "abcd" CHAR: a CHAR: z range parse ] unit-test { CHAR: z } [ - "zbcd" CHAR: a CHAR: z range parse + "zbcd" CHAR: a CHAR: z range parse ] unit-test [ - "bad" "a" token "b" token 2array seq parse + "bad" "a" token "b" token 2array seq parse ] must-fail { V{ "g" "o" } } [ - "good" "g" token "o" token 2array seq parse + "good" "g" token "o" token 2array seq parse ] unit-test { "a" } [ - "abcd" "a" token "b" token 2array choice parse + "abcd" "a" token "b" token 2array choice parse ] unit-test { "b" } [ - "bbcd" "a" token "b" token 2array choice parse + "bbcd" "a" token "b" token 2array choice parse ] unit-test [ - "cbcd" "a" token "b" token 2array choice parse + "cbcd" "a" token "b" token 2array choice parse ] must-fail [ - "" "a" token "b" token 2array choice parse + "" "a" token "b" token 2array choice parse ] must-fail { 0 } [ - "" "a" token repeat0 parse length + "" "a" token repeat0 parse length ] unit-test { 0 } [ - "b" "a" token repeat0 parse length + "b" "a" token repeat0 parse length ] unit-test { V{ "a" "a" "a" } } [ - "aaab" "a" token repeat0 parse + "aaab" "a" token repeat0 parse ] unit-test [ - "" "a" token repeat1 parse + "" "a" token repeat1 parse ] must-fail [ - "b" "a" token repeat1 parse + "b" "a" token repeat1 parse ] must-fail { V{ "a" "a" "a" } } [ - "aaab" "a" token repeat1 parse + "aaab" "a" token repeat1 parse ] unit-test -{ V{ "a" "b" } } [ - "ab" "a" token optional "b" token 2array seq parse +{ V{ "a" "b" } } [ + "ab" "a" token optional "b" token 2array seq parse ] unit-test -{ V{ f "b" } } [ - "b" "a" token optional "b" token 2array seq parse +{ V{ f "b" } } [ + "b" "a" token optional "b" token 2array seq parse ] unit-test -[ - "cb" "a" token optional "b" token 2array seq parse +[ + "cb" "a" token optional "b" token 2array seq parse ] must-fail { V{ CHAR: a CHAR: b } } [ - "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse + "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse ] unit-test [ - "bb" "a" token ensure CHAR: a CHAR: z range 2array seq parse + "bb" "a" token ensure CHAR: a CHAR: z range 2array seq parse ] must-fail { t } [ - "a+b" - "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq - parse [ t ] [ f ] if + "a+b" + "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq + parse [ t ] [ f ] if ] unit-test { t } [ - "a++b" - "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq - parse [ t ] [ f ] if + "a++b" + "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq + parse [ t ] [ f ] if ] unit-test { t } [ - "a+b" - "a" token "+" token "++" token 2array choice "b" token 3array seq - parse [ t ] [ f ] if + "a+b" + "a" token "+" token "++" token 2array choice "b" token 3array seq + parse [ t ] [ f ] if ] unit-test [ - "a++b" - "a" token "+" token "++" token 2array choice "b" token 3array seq - parse [ t ] [ f ] if + "a++b" + "a" token "+" token "++" token 2array choice "b" token 3array seq + parse [ t ] [ f ] if ] must-fail { 1 } [ - "a" "a" token [ drop 1 ] action parse + "a" "a" token [ drop 1 ] action parse ] unit-test { V{ 1 1 } } [ - "aa" "a" token [ drop 1 ] action dup 2array seq parse + "aa" "a" token [ drop 1 ] action dup 2array seq parse ] unit-test [ - "b" "a" token [ drop 1 ] action parse + "b" "a" token [ drop 1 ] action parse ] must-fail -[ - "b" [ CHAR: a = ] satisfy parse +[ + "b" [ CHAR: a = ] satisfy parse ] must-fail -{ CHAR: a } [ - "a" [ CHAR: a = ] satisfy parse +{ CHAR: a } [ + "a" [ CHAR: a = ] satisfy parse ] unit-test { "a" } [ - " a" "a" token sp parse + " a" "a" token sp parse ] unit-test { "a" } [ - "a" "a" token sp parse + "a" "a" token sp parse ] unit-test { V{ "a" } } [ - "[a]" "[" token hide "a" token "]" token hide 3array seq parse + "[a]" "[" token hide "a" token "]" token hide 3array seq parse ] unit-test [ - "a]" "[" token hide "a" token "]" token hide 3array seq parse + "a]" "[" token hide "a" token "]" token hide 3array seq parse ] must-fail { V{ "1" "-" "1" } V{ "1" "+" "1" } } [ - [ - [ "1" token , "-" token , "1" token , ] seq* , - [ "1" token , "+" token , "1" token , ] seq* , - ] choice* - "1-1" over parse swap - "1+1" swap parse + [ + [ "1" token , "-" token , "1" token , ] seq* , + [ "1" token , "+" token , "1" token , ] seq* , + ] choice* + "1-1" over parse swap + "1+1" swap parse ] unit-test -: expr ( -- parser ) - #! Test direct left recursion. Currently left recursion should cause a - #! failure of that parser. - [ expr ] delay "+" token "1" token 3seq "1" token 2choice ; +: expr ( -- parser ) + #! Test direct left recursion. Currently left recursion should cause a + #! failure of that parser. + [ expr ] delay "+" token "1" token 3seq "1" token 2choice ; { V{ V{ "1" "+" "1" } "+" "1" } } [ - "1+1+1" expr parse + "1+1+1" expr parse ] unit-test { t } [ - #! Ensure a circular parser doesn't loop infinitely - [ f , "a" token , ] seq* - dup peg>> parsers>> - dupd 0 swap set-nth compile word? + #! Ensure a circular parser doesn't loop infinitely + [ f , "a" token , ] seq* + dup peg>> parsers>> + dupd 0 swap set-nth compile word? ] unit-test [ - "A" [ drop t ] satisfy [ 66 >= ] semantic parse + "A" [ drop t ] satisfy [ 66 >= ] semantic parse ] must-fail { CHAR: B } [ - "B" [ drop t ] satisfy [ 66 >= ] semantic parse + "B" [ drop t ] satisfy [ 66 >= ] semantic parse ] unit-test { f } [ \ + T{ parser f f f } equal? ] unit-test @@ -206,3 +206,13 @@ USE: compiler [ ] [ enable-optimizer ] unit-test [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test + +{ + T{ parse-error + { position 0 } + { got "fbcd" } + { messages V{ "'a'" "'b'" } } + } +} [ + [ "fbcd" "a" token "b" token 2array choice parse ] [ ] recover +] unit-test diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 23a929a9ee..caa2ebb6c0 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -9,10 +9,10 @@ FROM: namespaces => set ; IN: peg TUPLE: parse-result remaining ast ; -TUPLE: parse-error position messages ; +TUPLE: parse-error position got messages ; TUPLE: parser peg compiled id ; -M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ; +M: parser equal? { [ [ class-of ] same? ] [ [ id>> ] same? ] } 2&& ; M: parser hashcode* id>> hashcode* ; C: parse-result @@ -20,38 +20,43 @@ C: parse-error SYMBOL: error-stack +: merge-overlapping-errors ( a b -- c ) + dupd [ messages>> ] bi@ union [ [ position>> ] [ got>> ] bi ] dip + ; + : (merge-errors) ( a b -- c ) - { - { [ over position>> not ] [ nip ] } - { [ dup position>> not ] [ drop ] } - [ 2dup [ position>> ] compare { - { +lt+ [ nip ] } - { +gt+ [ drop ] } - { +eq+ [ messages>> over messages>> union [ position>> ] dip ] } - } case - ] - } cond ; + { + { [ over position>> not ] [ nip ] } + { [ dup position>> not ] [ drop ] } + [ + 2dup [ position>> ] compare { + { +lt+ [ nip ] } + { +gt+ [ drop ] } + { +eq+ [ merge-overlapping-errors ] } + } case + ] + } cond ; : merge-errors ( -- ) - error-stack get dup length 1 > [ - dup pop over pop swap (merge-errors) swap push - ] [ - drop - ] if ; + error-stack get dup length 1 > [ + dup pop over pop swap (merge-errors) swap push + ] [ + drop + ] if ; -: add-error ( remaining message -- ) - error-stack get push ; - -SYMBOL: ignore +: add-error ( position got message -- ) + error-stack get push ; + +SYMBOL: ignore : packrat ( id -- cache ) - #! The packrat cache is a mapping of parser-id->cache. - #! For each parser it maps to a cache holding a mapping - #! of position->result. The packrat cache therefore keeps - #! track of all parses that have occurred at each position - #! of the input string and the results obtained from that - #! parser. - \ packrat get [ drop H{ } clone ] cache ; + #! The packrat cache is a mapping of parser-id->cache. + #! For each parser it maps to a cache holding a mapping + #! of position->result. The packrat cache therefore keeps + #! track of all parses that have occurred at each position + #! of the input string and the results obtained from that + #! parser. + \ packrat get [ drop H{ } clone ] cache ; SYMBOL: pos SYMBOL: input @@ -59,28 +64,28 @@ SYMBOL: fail SYMBOL: lrstack : heads ( -- cache ) - #! A mapping from position->peg-head. It maps a - #! position in the input string being parsed to - #! the head of the left recursion which is currently - #! being grown. It is 'f' at any position where - #! left recursion growth is not underway. - \ heads get ; + #! A mapping from position->peg-head. It maps a + #! position in the input string being parsed to + #! the head of the left recursion which is currently + #! being grown. It is 'f' at any position where + #! left recursion growth is not underway. + \ heads get ; : failed? ( obj -- ? ) - fail = ; + fail = ; : peg-cache ( -- cache ) - #! Holds a hashtable mapping a peg tuple to - #! the parser tuple for that peg. The parser tuple - #! holds a unique id and the compiled form of that peg. - \ peg-cache get-global [ - H{ } clone dup \ peg-cache set-global - ] unless* ; + #! Holds a hashtable mapping a peg tuple to + #! the parser tuple for that peg. The parser tuple + #! holds a unique id and the compiled form of that peg. + \ peg-cache get-global [ + H{ } clone dup \ peg-cache set-global + ] unless* ; : reset-pegs ( -- ) - H{ } clone \ peg-cache set-global ; + H{ } clone \ peg-cache set-global ; -reset-pegs +reset-pegs #! An entry in the table of memoized parse results #! ast = an AST produced from the parse @@ -89,120 +94,118 @@ reset-pegs #! pos = the position in the input string of this entry TUPLE: memo-entry ans pos ; -TUPLE: left-recursion seed rule-id head next ; +TUPLE: left-recursion seed rule-id head next ; TUPLE: peg-head rule-id involved-set eval-set ; -: rule-id ( word -- id ) - #! A rule is the parser compiled down to a word. It has - #! a "peg-id" property containing the id of the original parser. - "peg-id" word-prop ; +: rule-id ( word -- id ) + #! A rule is the parser compiled down to a word. It has + #! a "peg-id" property containing the id of the original parser. + "peg-id" word-prop ; : input-slice ( -- slice ) - #! Return a slice of the input from the current parse position - input get pos get tail-slice ; + #! Return a slice of the input from the current parse position + input get pos get tail-slice ; : input-from ( input -- n ) - #! Return the index from the original string that the - #! input slice is based on. - dup slice? [ from>> ] [ drop 0 ] if ; + #! Return the index from the original string that the + #! input slice is based on. + dup slice? [ from>> ] [ drop 0 ] if ; : process-rule-result ( p result -- result ) - [ - nip [ ast>> ] [ remaining>> ] bi input-from pos set - ] [ - pos set fail - ] if* ; + [ + nip [ ast>> ] [ remaining>> ] bi input-from pos set + ] [ + pos set fail + ] if* ; : eval-rule ( rule -- ast ) - #! Evaluate a rule, return an ast resulting from it. - #! Return fail if the rule failed. The rule has - #! stack effect ( -- parse-result ) - pos get swap execute( -- parse-result ) process-rule-result ; inline + #! Evaluate a rule, return an ast resulting from it. + #! Return fail if the rule failed. The rule has + #! stack effect ( -- parse-result ) + pos get swap execute( -- parse-result ) process-rule-result ; inline : memo ( pos id -- memo-entry ) - #! Return the result from the memo cache. - packrat at -! " memo result " write dup . - ; + #! Return the result from the memo cache. + packrat at ; : set-memo ( memo-entry pos id -- ) - #! Store an entry in the cache - packrat set-at ; + #! Store an entry in the cache + packrat set-at ; : update-m ( ast m -- ) - swap >>ans pos get >>pos drop ; + swap >>ans pos get >>pos drop ; : stop-growth? ( ast m -- ? ) - [ failed? pos get ] dip - pos>> <= or ; + [ failed? pos get ] dip + pos>> <= or ; : setup-growth ( h p -- ) - pos set dup involved-set>> clone >>eval-set drop ; + pos set dup involved-set>> clone >>eval-set drop ; : (grow-lr) ( h p r: ( -- result ) m -- ) - [ [ setup-growth ] 2keep ] 2dip - [ dup eval-rule ] dip swap - dup pick stop-growth? [ - 5 ndrop - ] [ - over update-m - (grow-lr) - ] if ; inline recursive - + [ [ setup-growth ] 2keep ] 2dip + [ dup eval-rule ] dip swap + dup pick stop-growth? [ + 5 ndrop + ] [ + over update-m + (grow-lr) + ] if ; inline recursive + : grow-lr ( h p r m -- ast ) - [ [ heads set-at ] 2keep ] 2dip - pick over [ (grow-lr) ] 2dip - swap heads delete-at - dup pos>> pos set ans>> - ; inline + [ [ heads set-at ] 2keep ] 2dip + pick over [ (grow-lr) ] 2dip + swap heads delete-at + dup pos>> pos set ans>> + ; inline :: (setup-lr) ( l s -- ) - s [ - s left-recursion? [ s throw ] unless - s head>> l head>> eq? [ - l head>> s head<< - l head>> [ s rule-id>> suffix ] change-involved-set drop - l s next>> (setup-lr) - ] unless - ] when ; + s [ + s left-recursion? [ s throw ] unless + s head>> l head>> eq? [ + l head>> s head<< + l head>> [ s rule-id>> suffix ] change-involved-set drop + l s next>> (setup-lr) + ] unless + ] when ; :: setup-lr ( r l -- ) - l head>> [ - r rule-id V{ } clone V{ } clone peg-head boa l head<< - ] unless - l lrstack get (setup-lr) ; + l head>> [ + r rule-id V{ } clone V{ } clone peg-head boa l head<< + ] unless + l lrstack get (setup-lr) ; :: lr-answer ( r p m -- ast ) m ans>> head>> :> h h rule-id>> r rule-id eq? [ - m ans>> seed>> m ans<< - m ans>> failed? [ - fail - ] [ - h p r m grow-lr - ] if + m ans>> seed>> m ans<< + m ans>> failed? [ + fail + ] [ + h p r m grow-lr + ] if ] [ - m ans>> seed>> + m ans>> seed>> ] if ; inline :: recall ( r p -- memo-entry ) p r rule-id memo :> m p heads at :> h h [ - m r rule-id h involved-set>> h rule-id>> suffix member? not and [ - fail p memo-entry boa - ] [ - r rule-id h eval-set>> member? [ - h [ r rule-id swap remove ] change-eval-set drop - r eval-rule - m update-m - m - ] [ - m + m r rule-id h involved-set>> h rule-id>> suffix member? not and [ + fail p memo-entry boa + ] [ + r rule-id h eval-set>> member? [ + h [ r rule-id swap remove ] change-eval-set drop + r eval-rule + m update-m + m + ] [ + m + ] if ] if - ] if ] [ - m + m ] if ; inline :: apply-non-memo-rule ( r p -- ast ) @@ -212,32 +215,29 @@ TUPLE: peg-head rule-id involved-set eval-set ; lrstack get next>> lrstack set pos get m pos<< lr head>> [ - m ans>> left-recursion? [ - ans lr seed<< - r p m lr-answer - ] [ ans ] if + m ans>> left-recursion? [ + ans lr seed<< + r p m lr-answer + ] [ ans ] if ] [ - ans m ans<< - ans + ans m ans<< + ans ] if ; inline : apply-memo-rule ( r m -- ast ) - [ ans>> ] [ pos>> ] bi pos set - dup left-recursion? [ - [ setup-lr ] keep seed>> - ] [ - nip - ] if ; + [ ans>> ] [ pos>> ] bi pos set + dup left-recursion? [ + [ setup-lr ] keep seed>> + ] [ + nip + ] if ; : apply-rule ( r p -- ast ) -! 2dup [ rule-id ] dip 2array "apply-rule: " write . - 2dup recall [ -! " memoed" print - nip apply-memo-rule - ] [ -! " not memoed" print - apply-non-memo-rule - ] if* ; inline + 2dup recall [ + nip apply-memo-rule + ] [ + apply-non-memo-rule + ] if* ; inline : with-packrat ( input quot -- result ) #! Run the quotation with a packrat cache active. @@ -253,361 +253,361 @@ TUPLE: peg-head rule-id involved-set eval-set ; GENERIC: (compile) ( peg -- quot ) : process-parser-result ( result -- result ) - dup failed? [ - drop f - ] [ - input-slice swap - ] if ; - + dup failed? [ + drop f + ] [ + input-slice swap + ] if ; + : execute-parser ( word -- result ) - pos get apply-rule process-parser-result ; + pos get apply-rule process-parser-result ; : preset-parser-word ( parser -- parser word ) - gensym [ >>compiled ] keep ; + gensym [ >>compiled ] keep ; : define-parser-word ( parser word -- ) - #! Return the body of the word that is the compiled version - #! of the parser. - 2dup swap peg>> (compile) ( -- result ) define-declared - swap id>> "peg-id" set-word-prop ; + #! Return the body of the word that is the compiled version + #! of the parser. + 2dup swap peg>> (compile) ( -- result ) define-declared + swap id>> "peg-id" set-word-prop ; : compile-parser ( parser -- word ) - #! Look to see if the given parser has been compiled. - #! If not, compile it to a temporary word, cache it, - #! and return it. Otherwise return the existing one. - #! Circular parsers are supported by getting the word - #! name and storing it in the cache, before compiling, - #! so it is picked up when re-entered. - dup compiled>> [ - nip - ] [ - preset-parser-word [ define-parser-word ] keep - ] if* ; + #! Look to see if the given parser has been compiled. + #! If not, compile it to a temporary word, cache it, + #! and return it. Otherwise return the existing one. + #! Circular parsers are supported by getting the word + #! name and storing it in the cache, before compiling, + #! so it is picked up when re-entered. + dup compiled>> [ + nip + ] [ + preset-parser-word [ define-parser-word ] keep + ] if* ; : compile-parser-quot ( parser -- quot ) - compile-parser [ execute-parser ] curry ; + compile-parser [ execute-parser ] curry ; SYMBOL: delayed : fixup-delayed ( -- ) - #! Work through all delayed parsers and recompile their - #! words to have the correct bodies. - delayed get [ - call( -- parser ) compile-parser-quot ( -- result ) define-declared - ] assoc-each ; + #! Work through all delayed parsers and recompile their + #! words to have the correct bodies. + delayed get [ + call( -- parser ) compile-parser-quot ( -- result ) define-declared + ] assoc-each ; : compile ( parser -- word ) - [ - H{ } clone delayed [ - compile-parser-quot ( -- result ) define-temp fixup-delayed - ] with-variable - ] with-compilation-unit ; + [ + H{ } clone delayed [ + compile-parser-quot ( -- result ) define-temp fixup-delayed + ] with-variable + ] with-compilation-unit ; : compiled-parse ( state word -- result ) - swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ; + swap [ execute( -- result ) [ error-stack get first throw ] unless* ] with-packrat ; : (parse) ( input parser -- result ) - dup word? [ compile ] unless compiled-parse ; + dup word? [ compile ] unless compiled-parse ; : parse ( input parser -- ast ) - (parse) ast>> ; + (parse) ast>> ; f f add-error - ] [ - [ drop pos get "token '" ] dip append "'" append 1vector add-error f - ] if ; + #! Parse the string, returning a parse result + [ ?head-slice ] keep swap [ + f f f add-error + ] [ + [ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f + ] if ; M: token-parser (compile) ( peg -- quot ) - symbol>> '[ input-slice _ parse-token ] ; - + symbol>> '[ input-slice _ parse-token ] ; + TUPLE: satisfy-parser quot ; : parse-satisfy ( input quot -- result ) - swap dup empty? [ - 2drop f - ] [ - unclip-slice rot dupd call [ - - ] [ - 2drop f - ] if - ] if ; inline + swap dup empty? [ + 2drop f + ] [ + unclip-slice rot dupd call [ + + ] [ + 2drop f + ] if + ] if ; inline M: satisfy-parser (compile) ( peg -- quot ) - quot>> '[ input-slice _ parse-satisfy ] ; + quot>> '[ input-slice _ parse-satisfy ] ; TUPLE: range-parser min max ; : parse-range ( input min max -- result ) - pick empty? [ - 3drop f - ] [ - [ dup first ] 2dip between? [ - unclip-slice - ] [ - drop f - ] if - ] if ; + pick empty? [ + 3drop f + ] [ + [ dup first ] 2dip between? [ + unclip-slice + ] [ + drop f + ] if + ] if ; M: range-parser (compile) ( peg -- quot ) - [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ; + [ min>> ] [ max>> ] bi '[ input-slice _ _ parse-range ] ; TUPLE: seq-parser parsers ; : ignore? ( ast -- bool ) - ignore = ; + ignore = ; : calc-seq-result ( prev-result current-result -- next-result ) - [ - [ remaining>> swap remaining<< ] 2keep - ast>> dup ignore? [ - drop + [ + [ remaining>> swap remaining<< ] 2keep + ast>> dup ignore? [ + drop + ] [ + swap [ ast>> push ] keep + ] if ] [ - swap [ ast>> push ] keep - ] if - ] [ - drop f - ] if* ; + drop f + ] if* ; : parse-seq-element ( result quot -- result ) - over [ - call calc-seq-result - ] [ - 2drop f - ] if ; inline + over [ + call calc-seq-result + ] [ + 2drop f + ] if ; inline M: seq-parser (compile) ( peg -- quot ) - [ - [ input-slice V{ } clone ] % [ - parsers>> unclip compile-parser-quot [ parse-seq-element ] curry , - [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each - ] { } make , \ 1&& , - ] [ ] make ; + [ input-slice V{ } clone ] % + [ + parsers>> unclip compile-parser-quot [ parse-seq-element ] curry , + [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each + ] { } make , \ 1&& , + ] [ ] make ; TUPLE: choice-parser parsers ; M: choice-parser (compile) ( peg -- quot ) - [ [ - parsers>> [ compile-parser-quot ] map - unclip , [ [ merge-errors ] compose , ] each - ] { } make , \ 0|| , - ] [ ] make ; + [ + parsers>> [ compile-parser-quot ] map + unclip , [ [ merge-errors ] compose , ] each + ] { } make , \ 0|| , + ] [ ] make ; TUPLE: repeat0-parser p1 ; : (repeat) ( quot: ( -- result ) result -- result ) - over call [ - [ remaining>> swap remaining<< ] 2keep - ast>> swap [ ast>> push ] keep - (repeat) - ] [ - nip - ] if* ; inline recursive + over call [ + [ remaining>> swap remaining<< ] 2keep + ast>> swap [ ast>> push ] keep + (repeat) + ] [ + nip + ] if* ; inline recursive M: repeat0-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ - input-slice V{ } clone _ swap (repeat) - ] ; + p1>> compile-parser-quot '[ + input-slice V{ } clone _ swap (repeat) + ] ; TUPLE: repeat1-parser p1 ; : repeat1-empty-check ( result -- result ) - [ - dup ast>> empty? [ drop f ] when - ] [ - f - ] if* ; + [ + dup ast>> empty? [ drop f ] when + ] [ + f + ] if* ; M: repeat1-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ - input-slice V{ } clone _ swap (repeat) repeat1-empty-check - ] ; + p1>> compile-parser-quot '[ + input-slice V{ } clone _ swap (repeat) repeat1-empty-check + ] ; TUPLE: optional-parser p1 ; : check-optional ( result -- result ) - [ input-slice f ] unless* ; + [ input-slice f ] unless* ; M: optional-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ @ check-optional ] ; + p1>> compile-parser-quot '[ @ check-optional ] ; TUPLE: semantic-parser p1 quot ; : check-semantic ( result quot -- result ) - over [ - over ast>> swap call [ drop f ] unless - ] [ - drop - ] if ; inline + over [ + over ast>> swap call [ drop f ] unless + ] [ + drop + ] if ; inline M: semantic-parser (compile) ( peg -- quot ) - [ p1>> compile-parser-quot ] [ quot>> ] bi - '[ @ _ check-semantic ] ; + [ p1>> compile-parser-quot ] [ quot>> ] bi + '[ @ _ check-semantic ] ; TUPLE: ensure-parser p1 ; : check-ensure ( old-input result -- result ) - [ ignore ] [ drop f ] if ; + [ ignore ] [ drop f ] if ; M: ensure-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ input-slice @ check-ensure ] ; + p1>> compile-parser-quot '[ input-slice @ check-ensure ] ; TUPLE: ensure-not-parser p1 ; : check-ensure-not ( old-input result -- result ) - [ drop f ] [ ignore ] if ; + [ drop f ] [ ignore ] if ; M: ensure-not-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ; + p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ; TUPLE: action-parser p1 quot ; : check-action ( result quot -- result ) - over [ - over ast>> swap call( ast -- ast ) >>ast - ] [ - drop - ] if ; + over [ + over ast>> swap call( ast -- ast ) >>ast + ] [ + drop + ] if ; M: action-parser (compile) ( peg -- quot ) - [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ; + [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ; TUPLE: sp-parser p1 ; M: sp-parser (compile) ( peg -- quot ) - p1>> compile-parser-quot '[ - input-slice [ blank? ] trim-head-slice input-from pos set @ - ] ; + p1>> compile-parser-quot '[ + input-slice [ blank? ] trim-head-slice input-from pos set @ + ] ; TUPLE: delay-parser quot ; M: delay-parser (compile) ( peg -- quot ) - #! For efficiency we memoize the quotation. - #! This way it is run only once and the - #! parser constructed once at run time. - quot>> gensym [ delayed get set-at ] keep 1quotation ; + #! For efficiency we memoize the quotation. + #! This way it is run only once and the + #! parser constructed once at run time. + quot>> gensym [ delayed get set-at ] keep 1quotation ; TUPLE: box-parser quot ; M: box-parser (compile) ( peg -- quot ) - #! Calls the quotation at compile time - #! to produce the parser to be compiled. - #! This differs from 'delay' which calls - #! it at run time. - quot>> call( -- parser ) compile-parser-quot ; + #! Calls the quotation at compile time + #! to produce the parser to be compiled. + #! This differs from 'delay' which calls + #! it at run time. + quot>> call( -- parser ) compile-parser-quot ; PRIVATE> : token ( string -- parser ) - token-parser boa wrap-peg ; + token-parser boa wrap-peg ; : satisfy ( quot -- parser ) - satisfy-parser boa wrap-peg ; + satisfy-parser boa wrap-peg ; : range ( min max -- parser ) - range-parser boa wrap-peg ; + range-parser boa wrap-peg ; : seq ( seq -- parser ) - seq-parser boa wrap-peg ; + seq-parser boa wrap-peg ; : 2seq ( parser1 parser2 -- parser ) - 2array seq ; + 2array seq ; : 3seq ( parser1 parser2 parser3 -- parser ) - 3array seq ; + 3array seq ; : 4seq ( parser1 parser2 parser3 parser4 -- parser ) - 4array seq ; + 4array seq ; : seq* ( quot -- paser ) - { } make seq ; inline + { } make seq ; inline : choice ( seq -- parser ) - choice-parser boa wrap-peg ; + choice-parser boa wrap-peg ; : 2choice ( parser1 parser2 -- parser ) - 2array choice ; + 2array choice ; : 3choice ( parser1 parser2 parser3 -- parser ) - 3array choice ; + 3array choice ; : 4choice ( parser1 parser2 parser3 parser4 -- parser ) - 4array choice ; + 4array choice ; : choice* ( quot -- paser ) - { } make choice ; inline + { } make choice ; inline : repeat0 ( parser -- parser ) - repeat0-parser boa wrap-peg ; + repeat0-parser boa wrap-peg ; : repeat1 ( parser -- parser ) - repeat1-parser boa wrap-peg ; + repeat1-parser boa wrap-peg ; : optional ( parser -- parser ) - optional-parser boa wrap-peg ; + optional-parser boa wrap-peg ; : semantic ( parser quot -- parser ) - semantic-parser boa wrap-peg ; + semantic-parser boa wrap-peg ; : ensure ( parser -- parser ) - ensure-parser boa wrap-peg ; + ensure-parser boa wrap-peg ; : ensure-not ( parser -- parser ) - ensure-not-parser boa wrap-peg ; + ensure-not-parser boa wrap-peg ; : action ( parser quot -- parser ) - action-parser boa wrap-peg ; + action-parser boa wrap-peg ; : sp ( parser -- parser ) - sp-parser boa wrap-peg ; + sp-parser boa wrap-peg ; : hide ( parser -- parser ) - [ drop ignore ] action ; + [ drop ignore ] action ; : delay ( quot -- parser ) - delay-parser boa wrap-peg ; + delay-parser boa wrap-peg ; : box ( quot -- parser ) - #! because a box has its quotation run at compile time - #! it must always have a new parser wrapper created, - #! not a cached one. This is because the same box, - #! compiled twice can have a different compiled word - #! due to running at compile time. - #! Why the [ ] action at the end? Box parsers don't get - #! memoized during parsing due to all box parsers being - #! unique. This breaks left recursion detection during the - #! parse. The action adds an indirection with a parser type - #! that gets memoized and fixes this. Need to rethink how - #! to fix boxes so this isn't needed... - box-parser boa f next-id parser boa [ ] action ; + #! because a box has its quotation run at compile time + #! it must always have a new parser wrapper created, + #! not a cached one. This is because the same box, + #! compiled twice can have a different compiled word + #! due to running at compile time. + #! Why the [ ] action at the end? Box parsers don't get + #! memoized during parsing due to all box parsers being + #! unique. This breaks left recursion detection during the + #! parse. The action adds an indirection with a parser type + #! that gets memoized and fixes this. Need to rethink how + #! to fix boxes so this isn't needed... + box-parser boa f next-id parser boa [ ] action ; ERROR: parse-failed input word ; diff --git a/basis/peg/search/search-docs.factor b/basis/peg/search/search-docs.factor index 565601ea11..6762373744 100644 --- a/basis/peg/search/search-docs.factor +++ b/basis/peg/search/search-docs.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup peg ; +USING: help.markup help.syntax kernel peg sequences strings ; IN: peg.search HELP: tree-write { $values - { "object" "an object" } } + { "object" object } } { $description "Write the object to the standard output stream, unless " "it is an array, in which case recurse through the array " @@ -14,9 +14,9 @@ HELP: tree-write HELP: search { $values - { "string" "a string" } + { "string" string } { "parser" "a peg based parser" } - { "seq" "a sequence" } + { "seq" sequence } } { $description "Returns a sequence containing the parse results of all substrings " @@ -30,9 +30,9 @@ HELP: search HELP: replace { $values - { "string" "a string" } + { "string" string } { "parser" "a peg based parser" } - { "result" "a string" } + { "result" string } } { $description "Returns a copy of the original string but with all substrings that " diff --git a/basis/persistent/heaps/heaps-docs.factor b/basis/persistent/heaps/heaps-docs.factor index 31422f23b9..3da6578d54 100644 --- a/basis/persistent/heaps/heaps-docs.factor +++ b/basis/persistent/heaps/heaps-docs.factor @@ -10,7 +10,7 @@ HELP: { $description "Creates a new persistent heap consisting of one object with the given priority." } ; HELP: pheap-empty? -{ $values { "heap" "a persistent heap" } { "?" "a boolean" } } +{ $values { "heap" "a persistent heap" } { "?" boolean } } { $description "Returns true if this is an empty persistent heap." } ; HELP: pheap-peek diff --git a/basis/persistent/sequences/sequences.factor b/basis/persistent/sequences/sequences.factor index 5503e369b4..8f9cbe83c8 100644 --- a/basis/persistent/sequences/sequences.factor +++ b/basis/persistent/sequences/sequences.factor @@ -9,7 +9,7 @@ M: sequence ppush swap suffix ; GENERIC: ppop ( seq -- seq' ) -M: sequence ppop 1 head* ; +M: sequence ppop but-last ; GENERIC: new-nth ( val i seq -- seq' ) diff --git a/basis/porter-stemmer/porter-stemmer-docs.factor b/basis/porter-stemmer/porter-stemmer-docs.factor index 537dfe79ce..0212bf348c 100644 --- a/basis/porter-stemmer/porter-stemmer-docs.factor +++ b/basis/porter-stemmer/porter-stemmer-docs.factor @@ -1,8 +1,8 @@ +USING: help.markup help.syntax strings ; IN: porter-stemmer -USING: help.markup help.syntax ; HELP: step1a -{ $values { "str" "a string" } { "newstr" "a new string" } } +{ $values { "str" string } { "newstr" "a new string" } } { $description "Gets rid of plurals." } { $examples { $table @@ -16,7 +16,7 @@ HELP: step1a } ; HELP: step1b -{ $values { "str" "a string" } { "newstr" "a new string" } } +{ $values { "str" string } { "newstr" "a new string" } } { $description "Gets rid of \"-ed\" and \"-ing\" suffixes." } { $examples { $table @@ -34,23 +34,23 @@ HELP: step1b } ; HELP: step1c -{ $values { "str" "a string" } { "newstr" "a new string" } } +{ $values { "str" string } { "newstr" "a new string" } } { $description "Turns a terminal y to i when there is another vowel in the stem." } ; HELP: step2 -{ $values { "str" "a string" } { "newstr" "a new string" } } +{ $values { "str" string } { "newstr" "a new string" } } { $description "Maps double suffices to single ones. so -ization maps to -ize etc. note that the string before the suffix must give positive " { $link consonant-seq } "." } ; HELP: step3 -{ $values { "str" "a string" } { "newstr" "a new string" } } +{ $values { "str" string } { "newstr" "a new string" } } { $description "Deals with -c-, -full, -ness, etc. Similar strategy to " { $link step2 } "." } ; HELP: step5 -{ $values { "str" "a string" } { "newstr" "a new string" } } +{ $values { "str" string } { "newstr" "a new string" } } { $description "Removes a final -e and changes a final -ll to -l if " { $link consonant-seq } " is greater than 1," } ; HELP: stem -{ $values { "str" "a string" } { "newstr" "a new string" } } +{ $values { "str" string } { "newstr" "a new string" } } { $description "Applies the Porter stemming algorithm to the input string." } ; ARTICLE: "porter-stemmer" "Porter stemming algorithm" diff --git a/basis/prettyprint/backend/backend-docs.factor b/basis/prettyprint/backend/backend-docs.factor index 556cdee0ee..250fbe61b0 100644 --- a/basis/prettyprint/backend/backend-docs.factor +++ b/basis/prettyprint/backend/backend-docs.factor @@ -1,12 +1,11 @@ -USING: help.markup help.syntax io kernel -prettyprint.config prettyprint.sections prettyprint.custom -words strings ; +USING: help.markup help.syntax kernel prettyprint.config +prettyprint.custom sequences strings words ; IN: prettyprint.backend ABOUT: "prettyprint-extension" HELP: pprint-word -{ $values { "word" "a word" } } +{ $values { "word" word } } { $description "Adds a text section for the word. Unlike the " { $link word } " method of " { $link pprint* } ", this does not add a " { $link POSTPONE: POSTPONE: } " prefix to parsing words." } $prettyprinting-note ; @@ -28,21 +27,21 @@ HELP: pprint-string $prettyprinting-note ; HELP: nesting-limit? -{ $values { "?" "a boolean" } } +{ $values { "?" boolean } } { $description "Tests if the " { $link nesting-limit } " has been reached." } $prettyprinting-note ; HELP: check-recursion -{ $values { "obj" "an object" } { "quot" { $quotation "( obj -- )" } } } +{ $values { "obj" object } { "quot" { $quotation ( obj -- ) } } } { $description "If the object is already being printed, that is, if the prettyprinter has encountered a cycle in the object graph, or if the maximum nesting depth has been reached, outputs a dummy string. Otherwise applies the quotation to the object." } $prettyprinting-note ; HELP: do-length-limit -{ $values { "seq" "a sequence" } { "trimmed" "a trimmed sequence" } { "n/f" "an integer or " { $link f } } } +{ $values { "seq" sequence } { "trimmed" "a trimmed sequence" } { "n/f" "an integer or " { $link f } } } { $description "If the " { $link length-limit } " is set and the sequence length exceeds this limit, trims the sequence and outputs a the number of elements which were chopped off the end. Otherwise outputs " { $link f } "." } $prettyprinting-note ; HELP: pprint-elements -{ $values { "seq" "a sequence" } } +{ $values { "seq" sequence } } { $description "Prettyprints the elements of a sequence, trimming the sequence to " { $link length-limit } " if necessary." } $prettyprinting-note ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index ec76a79d3c..d9cde6448b 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -99,17 +99,20 @@ M: f pprint* drop \ f pprint-word ; : ch>ascii-escape ( ch -- ch' ? ) H{ { CHAR: \a CHAR: a } + { CHAR: \b CHAR: b } { CHAR: \e CHAR: e } + { CHAR: \f CHAR: f } { CHAR: \n CHAR: n } { CHAR: \r CHAR: r } { CHAR: \t CHAR: t } + { CHAR: \v CHAR: v } { CHAR: \0 CHAR: 0 } { CHAR: \\ CHAR: \\ } { CHAR: \" CHAR: \" } } ?at ; inline : unparse-ch ( ch -- ) - ch>ascii-escape [ "\\" % , ] [ + ch>ascii-escape [ CHAR: \\ , , ] [ dup 32 < [ dup 16 < "\\x0" "\\x" ? % >hex % ] [ , ] if ] if ; diff --git a/basis/prettyprint/config/config.factor b/basis/prettyprint/config/config.factor index 93b3af7477..ed18ee71dc 100644 --- a/basis/prettyprint/config/config.factor +++ b/basis/prettyprint/config/config.factor @@ -19,7 +19,7 @@ SYMBOL: c-object-pointers? 15 nesting-limit set-global 100 length-limit set-global 10 number-base set-global -string-limit? on +t string-limit? set-global : with-short-limits ( quot -- ) H{ diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 33e1857260..57ecd8fda4 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -1,7 +1,6 @@ -USING: prettyprint.backend prettyprint.config prettyprint.custom -prettyprint.sections help.markup help.syntax -io kernel words definitions quotations strings generic classes -prettyprint.private ; +USING: help.markup help.syntax io kernel math +prettyprint.backend prettyprint.config prettyprint.custom +prettyprint.private prettyprint.sections sequences ; IN: prettyprint ARTICLE: "prettyprint-numbers" "Prettyprinting numbers" @@ -160,9 +159,10 @@ ARTICLE: "prettyprint" "The prettyprinter" $nl "Prettyprinter words are found in the " { $vocab-link "prettyprint" } " vocabulary." $nl -"The key words to print an object to " { $link output-stream } "; the first two emit a trailing newline, the second two do not:" +"The key words to print an object to " { $link output-stream } "; the first three emit a trailing newline, the second three do not:" { $subsections . + ... short. pprint pprint-short @@ -206,6 +206,15 @@ HELP: . "Printing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link short. } " or set some " { $link "prettyprint-variables" } " to limit output size." } ; +HELP: ... +{ $values { "obj" object } } +{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is unlimited in length." } +{ $warning + "Printing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link short. } " or set some " { $link "prettyprint-variables" } " to limit output size." +} ; + +{ . ... } related-words + HELP: unparse { $values { "obj" object } { "str" "Factor source string" } } { $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } @@ -222,11 +231,11 @@ HELP: short. { $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce “shorter” output." } ; HELP: .b -{ $values { "n" "an integer" } } +{ $values { "n" integer } } { $description "Outputs an integer in binary." } ; HELP: .o -{ $values { "n" "an integer" } } +{ $values { "n" integer } } { $description "Outputs an integer in octal." } ; HELP: .h @@ -234,7 +243,7 @@ HELP: .h { $description "Outputs an integer or floating-point value in hexadecimal." } ; HELP: stack. -{ $values { "seq" "a sequence" } } +{ $values { "seq" sequence } } { $description "Prints a the elements of the sequence, one per line." } { $notes "This word is used in the implementation of " { $link .s } " and " { $link .r } "." } ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 5efebc3aac..73626004ed 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -433,11 +433,7 @@ TUPLE: fo { a intersection{ integer fixnum } initial: 0 } ; ] unit-test [ -"""union{ - intersection{ string hashtable } - union{ integer float } -} -""" +"""union{ intersection{ string hashtable } union{ integer float } }\n""" ] [ [ union{ union{ float integer } intersection{ string hashtable } } . ] with-string-writer ] unit-test [ @@ -469,3 +465,21 @@ TUPLE: fo { a intersection{ integer fixnum } initial: 0 } ; [ 5 length-limit [ 6 iota >array pprint ] with-variable ] with-string-writer ] unit-test + +: margin-test ( number-of-'a's -- str ) + [ + [ CHAR: a text "b" text ] with-pprint + ] with-string-writer ; + +[ +"""aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa b""" +] [ margin get 3 - margin-test ] unit-test + +[ +"""aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa b""" +] [ margin get 2 - margin-test ] unit-test + +[ +"""aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +b""" +] [ margin get 1 - margin-test ] unit-test diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 6a73536c2a..fe8f4b2b37 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -21,6 +21,8 @@ IN: prettyprint : . ( obj -- ) pprint nl ; +: ... ( obj -- ) [ . ] without-limits ; + : pprint-use ( obj -- ) [ pprint* ] with-use ; : unparse ( obj -- str ) [ pprint ] with-string-writer ; diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor index 0bf11454ab..b645fc0e8a 100644 --- a/basis/prettyprint/sections/sections-docs.factor +++ b/basis/prettyprint/sections/sections-docs.factor @@ -1,6 +1,5 @@ -USING: prettyprint io kernel help.markup help.syntax -prettyprint.config words hashtables math -strings definitions quotations ; +USING: hashtables help.markup help.syntax io kernel math +prettyprint.config quotations strings ; IN: prettyprint.sections HELP: position @@ -10,7 +9,7 @@ HELP: recursion-check { $var-description "The current nesting of collections being output by the prettyprinter, used to detect circularity and prevent infinite recursion." } ; HELP: line-limit? -{ $values { "?" "a boolean" } } +{ $values { "?" boolean } } { $description "Tests if the line number limit has been reached, and thus if prettyprinting should stop." } ; HELP: do-indent @@ -29,7 +28,7 @@ HELP: hard { soft hard } related-words HELP: section-fits? -{ $values { "section" section } { "?" "a boolean" } } +{ $values { "section" section } { "?" boolean } } { $contract "Tests if a section fits in the space that remains on the current line." } ; HELP: short-section @@ -41,20 +40,20 @@ HELP: long-section { $contract "Prints a section which spans multiple lines. This should use a layout strategy maximizing readability and minimizing line length." } ; HELP: indent-section? -{ $values { "section" section } { "?" "a boolean" } } +{ $values { "section" section } { "?" boolean } } { $contract "Outputs a boolean indicating if the indent level should be increased when printing this section as a " { $link long-section } ". Default implementation outputs " { $link f } "." } ; HELP: unindent-first-line? -{ $values { "section" section } { "?" "a boolean" } } +{ $values { "section" section } { "?" boolean } } { $contract "Outputs a boolean indicating if the indent level should only be increased for lines after the first line when printing this section as a " { $link long-section } ". Default implementation outputs " { $link f } "." } { $notes "This is used to format " { $link colon } " sections because of the colon definition formatting convention." } ; HELP: newline-after? -{ $values { "section" section } { "?" "a boolean" } } +{ $values { "section" section } { "?" boolean } } { $contract "Outputs a boolean indicating if a newline should be output after printing this section as a " { $link long-section } ". Default implementation outputs " { $link f } "." } ; HELP: short-section? -{ $values { "section" section } { "?" "a boolean" } } +{ $values { "section" section } { "?" boolean } } { $contract "Tests if a section should be output as a " { $link short-section } ". The default implementation calls " { $link section-fits? } " but this behavior can be customized." } ; HELP: section @@ -144,7 +143,7 @@ HELP: save-end-position { $description "Save the current position as the end position of the block." } ; HELP: pprint-sections -{ $values { "block" block } { "advancer" { $quotation "( block -- )" } } } +{ $values { "block" block } { "advancer" { $quotation ( block -- ) } } } { $description "Prints child sections of a block, ignoring any " { $link line-break } " sections. The " { $snippet "advancer" } " quotation is called between every pair of sections." } ; HELP: do-break @@ -152,11 +151,11 @@ HELP: do-break { $description "Prints a break section as per the policy outlined in " { $link line-break } "." } ; HELP: empty-block? -{ $values { "block" block } { "?" "a boolean" } } +{ $values { "block" block } { "?" boolean } } { $description "Tests if the block has no child sections." } ; HELP: if-nonempty -{ $values { "block" block } { "quot" { $quotation "( block -- )" } } } +{ $values { "block" block } { "quot" { $quotation ( block -- ) } } } { $description "If the block has child sections, calls the quotation, otherwise does nothing." } ; HELP: (>overhang ; inline M: section section-fits? ( section -- ? ) - [ end>> pprinter get last-newline>> - ] + [ end>> 1 - pprinter get last-newline>> - ] [ overhang>> ] bi + text-fits? ; @@ -266,7 +266,7 @@ M: flow short-section? ( section -- ? ) #! a short section { [ section-fits? ] - [ [ end>> ] [ start>> ] bi - text-fits? not ] + [ [ end>> 1 - ] [ start>> ] bi - text-fits? not ] } 1|| ; : ( +{ $values { "quot" { $quotation ( -- x ) } } { "promise" "a promise object" } } { $description "Creates a promise to return a value. When forced this quotation is called and the value returned. The value is memorised so that calling " { $link force } " again does not call the quotation again, instead the previous value is returned directly." } ; HELP: force @@ -12,7 +12,7 @@ HELP: force { $description "Calls the quotation associated with the promise if it has not been called before, and returns the value. If the promise has been forced previously, returns the value from the previous call." } ; HELP: LAZY: -{ $syntax "LAZY: word ( stack -- effect ) definition... ;" } +{ $syntax "LAZY: word ( stack -- effect ) definition... ;" } { $values { "word" "a new word to define" } { "definition" "a word definition" } } { $description "Creates a lazy word in the current vocabulary. When executed the word will return a " { $link promise } " that when forced, executes the word definition. Any values on the stack that are required by the word definition are captured along with the promise." } { $examples diff --git a/basis/random/dummy/dummy.factor b/basis/random/dummy/dummy.factor index 988bd015d0..2103732193 100644 --- a/basis/random/dummy/dummy.factor +++ b/basis/random/dummy/dummy.factor @@ -4,8 +4,8 @@ IN: random.dummy TUPLE: random-dummy i ; C: random-dummy -M: random-dummy seed-random ( obj seed -- obj ) +M: random-dummy seed-random >>i ; -M: random-dummy random-32* ( obj -- r ) +M: random-dummy random-32* [ dup 1 + ] change-i drop ; diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 908e62fe66..3b4e029778 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c -USING: alien.c-types alien.data kernel math namespaces sequences -sequences.private system init accessors math.ranges random -math.bitwise combinators specialized-arrays fry ; +USING: accessors alien.c-types alien.data fry init kernel math +math.bitwise namespaces random sequences sequences.private +specialized-arrays system ; SPECIALIZED-ARRAY: uint IN: random.mersenne-twister @@ -16,27 +16,27 @@ CONSTANT: n 624 CONSTANT: m 397 CONSTANT: a uint-array{ 0 0x9908b0df } -: y ( n seq -- y ) - [ nth-unsafe 31 mask-bit ] - [ [ 1 + ] [ nth-unsafe ] bi* 31 bits ] 2bi bitor ; inline - -: mt[k] ( offset n seq -- ) +: mt-step ( k+m k+1 k seq -- ) [ - [ [ + ] dip nth-unsafe ] - [ y [ 2/ ] [ 1 bitand a nth ] bi bitxor ] 2bi - bitxor + [ nth-unsafe ] curry tri@ + [ 31 bits ] [ 31 mask-bit ] bi* bitor + [ 2/ ] [ 1 bitand a nth ] bi bitxor bitxor ] 2keep set-nth-unsafe ; inline +: mt-steps ( k+m k+1 k n seq -- ) + [ mt-step ] curry [ 3keep [ 1 + ] tri@ ] curry times 3drop ; inline + : mt-generate ( mt -- ) [ seq>> - [ [ n m - ] dip '[ [ m ] dip _ mt[k] ] each-integer ] - [ [ m 1 - ] dip '[ [ m n - ] [ n m - + ] bi* _ mt[k] ] each-integer ] - bi + [ [ m 1 0 n m - ] dip mt-steps ] + [ [ 0 n m - 1 + n m - m 1 - ] dip mt-steps ] + [ [ m 1 - 0 n 1 - ] dip mt-step ] + tri ] [ 0 >>i drop ] bi ; inline : init-mt-formula ( i seq -- f(seq[i]) ) - dupd nth dup -30 shift bitxor 1812433253 * + 1 + 32 bits ; inline + dupd nth dup -30 shift bitxor 1812433253 * + 1 w+ ; inline : init-mt-rest ( seq -- ) n 1 - swap '[ @@ -62,20 +62,19 @@ PRIVATE> init-mt-seq 0 mersenne-twister boa dup mt-generate ; -M: mersenne-twister seed-random ( mt seed -- mt' ) +M: mersenne-twister seed-random init-mt-seq >>seq [ mt-generate ] [ 0 >>i drop ] [ ] tri ; -M: mersenne-twister random-32* ( mt -- r ) +M: mersenne-twister random-32* [ next-index ] [ seq>> nth-unsafe mt-temper ] [ [ 1 + ] change-i drop ] tri ; : default-mersenne-twister ( -- mersenne-twister ) - [ 32 random-bits ] with-system-random - ; + nano-count ; [ default-mersenne-twister random-generator set-global diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index ae26d74ff1..5a6598f035 100644 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -1,21 +1,21 @@ -USING: help.markup help.syntax math kernel sequences arrays ; +USING: arrays help.markup help.syntax kernel math quotations +sequences ; IN: random HELP: seed-random { $values - { "tuple" "a random number generator" } + { "obj" "a random number generator" } { "seed" "a seed specific to the random number generator" } - { "tuple'" "a random number generator" } } { $description "Seed the random number generator. Repeatedly seeding the random number generator should provide the same sequence of random numbers." } { $notes "Not supported on all random number generators." } ; HELP: random-32* -{ $values { "tuple" "a random number generator" } { "r" "an integer between 0 and 2^32-1" } } +{ $values { "obj" "a random number generator" } { "n" "an integer between 0 and 2^32-1" } } { $description "Generates a random 32-bit unsigned integer." } ; HELP: random-bytes* -{ $values { "n" "an integer" } { "tuple" "a random number generator" } { "byte-array" "a sequence of random bytes" } } +{ $values { "n" integer } { "obj" "a random number generator" } { "byte-array" "a sequence of random bytes" } } { $description "Generates a byte-array of random bytes." } ; HELP: random @@ -37,7 +37,7 @@ HELP: random-32 { $description "Outputs 32 random bits. This word is more efficient than calling " { $link random } " because no scaling is done on the output." } ; HELP: random-bytes -{ $values { "n" "an integer" } { "byte-array" "a random integer" } } +{ $values { "n" integer } { "byte-array" "a random integer" } } { $description "Outputs an integer with n bytes worth of bits." } { $examples { $unchecked-example "USING: prettyprint random ;" @@ -56,6 +56,10 @@ HELP: random-integers } } ; +HELP: random-unit +{ $values { "n" float } } +{ $description "Outputs a random uniform float from [0,1]." } ; + HELP: random-units { $values { "length" integer } { "sequence" array } } { $description "Outputs an array with " { $snippet "length" } " random uniform floats from [0,1]." } @@ -75,28 +79,24 @@ HELP: random-units } ; HELP: random-bits -{ $values { "numbits" integer } { "r" "a random integer" } } +{ $values { "numbits" integer } { "n" "a random integer" } } { $description "Outputs an random integer n bits in length." } ; HELP: random-bits* -{ $values - { "numbits" integer } - { "n" integer } -} +{ $values { "numbits" integer } { "n" "a random integer" } } { $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; - HELP: with-random -{ $values { "tuple" "a random generator" } { "quot" "a quotation" } } -{ $description "Calls the quotation with the random generator in a dynamic variable. All random numbers will be generated using this random generator." } ; +{ $values { "obj" "a random number generator" } { "quot" quotation } } +{ $description "Calls the quotation with the random number generator in a dynamic variable. All random numbers will be generated using this random number generator." } ; HELP: with-secure-random -{ $values { "quot" "a quotation" } } -{ $description "Calls the quotation with the secure random generator in a dynamic variable. All random numbers will be generated using this random generator." } ; +{ $values { "quot" quotation } } +{ $description "Calls the quotation with the secure random number generator in a dynamic variable. All random numbers will be generated using this random number generator." } ; HELP: with-system-random -{ $values { "quot" "a quotation" } } -{ $description "Calls the quotation with the system's random generator in a dynamic variable. All random numbers will be generated using this random generator." } ; +{ $values { "quot" quotation } } +{ $description "Calls the quotation with the system's random number generator in a dynamic variable. All random numbers will be generated using this random number generator." } ; { with-random with-secure-random with-system-random } related-words diff --git a/basis/random/random.factor b/basis/random/random.factor index 230aec2f73..093e0b87e7 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -14,21 +14,20 @@ SYMBOL: system-random-generator SYMBOL: secure-random-generator SYMBOL: random-generator -GENERIC# seed-random 1 ( tuple seed -- tuple' ) -GENERIC: random-32* ( tuple -- r ) -GENERIC: random-bytes* ( n tuple -- byte-array ) +GENERIC# seed-random 1 ( obj seed -- obj ) +GENERIC: random-32* ( obj -- n ) +GENERIC: random-bytes* ( n obj -- byte-array ) -M: object random-bytes* ( n tuple -- byte-array ) - [ [ ] keep 4 /mod ] dip - [ pick '[ _ random-32* c:int _ push-all ] times ] - [ - over zero? - [ 2drop ] [ random-32* c:int swap head append! ] if - ] bi-curry bi* B{ } like ; +M: object random-bytes* + [ integer>fixnum-strict [ ] keep ] dip + [ over 4 >= ] [ + [ 4 - ] dip + [ random-32* 2over c:int c:set-alien-value ] keep + ] while over zero? [ 2drop ] [ + random-32* c:int swap head 0 pick copy-unsafe + ] if ; -HINTS: M\ object random-bytes* { fixnum object } ; - -M: object random-32* ( tuple -- r ) +M: object random-32* 4 swap random-bytes* c:uint deref ; ERROR: no-random-number-generator ; @@ -40,42 +39,56 @@ M: f random-bytes* ( n obj -- * ) no-random-number-generator ; M: f random-32* ( obj -- * ) no-random-number-generator ; -: random-32 ( -- n ) random-generator get random-32* ; +: random-32 ( -- n ) + random-generator get random-32* ; -TYPED: random-bytes ( n: fixnum -- byte-array: byte-array ) - random-generator get random-bytes* ; inline +: random-bytes ( n -- byte-array ) + random-generator get random-bytes* ; ] [ - [ 32 shift obj random-32* + ] [ 32 + ] [ 32 - ] tri* - ] while drop [ n * ] [ neg shift ] bi* ; inline - -: ((random-integer)) ( n obj -- n' ) - [ dup #bits ] dip (random-bits) ; inline - -GENERIC# (random-integer) 1 ( n obj -- n ) -M: fixnum (random-integer) ( n obj -- n' ) ((random-integer)) ; -M: bignum (random-integer) ( n obj -- n' ) ((random-integer)) ; - -: random-integer ( n -- n' ) - random-generator get (random-integer) ; +:: (random-bits) ( numbits obj -- n ) + numbits 32 > [ + obj random-32* numbits 32 - [ dup 32 > ] [ + [ 32 shift obj random-32* + ] [ 32 - ] bi* + ] while [ + [ shift ] keep obj random-32* swap bits + + ] unless-zero + ] [ + obj random-32* numbits bits + ] if ; inline PRIVATE> -: random-bits ( numbits -- r ) - [ 2^ ] keep random-generator get (random-bits) ; +: random-bits ( numbits -- n ) + random-generator get (random-bits) ; : random-bits* ( numbits -- n ) 1 - [ random-bits ] keep set-bit ; + ] [ + [ 32 shift obj random-32* + ] [ 32 + ] [ 32 - ] tri* + ] while drop [ m * ] [ neg shift ] bi* ; inline + +GENERIC# (random-integer) 1 ( m obj -- n ) +M: fixnum (random-integer) ( m obj -- n ) ((random-integer)) ; +M: bignum (random-integer) ( m obj -- n ) ((random-integer)) ; + +: random-integer ( m -- n ) + random-generator get (random-integer) ; + +PRIVATE> + GENERIC: random ( obj -- elt ) -M: integer random [ f ] [ random-integer ] if-zero ; +M: integer random + [ f ] [ random-integer ] if-zero ; M: sequence random [ f ] [ @@ -122,7 +135,7 @@ ERROR: too-many-samples seq n ; [ length random-integer ] keep [ nth ] 2keep remove-nth! drop ; -: with-random ( tuple quot -- ) +: with-random ( obj quot -- ) random-generator swap with-variable ; inline : with-system-random ( quot -- ) @@ -162,12 +175,16 @@ PRIVATE> : random-integers ( length n -- sequence ) random-generator get '[ _ _ (random-integer) ] replicate ; + + : normal-random-float ( mean sigma -- n ) (cos-random-float) (log-sqrt-random-float) * * + ; @@ -186,6 +203,8 @@ PRIVATE> : pareto-random-float ( k alpha -- n ) [ random-unit ] dip recip ^ /f ; +1) ( alpha beta -- n ) ! Uses R.C.H. Cheng, "The generation of Gamma ! variables with non-integral shape parameters", @@ -237,6 +256,8 @@ PRIVATE> ] if x! ] do while x beta * ; +PRIVATE> + : gamma-random-float ( alpha beta -- n ) { { [ over 1 > ] [ (gamma-random-float>1) ] } @@ -275,6 +296,8 @@ PRIVATE> rnd (random-unit) 0.5 > [ + ] [ - ] if ] if ; + c! random-unit :> u! @@ -282,6 +305,8 @@ PRIVATE> u c > [ 1. u - u! 1. c - c! swap ] when [ - u c * sqrt * ] keep + ; +PRIVATE> + : triangular-random-float ( low high -- n ) 2dup + 2 /f (triangular-random-float) ; diff --git a/basis/random/sfmt/sfmt.factor b/basis/random/sfmt/sfmt.factor index 4777058bae..ca6e73158c 100644 --- a/basis/random/sfmt/sfmt.factor +++ b/basis/random/sfmt/sfmt.factor @@ -116,8 +116,8 @@ M:: sfmt generate ( sfmt -- ) [ [ [ -30 shift ] [ ] bi bitxor - state-multiplier * 32 bits - ] dip + 32 bits + state-multiplier w* + ] dip w+ ] uint-array{ } accumulate-as nip dup uint-4 cast-array ; diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 0bf08b7878..29f46dd51d 100755 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -46,8 +46,12 @@ M: windows-crypto-context random-bytes* ( n windows-crypto-context -- bytes ) handle>> swap [ ] [ ] bi [ CryptGenRandom win32-error=0/f ] keep ; -: try-crypto-providers ( seq -- windows-crypto-context ) - [ first2 ] attempt-all ; +! Some Windows installations still don't work, so just set +! system and secure rngs to f +: try-crypto-providers ( seq -- windows-crypto-context/f ) + [ + [ first2 ] attempt-all + ] [ 2drop f ] recover ; [ { diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index ae6820f09c..d9ab28ebe1 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -28,7 +28,7 @@ ERROR: bad-class name ; [ [ simple ] keep ] H{ } map>assoc ; MEMO: simple-script-table ( -- table ) - script-table get-global interval-values members simple-table ; + script-table interval-values members simple-table ; MEMO: simple-category-table ( -- table ) categories simple-table ; diff --git a/basis/regexp/regexp-docs.factor b/basis/regexp/regexp-docs.factor index 064a2dd00f..aad796eabc 100644 --- a/basis/regexp/regexp-docs.factor +++ b/basis/regexp/regexp-docs.factor @@ -182,7 +182,7 @@ ARTICLE: "regexp-operations" "Matching operations with regular expressions" "Splitting a string into tokens delimited by a regular expression:" { $subsections re-split } "Replacing occurrences of a regular expression with a string:" -{ $subsections re-replace } ; +{ $subsections re-replace re-replace-with } ; ARTICLE: "regexp-deploy" "Regular expressions and the deploy tool" "The " { $link "tools.deploy" } " tool has the option to strip out the optimizing compiler from the resulting image. Since regular expressions compile to Factor code, this creates a minor performance-related caveat." @@ -210,7 +210,7 @@ HELP: regexp { $class-description "The class of regular expressions. To construct these, see " { $link "regexp-construction" } "." } ; HELP: matches? -{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } } +{ $values { "string" string } { "regexp" regexp } { "?" boolean } } { $description "Tests if the string as a whole matches the given regular expression." } ; HELP: all-matching-slices @@ -227,12 +227,30 @@ HELP: re-split HELP: re-replace { $values { "string" string } { "regexp" regexp } { "replacement" string } { "result" string } } -{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matching-slices } "." } ; +{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matching-slices } "." } +{ $examples + { $example + "USING: prettyprint regexp ;" + "\"python is pythonic\" R/ python/ \"factor\" re-replace ." + "\"factor is factoric\"" } +} ; + +HELP: re-replace-with +{ $values { "string" string } { "regexp" regexp } { "quot" { $quotation ( slice -- replacement ) } } { "result" string } } +{ $description "Replaces substrings which match the input regexp with the result of calling " { $snippet "quot" } " on each matching slice. The boundaries of the substring are chosen by the strategy used by " { $link all-matching-slices } "." } +{ $examples + { $example + "USING: ascii prettyprint regexp ;" + "\"abcdefghi\" R/ [aeiou]/ [ >upper ] re-replace-with ." + "\"AbcdEfghI\"" } +} ; + +{ re-replace re-replace-with } related-words HELP: first-match { $values { "string" string } { "regexp" regexp } { "slice/f" "the match, if one exists" } } { $description "Finds the first match of the regular expression in the string, and returns it as a slice. If there is no match, then " { $link f } " is returned." } ; HELP: re-contains? -{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } } +{ $values { "string" string } { "regexp" regexp } { "?" boolean } } { $description "Determines whether the string has a substring which matches the regular expression given." } ; diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 6070921d8d..c0d6333390 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -113,7 +113,7 @@ PRIVATE> : re-replace ( string regexp replacement -- result ) [ [ subseq ] (re-split) ] dip join ; +:: re-replace-with ( string regexp quot: ( slice -- replacement ) -- result ) + [ + 0 string regexp [ + drop [ [ string , ] keep ] dip + [ string quot call( x -- x ) , ] keep + ] each-match string [ length ] [ ] bi , + ] { } make concat ; + > peek-front ] [ assoc>> ] bi delete-at ] - [ deque>> pop-front* ] - bi ; + [ deque>> pop-front ] [ assoc>> ] bi delete-at ; M: search-deque pop-back* - [ [ deque>> peek-back ] [ assoc>> ] bi delete-at ] - [ deque>> pop-back* ] - bi ; + [ deque>> pop-back ] [ assoc>> ] bi delete-at ; M: search-deque delete-node [ deque>> delete-node ] diff --git a/basis/see/see-docs.factor b/basis/see/see-docs.factor index d872be0ca6..e3134e39fc 100644 --- a/basis/see/see-docs.factor +++ b/basis/see/see-docs.factor @@ -1,4 +1,5 @@ -USING: help.markup help.syntax strings definitions generic words classes ; +USING: classes definitions generic help.markup help.syntax +sequences strings words ; FROM: prettyprint.sections => with-pprint ; IN: see @@ -42,7 +43,7 @@ HELP: definer { $notes "This word is used in the implementation of " { $link see } "." } ; HELP: definition -{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } } +{ $values { "defspec" "a definition specifier" } { "seq" sequence } } { $contract "Outputs the body of a definition." } { $examples { $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" } @@ -62,4 +63,4 @@ $nl synopsis* } ; -ABOUT: "see" \ No newline at end of file +ABOUT: "see" diff --git a/basis/see/see.factor b/basis/see/see.factor index 712b55f142..0316acf378 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -21,6 +21,7 @@ GENERIC: see* ( defspec -- ) : synopsis ( defspec -- str ) [ + string-limit? off 0 margin set 1 line-limit set [ synopsis* ] with-in diff --git a/basis/sequences/deep/deep-docs.factor b/basis/sequences/deep/deep-docs.factor index 4d0b2e3699..d2661d6d41 100644 --- a/basis/sequences/deep/deep-docs.factor +++ b/basis/sequences/deep/deep-docs.factor @@ -2,31 +2,31 @@ USING: help.syntax help.markup kernel sequences ; IN: sequences.deep HELP: deep-each -{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... )" } } } +{ $values { "obj" object } { "quot" { $quotation ( ... elt -- ... ) } } } { $description "Execute a quotation on each nested element of an object and its children, in preorder." } { $see-also each } ; HELP: deep-map -{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... elt' )" } } { "newobj" "the mapped object" } } +{ $values { "obj" object } { "quot" { $quotation ( ... elt -- ... elt' ) } } { "newobj" "the mapped object" } } { $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } { $see-also map } ; HELP: deep-filter-as -{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "exemplar" sequence } { "seq" sequence } } +{ $values { "obj" object } { "quot" { $quotation ( ... elt -- ... ? ) } } { "exemplar" sequence } { "seq" sequence } } { $description "Creates a sequence (of the same type as " { $snippet "exemplar" } ") of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } ; HELP: deep-filter -{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "seq" sequence } } +{ $values { "obj" object } { "quot" { $quotation ( ... elt -- ... ? ) } } { "seq" sequence } } { $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } { $see-also filter } ; HELP: deep-find -{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "elt" "an element" } } +{ $values { "obj" object } { "quot" { $quotation ( ... elt -- ... ? ) } } { "elt" "an element" } } { $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisfies it, it returns " { $link f } "." } { $see-also find } ; HELP: deep-any? -{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... ? )" } } { "?" "a boolean" } } +{ $values { "obj" object } { "quot" { $quotation ( ... elt -- ... ? ) } } { "?" boolean } } { $description "Tests whether the given object or any subnode satisfies the given quotation." } { $see-also any? } ; @@ -39,7 +39,7 @@ HELP: flatten { $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ; HELP: deep-map! -{ $values { "obj" object } { "quot" { $quotation "( ... elt -- ... elt' )" } } } +{ $values { "obj" object } { "quot" { $quotation ( ... elt -- ... elt' ) } } } { $description "Modifies each sub-node of an object in place, in preorder, and returns that object." } { $see-also map! } ; diff --git a/basis/sequences/generalizations/generalizations-docs.factor b/basis/sequences/generalizations/generalizations-docs.factor index 26ddc08027..5ecebe44d4 100644 --- a/basis/sequences/generalizations/generalizations-docs.factor +++ b/basis/sequences/generalizations/generalizations-docs.factor @@ -83,47 +83,47 @@ HELP: nappend-as { nappend nappend-as } related-words HELP: neach -{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation "( element... -- )" } } { "n" integer } } +{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ) } } { "n" integer } } { $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ; HELP: nmap -{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation "( element... -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } } +{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- result ) } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } } { $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ; HELP: nmap-as -{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation "( element... -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } } +{ $values { "seq..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- result ) } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } } { $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ; HELP: mnmap -{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" { $quotation "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } } +{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" { $quotation ( m*element -- result*n ) } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } } { $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ; HELP: mnmap-as -{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" { $quotation "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } } +{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" { $quotation ( m*element -- result*n ) } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } } { $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ; HELP: nproduce -{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } } +{ $values { "pred" { $quotation ( -- ? ) } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } } { $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ; HELP: nproduce-as -{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "exemplar..." { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } } +{ $values { "pred" { $quotation ( -- ? ) } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "exemplar..." { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } } { $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ; HELP: nmap-reduce -{ $values { "map-quot" { $quotation "( element... -- intermediate )" } } { "reduce-quot" { $quotation "( prev intermediate -- next )" } } { "n" integer } } +{ $values { "map-quot" { $quotation ( element... -- intermediate ) } } { "reduce-quot" { $quotation ( prev intermediate -- next ) } } { "n" integer } } { $description "A generalization of " { $link map-reduce } " that can be applied to any number of sequences." } ; HELP: nall? -{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation "( element... - ? )" } } { "n" integer } { "?" boolean } } +{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "?" boolean } } { $description "A generalization of " { $link all? } " that can be applied to any number of sequences." } ; HELP: nfind -{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation "( element... - ? )" } } { "n" integer } { "i" integer } { "elts..." { $snippet "n" } " elements on the datastack" } } +{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "i" integer } { "elts..." { $snippet "n" } " elements on the datastack" } } { $description "A generalization of " { $link find } " that can be applied to any number of sequences." } ; HELP: nany? -{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation "( element... - ? )" } } { "n" integer } { "?" boolean } } +{ $values { "seqs..." { $snippet "n" } " sequences on the datastack" } { "quot" { $quotation ( element... -- ? ) } } { "n" integer } { "?" boolean } } { $description "A generalization of " { $link any? } " that can be applied to any number of sequences." } ; ARTICLE: "sequences.generalizations" "Generalized sequence words" diff --git a/basis/sequences/product/product-docs.factor b/basis/sequences/product/product-docs.factor index ac26089814..854911ae18 100644 --- a/basis/sequences/product/product-docs.factor +++ b/basis/sequences/product/product-docs.factor @@ -40,20 +40,20 @@ HELP: { product-sequence } related-words HELP: product-map -{ $values { "sequences" sequence } { "quot" { $quotation "( ... seq -- ... value )" } } { "sequence" sequence } } +{ $values { "sequences" sequence } { "quot" { $quotation ( ... seq -- ... value ) } } { "sequence" sequence } } { $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." } { $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] map" } "." } ; HELP: product-map-as -{ $values { "sequences" sequence } { "quot" { $quotation "( ... seq -- ... value )" } } { "exemplar" sequence } { "sequence" sequence } } +{ $values { "sequences" sequence } { "quot" { $quotation ( ... seq -- ... value ) } } { "exemplar" sequence } { "sequence" sequence } } { $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence the same type as the " { $snippet "exemplar" } " sequence." } ; HELP: product-map>assoc -{ $values { "sequences" sequence } { "quot" { $quotation "( ... seq -- ... key value )" } } { "exemplar" assoc } { "assoc" assoc } } +{ $values { "sequences" sequence } { "quot" { $quotation ( ... seq -- ... key value ) } } { "exemplar" assoc } { "assoc" assoc } } { $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output assoc." } ; HELP: product-each -{ $values { "sequences" sequence } { "quot" { $quotation "( ... seq -- ... )" } } } +{ $values { "sequences" sequence } { "quot" { $quotation ( ... seq -- ... ) } } } { $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." } { $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] each" } "." } ; diff --git a/basis/sequences/product/product.factor b/basis/sequences/product/product.factor index 1c193a1461..99f6035df8 100644 --- a/basis/sequences/product/product.factor +++ b/basis/sequences/product/product.factor @@ -1,5 +1,6 @@ ! (c)2009 Joe Groff bsd license -USING: accessors arrays assocs kernel locals math sequences ; +USING: accessors arrays assocs kernel locals math sequences +sequences.private ; FROM: sequences => change-nth ; IN: sequences.product @@ -25,24 +26,27 @@ M: product-sequence length lengths>> product ; :: (carry-n) ( ns lengths i -- ) ns length i 1 + = [ - i ns nth i lengths nth = [ - 0 i ns set-nth - i 1 + ns [ 1 + ] change-nth + i ns nth-unsafe i lengths nth-unsafe = [ + 0 i ns set-nth-unsafe + i 1 + ns [ 1 + ] change-nth-unsafe ns lengths i 1 + (carry-n) ] when - ] unless ; + ] unless ; inline recursive : carry-ns ( ns lengths -- ) - 0 (carry-n) ; + 0 (carry-n) ; inline : product-iter ( ns lengths -- ) - [ 0 over [ 1 + ] change-nth ] dip carry-ns ; + [ 0 over [ 1 + ] change-nth-unsafe ] dip carry-ns ; inline : start-product-iter ( sequences -- ns lengths ) - [ length 0 ] [ [ length ] map ] bi ; + [ length 0 ] [ [ length ] map ] bi ; inline : end-product-iter? ( ns lengths -- ? ) - [ last ] same? ; + [ last-unsafe ] same? ; inline + +: product-length ( sequences -- length ) + [ length ] [ * ] map-reduce ; inline PRIVATE> @@ -58,9 +62,9 @@ M: product-sequence nth :: product-map-as ( ... sequences quot: ( ... seq -- ... value ) exemplar -- ... sequence ) 0 :> i! - sequences [ length ] [ * ] map-reduce exemplar + sequences product-length exemplar [| result | - sequences [ quot call i result set-nth i 1 + i! ] product-each + sequences [ quot call i result set-nth-unsafe i 1 + i! ] product-each result ] new-like ; inline @@ -69,8 +73,8 @@ M: product-sequence nth :: product-map>assoc ( ... sequences quot: ( ... seq -- ... key value ) exemplar -- ... assoc ) 0 :> i! - sequences [ length ] [ * ] map-reduce { } + sequences product-length { } [| result | - sequences [ quot call 2array i result set-nth i 1 + i! ] product-each + sequences [ quot call 2array i result set-nth-unsafe i 1 + i! ] product-each result ] new-like exemplar assoc-like ; inline diff --git a/basis/sequences/unrolled/unrolled-docs.factor b/basis/sequences/unrolled/unrolled-docs.factor index 1e6ba39897..3d41426f7c 100644 --- a/basis/sequences/unrolled/unrolled-docs.factor +++ b/basis/sequences/unrolled/unrolled-docs.factor @@ -5,70 +5,70 @@ IN: sequences.unrolled HELP: unrolled-collect { $values - { "n" integer } { "quot" { $quotation "( n -- value )" } } { "into" sequence } + { "n" integer } { "quot" { $quotation ( n -- value ) } } { "into" sequence } } { $description "Unrolled version of " { $link collect } ". " { $snippet "n" } " must be a compile-time constant." } ; HELP: unrolled-each { $values - { "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- )" } } + { "seq" sequence } { "len" integer } { "quot" { $quotation ( x -- ) } } } { $description "Unrolled version of " { $link each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ; HELP: unrolled-2each { $values - { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- )" } } + { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation ( x y -- ) } } } { $description "Unrolled version of " { $link 2each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ; HELP: unrolled-each-index { $values - { "seq" sequence } { "len" integer } { "quot" { $quotation "( x i -- )" } } + { "seq" sequence } { "len" integer } { "quot" { $quotation ( x i -- ) } } } { $description "Unrolled version of " { $link each-index } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ; HELP: unrolled-each-integer { $values - { "n" integer } { "quot" { $quotation "( i -- )" } } + { "n" integer } { "quot" { $quotation ( i -- ) } } } { $description "Unrolled version of " { $link each-integer } ". " { $snippet "n" } " must be a compile-time constant." } ; HELP: unrolled-map { $values - { "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- newx )" } } + { "seq" sequence } { "len" integer } { "quot" { $quotation ( x -- newx ) } } { "newseq" sequence } } { $description "Unrolled version of " { $link map } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ; HELP: unrolled-map-as { $values - { "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- newx )" } } { "exemplar" sequence } + { "seq" sequence } { "len" integer } { "quot" { $quotation ( x -- newx ) } } { "exemplar" sequence } { "newseq" sequence } } { $description "Unrolled version of " { $link map-as } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ; HELP: unrolled-2map { $values - { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- newx )" } } { "newseq" sequence } + { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation ( x y -- newx ) } } { "newseq" sequence } } { $description "Unrolled version of " { $link 2map } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ; HELP: unrolled-2map-as { $values - { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- newx )" } } { "exemplar" sequence } { "newseq" sequence } + { "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation ( x y -- newx ) } } { "exemplar" sequence } { "newseq" sequence } } { $description "Unrolled version of " { $link 2map-as } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ; HELP: unrolled-map-index { $values - { "seq" sequence } { "len" integer } { "quot" { $quotation "( x i -- newx )" } } + { "seq" sequence } { "len" integer } { "quot" { $quotation ( x i -- newx ) } } { "newseq" sequence } } { $description "Unrolled version of " { $link map-index } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ; HELP: unrolled-map-integers { $values - { "n" integer } { "quot" { $quotation "( n -- value )" } } { "exemplar" sequence } { "newseq" sequence } + { "n" integer } { "quot" { $quotation ( n -- value ) } } { "exemplar" sequence } { "newseq" sequence } } { $description "Unrolled version of " { $link map-integers } ". " { $snippet "n" } " must be a compile-time constant." } ; diff --git a/basis/sequences/windowed/windowed.factor b/basis/sequences/windowed/windowed.factor index 5dd986cb19..19458157d6 100644 --- a/basis/sequences/windowed/windowed.factor +++ b/basis/sequences/windowed/windowed.factor @@ -1,25 +1,48 @@ ! Copyright (C) 2012 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math math.order sequences ; +USING: accessors fry kernel locals math math.order +math.statistics sequences sequences.private ; IN: sequences.windowed -TUPLE: windowed-sequence { sequence sequence read-only } { n integer } ; +TUPLE: windowed-sequence + { sequence sequence read-only } + { n integer } ; INSTANCE: windowed-sequence sequence C: windowed-sequence - + +M: windowed-sequence nth-unsafe + [ 1 + ] dip [ n>> dupd [-] swap ] [ sequence>> ] bi ; inline + +M: windowed-sequence length + sequence>> length ; inline + : in-bound ( n sequence -- n' ) [ drop 0 ] [ length ] bi clamp ; inline : in-bounds ( a b sequence -- a' b' sequence ) - [ nip in-bound ] - [ [ nip ] dip in-bound ] - [ 2nip ] 3tri ; - -M: windowed-sequence nth - [ [ 1 + ] dip n>> [ - ] [ drop ] 2bi ] - [ nip sequence>> in-bounds ] 2bi ; - -M: windowed-sequence length - sequence>> length ; \ No newline at end of file + [ nip in-bound ] [ [ nip ] dip in-bound ] [ 2nip ] 3tri ; + +:: rolling-map ( ... seq n quot: ( ... slice -- ... elt ) -- ... newseq ) + seq length [ + [ n [-] ] [ seq ] bi quot call + ] { } map-integers ; inline + +: rolling-sum ( seq n -- newseq ) + [ sum ] rolling-map ; + +: rolling-mean ( seq n -- newseq ) + [ mean ] rolling-map ; + +: rolling-median ( seq n -- newseq ) + [ median ] rolling-map ; + +: rolling-supremum ( seq n -- newseq ) + [ supremum ] rolling-map ; + +: rolling-infimum ( seq n -- newseq ) + [ infimum ] rolling-map ; + +: rolling-count ( ... u n quot: ( ... elt -- ... ? ) -- ... v ) + '[ _ count ] rolling-map ; inline diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 3151bea80b..0b7c4df97a 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -6,13 +6,11 @@ ! ! See http://factorcode.org/license.txt for BSD license. ! -USING: namespaces sequences kernel math io math.functions -io.binary strings classes words sbufs classes.tuple arrays -vectors byte-arrays quotations hashtables hashtables.identity -assocs help.syntax help.markup splitting io.streams.byte-array -io.encodings.string io.encodings.utf8 io.encodings.binary -combinators accessors locals prettyprint compiler.units -sequences.private classes.tuple.private vocabs ; +USING: accessors arrays assocs byte-arrays classes classes.tuple +combinators hashtables hashtables.identity io io.binary +io.encodings.binary io.encodings.string io.encodings.utf8 +io.streams.byte-array kernel locals math namespaces prettyprint +quotations sequences sequences.private strings vocabs words ; IN: serialize GENERIC: (serialize) ( obj -- ) @@ -95,7 +93,7 @@ M: tuple (serialize) ( obj -- ) CHAR: T write1 [ class-of (serialize) ] [ add-object ] - [ tuple>array rest (serialize) ] + [ tuple-slots (serialize) ] tri ] serialize-shared ; @@ -194,19 +192,17 @@ SYMBOL: deserialized (deserialize-string) dup intern-object ; : deserialize-word ( -- word ) - (deserialize) (deserialize) 2dup [ require ] keep lookup-word - dup [ 2nip ] [ - drop + (deserialize) (deserialize) + 2dup [ require ] keep lookup-word [ 2nip ] [ 2array unparse "Unknown word: " prepend throw - ] if ; + ] if* ; : deserialize-gensym ( -- word ) - gensym { - [ intern-object ] - [ (deserialize) define ] - [ (deserialize) >>props drop ] - [ ] - } cleave ; + gensym + [ intern-object ] + [ (deserialize) define ] + [ (deserialize) >>props ] + tri ; : deserialize-wrapper ( -- wrapper ) (deserialize) ; @@ -228,8 +224,8 @@ SYMBOL: deserialized : deserialize-hashtable ( -- hashtable ) H{ } clone [ intern-object ] - [ (deserialize) assoc-union! drop ] - [ ] tri ; + [ (deserialize) assoc-union! ] + bi ; : copy-seq-to-tuple ( seq tuple -- ) [ set-array-nth ] curry each-index ; @@ -277,8 +273,7 @@ SYMBOL: deserialized PRIVATE> : deserialize ( -- obj ) - V{ } clone deserialized - [ (deserialize) ] with-variable ; + V{ } clone deserialized [ (deserialize) ] with-variable ; : serialize ( obj -- ) IH{ } clone serialized [ (serialize) ] with-variable ; diff --git a/basis/simple-flat-file/summary.txt b/basis/simple-flat-file/summary.txt new file mode 100644 index 0000000000..af4fd1feef --- /dev/null +++ b/basis/simple-flat-file/summary.txt @@ -0,0 +1 @@ +Parsing simple text files diff --git a/basis/simple-tokenizer/simple-tokenizer.factor b/basis/simple-tokenizer/simple-tokenizer.factor index f6698a65f0..f7de0822c1 100644 --- a/basis/simple-tokenizer/simple-tokenizer.factor +++ b/basis/simple-tokenizer/simple-tokenizer.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2010 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: peg peg.ebnf arrays sequences strings kernel ; +USING: peg.ebnf strings ; IN: simple-tokenizer EBNF: tokenize diff --git a/basis/simple-tokenizer/summary.txt b/basis/simple-tokenizer/summary.txt new file mode 100644 index 0000000000..d9d2171265 --- /dev/null +++ b/basis/simple-tokenizer/summary.txt @@ -0,0 +1 @@ +Simple string tokenizer diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index b00ee6a856..62c0f770c9 100644 --- a/basis/smtp/smtp-docs.factor +++ b/basis/smtp/smtp-docs.factor @@ -4,34 +4,41 @@ USING: accessors kernel quotations help.syntax help.markup io.sockets strings calendar io.encodings.utf8 ; IN: smtp -HELP: smtp-domain -{ $var-description "The name of the machine that is sending the email. This variable will be filled in by the " { $link host-name } " word if not set by the user." } ; +HELP: smtp-config +{ $class-description "An SMTP configuration object, with the following slots:" + { $table + { { $slot "domain" } { "Name of the machine sending the email, or " { $link host-name } " if empty." } } + { { $slot "server" } { "An " { $link } " of the SMTP server." } } + { { $slot "tls?" } { "Secure socket after connecting to server, server must support " { $snippet "STARTTLS" } } } + { { $slot "read-timeout" } { "Length of time after which we give up waiting for a response." } } + { { $slot "auth" } { "Either " { $link no-auth } " or an instance of " { $link plain-auth } } } + } +} ; -HELP: smtp-server -{ $var-description "Holds an " { $link inet } " object with the address of an SMTP server." } ; +HELP: default-smtp-config +{ $values { "smtp-config" smtp-config } } +{ $description "Creates a new " { $link smtp-config } " with defaults of a one minute " { $snippet "read-timeout" } ", " { $link no-auth } " for authentication, and " { $snippet "localhost" } " port " { $snippet "25" } " as the server." } ; -HELP: smtp-tls? -{ $var-description "If set to true, secure socket communication will be established after connecting to the SMTP server. The server must support the " { $snippet "STARTTLS" } " command. Off by default." } ; - -HELP: smtp-read-timeout -{ $var-description "Holds a " { $link duration } " object that specifies how long to wait for a response from the SMTP server." } ; - -HELP: smtp-auth -{ $var-description "Holds either " { $link no-auth } " or an instance of " { $link plain-auth } ", specifying how to authenticate with the SMTP server. Set to " { $link no-auth } " by default." } ; +{ smtp-config default-smtp-config } related-words HELP: no-auth -{ $class-description "If the " { $link smtp-auth } " variable is set to this value, no authentication will be performed." } ; +{ $class-description "If the " { $snippet "auth" } " slot is set to this value, no authentication will be performed." } ; HELP: plain-auth -{ $class-description "If the " { $link smtp-auth } " variable is set to this value, plain authentication will be performed, with the username and password stored in the " { $slot "username" } " and " { $slot "password" } " slots of the tuple sent to the server as plain-text." } ; +{ $class-description "If the " { $snippet "auth" } " slot is set to this value, plain authentication will be performed, with the username and password stored in the " { $slot "username" } " and " { $slot "password" } " slots of the tuple sent to the server as plain-text." } ; HELP: { $values { "username" string } { "password" string } { "plain-auth" plain-auth } } { $description "Creates a new " { $link plain-auth } " instance." } ; +HELP: with-smtp-config +{ $values { "quot" quotation } } +{ $description "Connects to an SMTP server using credentials and settings stored in " { $link smtp-config } " and calls the " { $link with-smtp-connection } " combinator." } +{ $notes "This word is used to implement " { $link send-email } " and there is probably no reason to call it directly." } ; + HELP: with-smtp-connection { $values { "quot" quotation } } -{ $description "Connects to an SMTP server stored in " { $link smtp-server } " and calls the quotation." } +{ $description "Connects to an SMTP server using credentials and settings stored in " { $link smtp-config } " and calls the quotation." } { $notes "This word is used to implement " { $link send-email } " and there is probably no reason to call it directly." } ; HELP: email @@ -76,31 +83,29 @@ HELP: send-email } ; ARTICLE: "smtp-gmail" "Setting up SMTP with gmail" -"If you plan to send all email from the same address, then setting variables in the global namespace is the best option. The code example below does this approach and is meant to go in your " { $link ".factor-boot-rc" } "." $nl -"Several variables need to be set for sending outgoing mail through gmail. First, we set the login and password to a " { $link } " tuple with our login. Next, we set the gmail server address with an " { $link } " object. Finally, we tell the SMTP library to use a secure connection." +"If you plan to send all email from the same address, then setting the config variable in the global namespace is the best option. The code example below does this approach and is meant to go in your " { $link ".factor-boot-rc" } "." $nl +"First, we set the login and password to a " { $link } " tuple with our login. Next, we set the gmail server address with an " { $link } " object. Finally, we tell the SMTP library to use a secure connection." +{ $notes "Gmail requires the use of application-specific passwords when accessed from anywhere but their website. Visit " { $url "https://support.google.com/accounts/answer/185833?hl=en" } " to create a password for use with Factor." } { $code "USING: smtp namespaces io.sockets ;" "" - "\"my.gmail.address@gmail.com\" \"secret-password\" smtp-auth set-global" - "" - "\"smtp.gmail.com\" 587 smtp-server set-global" - "" - "t smtp-tls? set-global" + """default-smtp-config + "smtp.gmail.com" 587 >>server + t >>tls? + "my.gmail.address@gmail.com" "qwertyuiasdfghjk" >>auth + \\ smtp-config set-global""" } ; ARTICLE: "smtp" "SMTP client library" "The " { $vocab-link "smtp" } " vocabulary sends e-mail via an SMTP server." $nl -"This library is configured by a set of dynamically-scoped variables:" +"This library is configured by a globally scoped config tuple:" { $subsections - smtp-server - smtp-tls? - smtp-read-timeout - smtp-domain - smtp-auth + smtp-config + default-smtp-config } -"The latter is set to an instance of one of the following:" +"The auth slot is set to an instance of one of the following:" { $subsections no-auth plain-auth diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index ca0629a1fd..8e9c5d0e26 100644 --- a/basis/smtp/smtp-tests.factor +++ b/basis/smtp/smtp-tests.factor @@ -1,9 +1,21 @@ -USING: smtp tools.test io.streams.string io.sockets -io.sockets.secure threads smtp.server kernel sequences -namespaces logging accessors assocs sorting smtp.private -concurrency.promises system ; +USING: accessors assocs combinators concurrency.promises +continuations fry io.sockets io.sockets.secure io.streams.string +kernel namespaces sequences smtp smtp.private smtp.server +sorting system tools.test ; IN: smtp.tests +: with-test-smtp-config ( quot -- ) + [ + "p" set + "p" get mock-smtp-server + + default-smtp-config + "localhost" "p" get ?promise >>server + no-auth >>auth + os unix? [ t >>tls? ] when + \ smtp-config + ] dip with-variable ; inline + { 0 0 } [ [ ] with-smtp-connection ] must-infer-as [ "hello\nworld" validate-address ] must-fail @@ -56,40 +68,40 @@ IN: smtp.tests { "slava@factorcode.org" "dharmatech@factorcode.org" } "erg@factorcode.org" ] [ - - "Factor rules" >>subject - { - "Slava " - "Ed " - } >>to - "Doug " >>from [ - email>headers sort-keys [ - drop { "Date" "Message-Id" } member? not - ] assoc-filter - ] - [ to>> [ extract-email ] map ] - [ from>> extract-email ] tri -] unit-test - - "p" set - -[ ] [ "p" get mock-smtp-server ] unit-test - -[ ] [ - f >>verify [ - "localhost" "p" get ?promise smtp-server set - no-auth smtp-auth set - os unix? [ smtp-tls? on ] when - - "Hi guys\nBye guys" >>body "Factor rules" >>subject { "Slava " "Ed " } >>to "Doug " >>from - send-email + { + [ + email>headers sort-keys [ + drop { "Date" "Message-Id" } member? not + ] assoc-filter + ] + [ to>> [ extract-email ] map ] + [ from>> extract-email ] + ! To get the smtp server to clean up itself + [ '[ _ send-email ] ignore-errors ] + } cleave + ] with-test-smtp-config +] unit-test + +[ ] [ + f >>verify [ + [ + + "Hi guys\nBye guys" >>body + "Factor rules" >>subject + { + "Slava " + "Ed " + } >>to + "Doug " >>from + send-email + ] with-test-smtp-config ] with-secure-context ] unit-test diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 78c0fad40f..48ea2c1814 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,43 +1,47 @@ ! 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 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 ; +USING: accessors arrays assocs base64 calendar calendar.format +classes combinators debugger fry io io.crlf io.encodings +io.encodings.ascii io.encodings.binary io.encodings.iana +io.encodings.string io.encodings.utf8 io.sockets +io.sockets.secure io.timeouts kernel logging make math.order +math.parser namespaces prettyprint random sequences sets +splitting strings words ; IN: smtp -SYMBOL: smtp-domain - -SYMBOL: smtp-server -"localhost" 25 smtp-server set-global - -SYMBOL: smtp-tls? - -SYMBOL: smtp-read-timeout -1 minutes smtp-read-timeout set-global +TUPLE: smtp-config domain server tls? { read-timeout duration } auth ; SINGLETON: no-auth TUPLE: plain-auth username password ; C: plain-auth -SYMBOL: smtp-auth -no-auth smtp-auth set-global +: ( -- smtp-config ) + smtp-config new ; inline + +: default-smtp-config ( -- smtp-config ) + + "localhost" 25 >>server + 1 minutes >>read-timeout + no-auth >>auth ; inline LOG: log-smtp-connection NOTICE : with-smtp-connection ( quot -- ) - smtp-server get + smtp-config get server>> dup log-smtp-connection ascii [ - smtp-domain [ host-name or ] change - smtp-read-timeout get timeouts + smtp-config get + [ [ host-name or ] change-domain drop ] + [ read-timeout>> timeouts ] bi call ] with-client ; inline +: with-smtp-config ( quot -- ) + [ \ smtp-config get-global clone \ smtp-config ] dip + '[ _ with-smtp-connection ] with-variable ; inline + TUPLE: email { from string } { to array } @@ -152,7 +156,7 @@ M: plain-auth send-auth [ username>> ] [ password>> ] bi plain-auth-string "AUTH PLAIN " prepend command get-ok ; -: auth ( -- ) smtp-auth get send-auth ; +: auth ( -- ) smtp-config get auth>> send-auth ; : encode-header ( string -- string' ) dup aux>> [ @@ -180,7 +184,7 @@ ERROR: invalid-header-string string ; "-" % gmt timestamp>micros # "@" % - smtp-domain get [ host-name ] unless* % + smtp-config get domain>> [ host-name ] unless* % ">" % ] "" make ; @@ -210,7 +214,7 @@ ERROR: invalid-header-string string ; [ get-ok helo get-ok - smtp-tls? get [ start-tls get-ok send-secure-handshake ] when + smtp-config get tls?>> [ start-tls get-ok send-secure-handshake ] when auth dup from>> extract-email mail-from get-ok dup to>> [ extract-email rcpt-to get-ok ] each diff --git a/basis/sorting/insertion/insertion.factor b/basis/sorting/insertion/insertion.factor index 0615893f07..2a2ac4134a 100644 --- a/basis/sorting/insertion/insertion.factor +++ b/basis/sorting/insertion/insertion.factor @@ -1,16 +1,19 @@ -USING: locals sequences kernel math ; +USING: kernel locals math sequences sequences.private ; IN: sorting.insertion = [ - n n 1 - seq exchange + n n 1 - [ seq nth-unsafe ] bi@ + 2dup [ quot call ] bi@ >= [ 2drop ] [ + n 1 - n [ seq set-nth-unsafe ] bi-curry@ bi* seq quot n 1 - insert - ] unless + ] if ] unless ; inline recursive + PRIVATE> : insertion-sort ( ... seq quot: ( ... elt -- ... elt' ) -- ... ) ! quot is a transformation on elements - over length [ insert ] with with each-integer ; inline + over length [ insert ] 2with 1 -rot (each-integer) ; inline diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 959fd8bfd5..43c05ee207 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -16,7 +16,7 @@ IN: sorting.slots unclip-last-slice [ [ execute-accessor ] each ] dip ] when execute-comparator - ] with with map-find drop +eq+ or ; + ] 2with map-find drop +eq+ or ; : sort-by-with ( seq sort-specs quot: ( obj -- key ) -- seq' ) swap '[ _ bi@ _ compare-slots ] sort ; inline diff --git a/basis/stack-checker/alien/alien-docs.factor b/basis/stack-checker/alien/alien-docs.factor new file mode 100644 index 0000000000..db710100d8 --- /dev/null +++ b/basis/stack-checker/alien/alien-docs.factor @@ -0,0 +1,61 @@ +USING: alien alien.c-types compiler.tree effects help.markup help.syntax +quotations sequences ; +IN: stack-checker.alien + +HELP: alien-node-params +{ $class-description "Base class for the parameter slot of " { $link #alien-node } " nodes. It has the following slots:" + { $table + { { $slot "return" } { "a " { $link c-type-name } " which indicates the type of the functions return value." } } + { { $slot "parameters" } { "a " { $link sequence } " of " { $link c-type-name } " giving the types of the functions parameters." } } + } +} ; + +HELP: alien-callback-params +{ $class-description "Class that holds the parameter types and return value type of an alien callback call." } +{ $see-also #alien-callback } ; + +HELP: param-prep-quot +{ $values { "params" alien-node-params } { "quot" quotation } } +{ $description "Builds a quotation which coerces values on the stack to the required types for the alien call." } +{ $examples + { $unchecked-example + "USING: alien.c-types prettyprint stack-checker.alien ;" + "T{ alien-invoke-params { parameters { void* c-string int } } } param-prep-quot ." + "[ [ [ [ ] dip >c-ptr ] dip \\ utf8 string>alien ] dip >fixnum ]" + } +} ; + +HELP: callback-parameter-quot +{ $values { "params" alien-node-params } { "quot" quotation } } +{ $description "Builds a quotation which coerces values on the stack to the required types for an alien callback. This word is essentially the opposite to " { $link param-prep-quot } "." } +{ $examples + { $unchecked-example + "USING: alien.c-types prettyprint stack-checker.alien ;" + "T{ alien-node-params { parameters { c-string } } } callback-parameter-quot ." + "[ { object } declare [ ] dip \ utf8 alien>string ]" + } +} ; + +HELP: infer-alien-invoke +{ $description "Appends the necessary SSA nodes for performing an " { $link alien-invoke } " call to the IR tree being constructed." } ; + +HELP: wrap-callback-quot +{ $values { "params" alien-node-params } { "quot" quotation } { "quot'" quotation } } +{ $description "Wraps the given quotation in protective packaging so that it becomes suitable to be used as an alien callback. That means that the parameters are unpacked from C types to Factor types and, if the callback returns something, the top data stack item is afterwards converted to a C compatible value." } +{ $examples + "Here a callback that returns the length of a " { $link c-string } " is wrapped:" + { $unchecked-example + "USING: alien.c-types prettyprint stack-checker.alien ;" + "T{ alien-node-params { return int } { parameters { c-string } } } " + "[ length ] wrap-callback-quot ." + "[" + " [" + " { object } declare [ ] dip \ utf8 alien>string" + " length >fixnum" + " ] [" + " dup current-callback eq?" + " [ drop ] [ wait-for-callback ] if" + " ] do-callback" + "]" + } +} ; diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 7a712e1b9c..fdaa5add17 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays sequences accessors combinators math +USING: kernel destructors arrays sequences accessors combinators math namespaces init sets words assocs alien.libraries alien alien.private alien.c-types fry quotations strings stack-checker.backend stack-checker.errors stack-checker.visitor diff --git a/basis/stack-checker/backend/backend-docs.factor b/basis/stack-checker/backend/backend-docs.factor new file mode 100644 index 0000000000..04a1a46f24 --- /dev/null +++ b/basis/stack-checker/backend/backend-docs.factor @@ -0,0 +1,19 @@ +USING: compiler.tree effects help.markup help.syntax quotations sequences +stack-checker.state stack-checker.visitor ; +IN: stack-checker.backend + +HELP: infer-quot-here +{ $values { "quot" quotation } } +{ $description "Performs inferencing on the given quotation. This word should only be called in a " { $link with-infer } " context." } ; + +HELP: introduce-values +{ $values { "values" sequence } } +{ $description "Emits an " { $link #introduce } " node to the current " { $link stack-visitor } " which pushes the given values onto the data stack." } ; + +HELP: with-infer +{ $values { "quot" quotation } { "effect" effect } { "visitor" "a visitor, if any" } } +{ $description "Initializes the inference engine and then runs the given quotation which is supposed to perform the inferencing." } ; + +HELP: push-literal +{ $values { "obj" "something" } } +{ $description "Pushes a literal onto the " { $link literals } " sequence." } ; diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 2c4e4d02ad..5eab8a11bc 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -61,7 +61,7 @@ SYMBOLS: combinator quotations ; ] if-empty ; : branch-variable ( seq symbol -- seq ) - '[ [ _ ] dip at ] map ; + '[ _ of ] map ; : active-variable ( seq symbol -- seq ) [ [ terminated? over at [ drop f ] when ] map ] dip @@ -92,6 +92,20 @@ SYMBOLS: combinator quotations ; input-count [ ] change inner-d-index [ ] change ; +: collect-variables ( -- hash ) + { + (meta-d) + (meta-r) + current-word + inner-d-index + input-count + literals + quotation + recursive-state + stack-visitor + terminated? + } [ dup get ] H{ } map>assoc ; + GENERIC: infer-branch ( literal -- namespace ) M: literal-tuple infer-branch @@ -99,7 +113,8 @@ M: literal-tuple infer-branch copy-inference nest-visitor [ value>> quotation set ] [ infer-literal-quot ] bi - ] H{ } make-assoc ; + collect-variables + ] with-scope ; M: declared-effect infer-branch known>> infer-branch ; @@ -109,7 +124,8 @@ M: callable infer-branch copy-inference nest-visitor [ quotation set ] [ infer-quot-here ] bi - ] H{ } make-assoc ; + collect-variables + ] with-scope ; : infer-branches ( branches -- input children data ) [ pop-d ] dip diff --git a/basis/stack-checker/known-words/known-words-docs.factor b/basis/stack-checker/known-words/known-words-docs.factor new file mode 100644 index 0000000000..95bbbc87b3 --- /dev/null +++ b/basis/stack-checker/known-words/known-words-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax sequences words ; +IN: stack-checker.known-words + +HELP: infer-special +{ $values { "word" word } } +{ $description "Performs inferencing of a word with the \"special\" property set." } ; + +HELP: infer-ndip +{ $values { "word" word } { "n" "the dip depth" } } +{ $description "Performs inferencing for one of the dip words." } ; + +HELP: define-primitive +{ $values { "word" word } { "inputs" sequence } { "outputs" sequence } } +{ $description "Marks the word as a primitive whose input and output types must be the given ones." } ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index d6a92cbf08..10297eb071 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -302,7 +302,7 @@ M: object infer-call* \ call bad-macro-input ; \ (word) { object object object } { word } define-primitive \ (word) make-flushable \ { integer object } { array } define-primitive \ make-flushable \ { integer } { byte-array } define-primitive \ make-flushable -\ { integer word } { alien } define-primitive +\ { word integer } { alien } define-primitive \ { integer c-ptr } { c-ptr } define-primitive \ make-flushable \ { integer integer } { string } define-primitive \ make-flushable \ { array } { tuple } define-primitive \ make-flushable @@ -344,6 +344,7 @@ M: object infer-call* \ call bad-macro-input ; \ bignum> { bignum bignum } { object } define-primitive \ bignum> make-foldable \ bignum>= { bignum bignum } { object } define-primitive \ bignum>= make-foldable \ bignum>fixnum { bignum } { fixnum } define-primitive \ bignum>fixnum make-foldable +\ bignum>fixnum-strict { bignum } { fixnum } define-primitive \ bignum>fixnum-strict make-foldable \ bits>double { integer } { float } define-primitive \ bits>double make-foldable \ bits>float { integer } { float } define-primitive \ bits>float make-foldable \ both-fixnums? { object object } { object } define-primitive @@ -358,6 +359,7 @@ M: object infer-call* \ call bad-macro-input ; \ context-object { fixnum } { object } define-primitive \ context-object make-flushable \ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable \ current-callback { } { fixnum } define-primitive \ current-callback make-flushable +\ (callback-room) { } { byte-array } define-primitive \ (callback-room) make-flushable \ (data-room) { } { byte-array } define-primitive \ (data-room) make-flushable \ datastack { } { array } define-primitive \ datastack make-flushable \ datastack-for { c-ptr } { array } define-primitive \ datastack-for make-flushable @@ -416,6 +418,7 @@ M: object infer-call* \ call bad-macro-input ; \ fpu-state { } { } define-primitive \ fputc { object alien } { } define-primitive \ fread-unsafe { integer c-ptr alien } { integer } define-primitive +\ free-callback { alien } { } define-primitive \ fseek { integer integer alien } { } define-primitive \ ftell { alien } { integer } define-primitive \ fwrite { c-ptr integer alien } { } define-primitive diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 620b3759a2..03e8a38f93 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -1,11 +1,5 @@ -USING: help.syntax help.markup kernel sequences words io -effects classes math combinators -stack-checker.backend -stack-checker.branches -stack-checker.errors -stack-checker.transforms -stack-checker.state -continuations ; +USING: classes continuations effects help.markup help.syntax io +kernel quotations sequences stack-checker.errors ; IN: stack-checker ARTICLE: "inference-simple" "Straight-line stack effects" @@ -91,7 +85,7 @@ $nl "However a small change can be made:" { $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( x -- )" } "An inline recursive word must have a fixed stack effect in its base case. The following will not infer:" -{ $example +{ $unchecked-example ": foo ( quot ? -- ) [ f foo ] [ call ] if ; inline" "[ [ 5 ] t foo ] infer." "The inline recursive word “foo” must be declared recursive\nword foo" @@ -160,12 +154,12 @@ HELP: inference-error } ; HELP: infer -{ $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } } +{ $values { "quot" 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." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; HELP: infer. -{ $values { "quot" "a quotation" } } +{ $values { "quot" quotation } } { $description "Attempts to infer the quotation's stack effect, and prints this data to " { $link output-stream } "." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; diff --git a/basis/stack-checker/state/state-docs.factor b/basis/stack-checker/state/state-docs.factor new file mode 100644 index 0000000000..734eb19357 --- /dev/null +++ b/basis/stack-checker/state/state-docs.factor @@ -0,0 +1,13 @@ +USING: help.markup help.syntax quotations sequences ; +IN: stack-checker.state + +HELP: meta-d +{ $values { "stack" sequence } } +{ $description "Compile-time data stack." } ; + +HELP: meta-r +{ $values { "stack" sequence } } +{ $description "Compile-time retain stack." } ; + +HELP: literals +{ $var-description "Uncommitted literals. This is a form of local dead-code elimination; the goal is to reduce the number of IR nodes which get constructed. Technically it is redundant since we do global DCE later, but it speeds up compile time." } ; diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 67f8cdc67b..b48b0b14a6 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -18,16 +18,10 @@ DEFER: commit-literals SYMBOL: (meta-d) SYMBOL: (meta-r) -! Compile-time data stack : meta-d ( -- stack ) commit-literals (meta-d) get ; -! Compile-time retain stack : meta-r ( -- stack ) (meta-r) get ; -! Uncommitted literals. This is a form of local dead-code -! elimination; the goal is to reduce the number of IR nodes -! which get constructed. Technically it is redundant since -! we do global DCE later, but it speeds up compile time. SYMBOL: literals : (push-literal) ( obj -- ) diff --git a/basis/stack-checker/values/values-docs.factor b/basis/stack-checker/values/values-docs.factor new file mode 100644 index 0000000000..c87dad50c1 --- /dev/null +++ b/basis/stack-checker/values/values-docs.factor @@ -0,0 +1,6 @@ +USING: help.markup help.syntax math quotations sequences words ; +IN: stack-checker.values + +HELP: +{ $values { "value" number } } +{ $description "Outputs a series of monotonically increasing numbers. They are used to assign unique ids to nodes " { $slot "in-d" } " and " { $slot "out-d" } " slots." } ; diff --git a/basis/stack-checker/visitor/visitor-docs.factor b/basis/stack-checker/visitor/visitor-docs.factor new file mode 100644 index 0000000000..4805d4edae --- /dev/null +++ b/basis/stack-checker/visitor/visitor-docs.factor @@ -0,0 +1,13 @@ +USING: compiler.tree help.markup help.syntax kernel sequences words ; +IN: stack-checker.visitor + +HELP: #>r, +{ $values { "inputs" sequence } { "outputs" sequence } } +{ $description "Emits a " { $link #shuffle } " node that copies values from the data stack to the retain stack. This node is primarily outputted by the " { $link dip } " word and its relatives." } +{ $examples + { $example + "USING: namespaces prettyprint stack-checker.visitor ;" + "V{ } stack-visitor set { 123 } { 124 } #>r, stack-visitor get ." + "V{\n T{ #shuffle\n { mapping { { 124 123 } } }\n { in-d { 123 } }\n { out-r { 124 } }\n }\n}" + } +} ; diff --git a/basis/summary/summary.factor b/basis/summary/summary.factor index 89f4a61af6..fb46d3f11b 100644 --- a/basis/summary/summary.factor +++ b/basis/summary/summary.factor @@ -1,13 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs classes continuations kernel make math -math.parser sequences ; +math.parser sequences sets ; IN: summary GENERIC: summary ( object -- string ) -: object-summary ( object -- string ) - class-of name>> ; inline +: object-summary ( object -- string ) class-of name>> ; inline M: object summary object-summary ; @@ -27,6 +26,14 @@ M: assoc summary " entries" % ] "" make ; +M: set summary + [ + dup class-of name>> % + " with " % + cardinality # + " members" % + ] "" make ; + ! Override sequence => integer instance M: f summary object-summary ; diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor index b0bd5a2ff5..d8bf47c7d9 100644 --- a/basis/syndication/syndication-tests.factor +++ b/basis/syndication/syndication-tests.factor @@ -40,4 +40,4 @@ IN: syndication.tests } } } ] [ "vocab:syndication/test/atom.xml" load-news-file ] unit-test -[ ] [ "vocab:syndication/test/atom.xml" load-news-file feed>xml xml>string drop ] unit-test +[ t ] [ "vocab:syndication/test/atom.xml" load-news-file dup feed>xml xml>feed = ] unit-test diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index 407e09aab1..27f709dd10 100644 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -80,7 +80,7 @@ TUPLE: entry title url description date ; [ children>string ] if >>description ] [ - { "published" "updated" "issued" "modified" } + { "published" "updated" "issued" "modified" } any-tag-named children>string try-parsing-timestamp >>date ] @@ -122,7 +122,7 @@ M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ; [XML <-> - /> + /> <-> <-> @@ -135,7 +135,7 @@ M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ; <-> - /> + /> <-> XML> ; diff --git a/basis/system-info/linux/linux.factor b/basis/system-info/linux/linux.factor index 13121a851e..bcc207ab53 100644 --- a/basis/system-info/linux/linux.factor +++ b/basis/system-info/linux/linux.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax byte-arrays io +USING: accessors alien.c-types alien.syntax byte-arrays io io.encodings.string io.encodings.utf8 io.streams.byte-array -kernel sequences splitting strings system system-info unix ; +libc kernel sequences splitting strings system system-info unix +unix.linux.proc math ; IN: system-info.linux FUNCTION-ALIAS: (uname) @@ -19,4 +20,9 @@ FUNCTION-ALIAS: (uname) : machine ( -- string ) 4 uname nth ; : domainname ( -- string ) 5 uname nth ; -M: linux os-version release ; \ No newline at end of file +M: linux os-version release ; +M: linux cpus parse-proc-cpuinfo sort-cpus cpu-counts 2drop ; +: cores ( -- n ) parse-proc-cpuinfo sort-cpus cpu-counts drop nip ; +: hyperthreads ( -- n ) parse-proc-cpuinfo sort-cpus cpu-counts 2nip ; +M: linux cpu-mhz parse-proc-cpuinfo first cpu-mhz>> 1,000,000 * ; +M: linux physical-mem parse-proc-meminfo mem-total>> ; diff --git a/basis/system-info/macosx/macosx.factor b/basis/system-info/macosx/macosx.factor index 570ed21887..a40a9c41f9 100644 --- a/basis/system-info/macosx/macosx.factor +++ b/basis/system-info/macosx/macosx.factor @@ -3,8 +3,9 @@ USING: alien alien.c-types alien.data alien.strings alien.syntax arrays assocs byte-arrays combinators core-foundation io.binary -io.encodings.utf8 kernel math namespaces sequences system -system-info unix ; +io.encodings.utf8 libc kernel math namespaces sequences +specialized-arrays system system-info unix ; +SPECIALIZED-ARRAY: int IN: system-info.macosx @@ -15,8 +16,7 @@ TYPEDEF: UInt32 OSType FUNCTION: OSErr Gestalt ( OSType selector, SInt32* response ) ; : gestalt ( selector -- response ) - 0 SInt32 [ Gestalt ] keep - swap [ throw ] unless-zero le> ; + { SInt32 } [ Gestalt 0 assert= ] with-out-parameters ; : system-version ( -- n ) "sysv" be> gestalt ; : system-version-major ( -- n ) "sys1" be> gestalt ; @@ -24,19 +24,22 @@ FUNCTION: OSErr Gestalt ( OSType selector, SInt32* response ) ; : system-version-bugfix ( -- n ) "sys3" be> gestalt ; CONSTANT: system-code-names H{ - { 0x1080 "Mountain Lion" } - { 0x1070 "Lion" } - { 0x1060 "Snow Leopard" } - { 0x1050 "Leopard" } - { 0x1040 "Tiger" } - { 0x1030 "Panther" } - { 0x1020 "Jaguar" } - { 0x1010 "Puma" } - { 0x1000 "Cheetah" } + { { 10 10 } "Yosemite" } + { { 10 9 } "Mavericks" } + { { 10 8 } "Mountain Lion" } + { { 10 7 } "Lion" } + { { 10 6 } "Snow Leopard" } + { { 10 5 } "Leopard" } + { { 10 4 } "Tiger" } + { { 10 3 } "Panther" } + { { 10 2 } "Jaguar" } + { { 10 1 } "Puma" } + { { 10 0 } "Cheetah" } } : system-code-name ( -- str/f ) - system-version 0xFFF0 bitand system-code-names at ; + system-version-major system-version-minor 2array + system-code-names at ; PRIVATE> @@ -50,14 +53,11 @@ M: macosx os-version LIBRARY: libc FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ; -: make-int-array ( seq -- byte-array ) - [ int ] map concat ; - : (sysctl-query) ( name namelen oldp oldlenp -- oldp ) over [ f 0 sysctl io-error ] dip ; : sysctl-query ( seq n -- byte-array ) - [ [ make-int-array ] [ length ] bi ] dip + [ [ int >c-array ] [ length ] bi ] dip [ ] [ uint ] bi (sysctl-query) ; : sysctl-query-string ( seq -- n ) @@ -73,8 +73,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi : model ( -- str ) { 6 2 } sysctl-query-string ; M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ; : byte-order ( -- n ) { 6 4 } sysctl-query-uint ; -M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ; -: user-mem ( -- n ) { 6 6 } sysctl-query-uint ; + +! Only an int, not large enough. Deprecated. +! M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-int ; +! : user-mem ( -- n ) { 6 6 } sysctl-query-uint ; + : page-size ( -- n ) { 6 7 } sysctl-query-uint ; : disknames ( -- n ) { 6 8 } 8 sysctl-query ; : diskstats ( -- n ) { 6 9 } 8 sysctl-query ; @@ -92,5 +95,5 @@ M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ; : l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ; : l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ; : tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ; -: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ; +M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ; : available-cpus ( -- n ) { 6 25 } sysctl-query-uint ; diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index 563a59dde9..7d58d6f635 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -95,7 +95,7 @@ HELP: run-queue { $values { "dlist" dlist } } { $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time." $nl -"By convention, threads are queued with " { $link push-front } +"By convention, threads are queued with " { $link push-front } " and dequed with " { $link pop-back } "." } ; HELP: resume @@ -154,11 +154,28 @@ $nl "The recommended way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." } { $examples + "A simple thread that adds two numbers:" { $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" } + "A thread that counts to 10:" + { $code + "USING: math.parser threads ;" + "[ 10 iota [ number>string write nl yield ] each ] \"test\" spawn" + "10 [ yield ] times" + "0" + "1" + "2" + "3" + "4" + "5" + "6" + "7" + "8" + "9" + } } ; HELP: spawn-server -{ $values { "quot" { $quotation "( -- ? )" } } { "name" string } { "thread" thread } } +{ $values { "quot" { $quotation ( -- ? ) } } { "name" string } { "thread" thread } } { $description "Convenience wrapper around " { $link spawn } " which repeatedly calls the quotation in a new thread until it outputs " { $link f } "." } { $examples "A thread that runs forever:" @@ -181,5 +198,5 @@ HELP: tset { $description "Sets the value of a thread-local variable." } ; HELP: tchange -{ $values { "key" object } { "quot" { $quotation "( ..a value -- ..b newvalue )" } } } +{ $values { "key" object } { "quot" { $quotation ( ..a value -- ..b newvalue ) } } } { $description "Applies the quotation to the current value of a thread-local variable, storing the result back to the same variable." } ; diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index 43fc3af129..a8612696b7 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -25,7 +25,7 @@ $nl ABOUT: "tools.annotations" HELP: annotate -{ $values { "word" "a word" } { "quot" { $quotation "( old-def -- new-def )" } } } +{ $values { "word" word } { "quot" { $quotation ( old-def -- new-def ) } } } { $description "Changes a word definition to the result of applying a quotation to the old definition." } { $notes "This word is used to implement " { $link watch } "." } ; diff --git a/basis/tools/coverage/coverage-docs.factor b/basis/tools/coverage/coverage-docs.factor index 386a867f79..90ac1d1bf0 100644 --- a/basis/tools/coverage/coverage-docs.factor +++ b/basis/tools/coverage/coverage-docs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2011 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types help.markup help.syntax kernel quotations +USING: alien.c-types assocs help.markup help.syntax kernel quotations sequences strings ; IN: tools.coverage @@ -85,7 +85,14 @@ HELP: test-coverage { "vocab" "a vocabulary specifier" } { "coverage" sequence } } -{ $description "Enables code coverage for a vocabulary and activates it for the unit tests only. The returned value is a sequence of pairs containing names and quotations which did not execute." } ; +{ $description "Enables code coverage for a vocabulary and runs its unit tests. The returned value is a sequence of pairs containing names and quotations which did not execute." } ; + +HELP: test-coverage-recursively +{ $values + { "prefix" "a vocabulary name" } + { "assoc" assoc } +} +{ $description "Enables code coverage for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ; ARTICLE: "tools.coverage" "Coverage tool" "The " { $vocab-link "tools.coverage" } " vocabulary is a tool for testing code coverage. The implementation uses " { $vocab-link "tools.annotations" } " to place a coverage object at the beginning of every quotation. When the quotation executes, a slot on the coverage object is set to true. By examining the coverage objects after running the code for some time, one can see which of the quotations did not execute and write more tests or refactor the code." $nl diff --git a/basis/tools/coverage/coverage-tests.factor b/basis/tools/coverage/coverage-tests.factor new file mode 100644 index 0000000000..6e03bced33 --- /dev/null +++ b/basis/tools/coverage/coverage-tests.factor @@ -0,0 +1,75 @@ +! Copyright (C) 2014 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel sequences sorting tools.coverage +tools.coverage.private tools.coverage.testvocab tools.coverage.testvocab.child +tools.coverage.testvocab.private tools.test vocabs.loader ; +IN: tools.coverage.tests + +{ "foo.private" } [ "foo" private-vocab-name ] unit-test +{ "foo.private" } [ "foo.private" private-vocab-name ] unit-test + +{ + { halftested mconcat testcond testfry testif testifprivate testmacro untested +} +} [ "tools.coverage.testvocab" [ ] map-words natural-sort ] unit-test + +{ t } [ + "tools.coverage.testvocab" + [ V{ } clone [ [ push ] curry each-word ] keep >array ] + [ [ ] map-words ] bi = +] unit-test + +{ + { testifprivate } +} [ "tools.coverage.testvocab.private" [ ] map-words natural-sort ] unit-test + +{ t } [ + "tools.coverage.testvocab.private" + [ V{ } clone [ [ push ] curry each-word ] keep >array ] + [ [ ] map-words ] bi = +] unit-test + +{ 3 } [ \ testif count-callables ] unit-test + +! Need to reload to flush macro cache +! and have correct coverage statistics +{ + { + { halftested { [ ] } } + { mconcat { } } + { testcond { } } + { testfry { } } + { testif { } } + { testifprivate { } } + { testmacro { } } + { untested { [ ] } } + } +} [ "tools.coverage.testvocab" [ reload ] [ test-coverage natural-sort ] bi ] unit-test + +{ 0.75 } [ "tools.coverage.testvocab.child" [ reload ] [ %coverage ] bi ] unit-test + +{ + { + { + "tools.coverage.testvocab" + { + { halftested { [ ] } } + { mconcat { } } + { testcond { } } + { testfry { } } + { testif { } } + { testifprivate { } } + { testmacro { } } + { untested { [ ] } } + } + } + { + "tools.coverage.testvocab.child" + { { child-halftested { [ ] } } { foo { } } } + } +} +} [ + "tools.coverage.testvocab.child" reload + "tools.coverage.testvocab" [ reload ] [ test-coverage-recursively ] bi natural-sort + [ first2 natural-sort 2array ] map +] unit-test diff --git a/basis/tools/coverage/coverage.factor b/basis/tools/coverage/coverage.factor index 1d3dadd972..cf9079d165 100644 --- a/basis/tools/coverage/coverage.factor +++ b/basis/tools/coverage/coverage.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2011 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs fry io kernel math prettyprint -quotations sequences sequences.deep splitting strings -tools.annotations vocabs words arrays words.symbol -combinators.short-circuit namespaces tools.test -combinators continuations classes ; +USING: accessors arrays assocs classes combinators +combinators.short-circuit continuations fry io kernel math +namespaces prettyprint quotations sequences sequences.deep +splitting strings tools.annotations tools.test +tools.test.private vocabs words words.symbol ; IN: tools.coverage TUPLE: coverage-state < identity-tuple executed? ; @@ -121,12 +121,19 @@ PRIVATE> dup '[ [ _ - [ coverage-on test coverage-off ] + [ coverage-on test-vocab coverage-off ] [ coverage ] bi ] [ _ remove-coverage ] [ ] cleanup ] call ] bi ; +: coverage-vocab? ( vocab -- ? ) + { [ ".private" tail? ] [ ".tests" tail? ] } 1|| not ; + +: test-coverage-recursively ( prefix -- assoc ) + child-vocabs [ coverage-vocab? ] filter + [ dup test-coverage ] { } map>assoc ; + : %coverage ( string -- x ) [ test-coverage values concat length ] [ count-callables ] bi [ swap - ] keep /f ; inline diff --git a/basis/tools/coverage/testvocab/authors.txt b/basis/tools/coverage/testvocab/authors.txt new file mode 100644 index 0000000000..2c5e05bdac --- /dev/null +++ b/basis/tools/coverage/testvocab/authors.txt @@ -0,0 +1 @@ +Jon Harper diff --git a/basis/tools/coverage/testvocab/child/authors.txt b/basis/tools/coverage/testvocab/child/authors.txt new file mode 100644 index 0000000000..2c5e05bdac --- /dev/null +++ b/basis/tools/coverage/testvocab/child/authors.txt @@ -0,0 +1 @@ +Jon Harper diff --git a/basis/tools/coverage/testvocab/child/child-tests.factor b/basis/tools/coverage/testvocab/child/child-tests.factor new file mode 100644 index 0000000000..1745dc9629 --- /dev/null +++ b/basis/tools/coverage/testvocab/child/child-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2014 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test tools.coverage.testvocab.child ; +IN: tools.coverage.testvocab.child.tests + +{ } [ foo ] unit-test +{ } [ t child-halftested ] unit-test diff --git a/basis/tools/coverage/testvocab/child/child.factor b/basis/tools/coverage/testvocab/child/child.factor new file mode 100644 index 0000000000..ea9f86580e --- /dev/null +++ b/basis/tools/coverage/testvocab/child/child.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2014 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: tools.coverage.testvocab.child + +: foo ( -- ) ; +: child-halftested ( ? -- ) [ ] [ ] if ; diff --git a/basis/tools/coverage/testvocab/testvocab-docs.factor b/basis/tools/coverage/testvocab/testvocab-docs.factor new file mode 100644 index 0000000000..aaa21a41f9 --- /dev/null +++ b/basis/tools/coverage/testvocab/testvocab-docs.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2014 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations sequences ; +IN: tools.coverage.testvocab + +ARTICLE: "tools.coverage.testvocab" "Coverage tool dummy test vocabulary" +"The " { $vocab-link "tools.coverage.testvocab" } " vocabulary is just a dummy vocabulary to test " { $vocab-link "tools.coverage" } "." ; + +ABOUT: "tools.coverage.testvocab" + diff --git a/basis/tools/coverage/testvocab/testvocab-tests.factor b/basis/tools/coverage/testvocab/testvocab-tests.factor new file mode 100644 index 0000000000..847dcabd32 --- /dev/null +++ b/basis/tools/coverage/testvocab/testvocab-tests.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2014 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test tools.coverage.testvocab tools.coverage.testvocab.private ; +IN: tools.coverage.testvocab.tests + +{ } [ t testifprivate ] unit-test +{ } [ f testifprivate ] unit-test +{ } [ t testif ] unit-test +{ } [ f testif ] unit-test +{ } [ f halftested ] unit-test +{ 0 } [ 0 testcond ] unit-test +{ 1 } [ 1 testcond ] unit-test +{ 2 } [ 2 testcond ] unit-test +{ 1 2 3 } [ { [ 1 ] [ 2 3 ] } mconcat ] unit-test +{ } [ 1 2 testmacro ] unit-test +{ } [ 2 1 testmacro ] unit-test +{ } [ t testfry ] unit-test +{ } [ f testfry ] unit-test diff --git a/basis/tools/coverage/testvocab/testvocab.factor b/basis/tools/coverage/testvocab/testvocab.factor new file mode 100644 index 0000000000..d6f83c2eb7 --- /dev/null +++ b/basis/tools/coverage/testvocab/testvocab.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2014 Jon Harper. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators fry kernel macros math sequences ; +IN: tools.coverage.testvocab + + + +: halftested ( ? -- ) [ ] [ ] if ; +: testif ( ? -- ) [ ] [ ] if ; +: testcond ( n -- n ) { + { [ dup 0 = ] [ ] } + { [ dup 1 = ] [ ] } + [ ] +} cond ; + +MACRO: mconcat ( seq -- quot ) concat ; +: testmacro ( a b -- ) + { [ 2dup ] [ <= [ ] [ ] if ] [ > [ ] [ ] if ] } mconcat ; + +: testfry ( ? -- ) + '[ _ [ ] [ ] if ] call ; + +: untested ( -- ) ; + +SYMBOL: not-a-coverage-word diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor index f4d2abe2f8..3c47e57dae 100644 --- a/basis/tools/crossref/crossref-docs.factor +++ b/basis/tools/crossref/crossref-docs.factor @@ -1,5 +1,5 @@ -USING: help.markup help.syntax words definitions prettyprint -tools.crossref.private math quotations assocs kernel sets ; +USING: assocs help.markup help.syntax kernel math sets +tools.crossref.private words ; IN: tools.crossref ARTICLE: "tools.crossref" "Definition cross referencing" @@ -50,7 +50,7 @@ HELP: usage { $notes "The sequence might include the definition itself, if it is a recursive word." } ; HELP: usage. -{ $values { "word" "a word" } } +{ $values { "word" 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." } } ; diff --git a/basis/tools/deploy/backend/backend-tests.factor b/basis/tools/deploy/backend/backend-tests.factor new file mode 100644 index 0000000000..b47bfc3b3e --- /dev/null +++ b/basis/tools/deploy/backend/backend-tests.factor @@ -0,0 +1,45 @@ +USING: kernel pcre sequences tools.deploy.backend tools.test ; +IN: tools.deploy.backend.tests + +: complete-match? ( str regexp -- ? ) + "^" "$" surround matches? ; + +{ t } [ + { } staging-command-line + { + "-staging" + "-no-user-init" + "-pic=0" + "-output-image.*" + "-include=" + "-i=boot\\..*" + } [ complete-match? ] 2all? +] unit-test + +{ t } [ + { "compiler" } staging-command-line + { + "-staging" + "-no-user-init" + "-pic=0" + "-output-image=.*" + "-include=compiler" + "-i=.*" + "-resource-path=.*" + "-run=tools.deploy.restage" + } [ complete-match? ] 2all? +] unit-test + +{ t } [ + "image" "hello-world" "manifest.file" { "foob" } deploy-command-line + { + "-pic=0" + "-i=.*foob.*" + "-vocab-manifest-out=manifest.file" + "-deploy-vocab=hello-world" + "-deploy-config=.*hello-world" + "-output-image=image" + "-resource-path=.*" + "-run=tools.deploy.shaker" + } [ complete-match? ] 2all? +] unit-test diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 0cc5d0b817..6ab4de3bd2 100644 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -47,7 +47,7 @@ ERROR: can't-deploy-library-file library ; : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. my-boot-image-name resource-path exists? - [ my-arch make-image ] unless ; + [ make-my-image ] unless ; : bootstrap-profile ( -- profile ) [ @@ -55,38 +55,38 @@ ERROR: can't-deploy-library-file library ; deploy-threads? get [ "threads" , ] when "compiler" , deploy-help? get [ "help" , ] when + native-io? [ "io" , ] when deploy-ui? get [ "ui" , ] when deploy-unicode? get [ "unicode" , ] when - native-io? [ "io" , ] when + ] { } make ; : staging-image-name ( profile -- name ) "-" join "." my-arch 3append "staging." ".image" surround cache-file ; -DEFER: ?make-staging-image - : staging-command-line ( profile -- flags ) [ - "-staging" , - dup empty? [ - "-i=" my-boot-image-name append , + [ + "-staging" , "-no-user-init" , "-pic=0" , + [ staging-image-name "-output-image=" prepend , ] + [ " " join "-include=" prepend , ] bi ] [ - dup but-last ?make-staging-image - "-resource-path=" "" resource-path append , - "-i=" over but-last staging-image-name append , - "-run=tools.deploy.restage" , - ] if - "-output-image=" over staging-image-name append , - "-include=" swap " " join append , - "-no-user-init" , - "-pic=0" , + [ "-i=" my-boot-image-name append , ] [ + but-last staging-image-name "-i=" prepend , + "-resource-path=" "" resource-path append , + "-run=tools.deploy.restage" , + ] if-empty + ] bi ] { } make ; : run-factor ( vm flags -- ) swap prefix dup . run-with-output ; inline +DEFER: ?make-staging-image + : make-staging-image ( profile -- ) + dup [ but-last ?make-staging-image ] unless-empty vm swap staging-command-line run-factor ; : ?make-staging-image ( profile -- ) @@ -98,21 +98,17 @@ DEFER: ?make-staging-image [ "deploy-config-" prepend temp-file ] bi [ utf8 set-file-contents ] keep ; -: deploy-command-line ( image vocab manifest-file config -- flags ) +: deploy-command-line ( image vocab manifest-file profile -- flags ) [ - bootstrap-profile ?make-staging-image - - [ - "-i=" bootstrap-profile staging-image-name append , - "-resource-path=" "" resource-path append , - "-run=tools.deploy.shaker" , - "-vocab-manifest-out=" prepend , - [ "-deploy-vocab=" prepend , ] - [ make-deploy-config "-deploy-config=" prepend , ] bi - "-output-image=" prepend , - "-pic=0" , - ] { } make - ] with-variables ; + "-pic=0" , + staging-image-name "-i=" prepend , + "-vocab-manifest-out=" prepend , + [ "-deploy-vocab=" prepend , ] + [ make-deploy-config "-deploy-config=" prepend , ] bi + "-output-image=" prepend , + "-resource-path=" "" resource-path append , + "-run=tools.deploy.shaker" , + ] { } make ; : parse-vocab-manifest-file ( path -- vocab-manifest ) utf8 file-lines [ "empty vocab manifest!" throw ] [ @@ -123,10 +119,14 @@ DEFER: ?make-staging-image :: make-deploy-image ( vm image vocab config -- manifest ) make-boot-image - vocab "vocab-manifest-" prepend temp-file :> manifest-file - image vocab manifest-file config deploy-command-line :> flags - vm flags run-factor - manifest-file parse-vocab-manifest-file ; + config [ + bootstrap-profile :> profile + vocab "vocab-manifest-" prepend temp-file :> manifest-file + image vocab manifest-file profile deploy-command-line :> flags + profile ?make-staging-image + vm flags run-factor + manifest-file parse-vocab-manifest-file + ] with-variables ; :: make-deploy-image-executable ( vm image vocab config -- manifest ) vm image vocab config make-deploy-image diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor index 5170e34065..48b4b1c349 100644 --- a/basis/tools/deploy/config/config-docs.factor +++ b/basis/tools/deploy/config/config-docs.factor @@ -88,6 +88,9 @@ $nl "On by default." { $notes "On Mac OS X, if " { $link deploy-ui? } " is set, the application will always be deployed as an application bundle regardless of the " { $snippet "deploy-console?" } " setting. The UI implementation on Mac OS X relies on the application being in a bundle." } } ; +HELP: deploy-directory +{ $description "Used to specify the directory where the deployed executable will be created." } ; + HELP: deploy-io { $description "The level of I/O support required by the deployed image:" { $table diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index 7af24b837f..950b2da2a1 100644 --- a/basis/tools/deploy/config/config.factor +++ b/basis/tools/deploy/config/config.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files io kernel sequences assocs splitting parser -namespaces math vocabs hashtables ; +USING: assocs hashtables kernel math namespaces vocabs ; IN: tools.deploy.config SYMBOL: deploy-name @@ -67,3 +66,6 @@ SYMBOL: deploy-image ! default value for deploy.macosx { "stop-after-last-window?" t } } assoc-union ; + +SYMBOL: deploy-directory +"resource:" deploy-directory set-global diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index e71b4a8a39..7c6e5573af 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -20,35 +20,41 @@ cache-directory [ [ "no such vocab, fool!" deploy ] [ bad-vocab-name? ] must-fail-with -[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test +[ ] [ "hello-world" shake-and-bake 550000 small-enough? ] unit-test [ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test -[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test +! [ ] [ "hello-ui" shake-and-bake 1605000 small-enough? ] unit-test +[ ] [ "hello-ui" shake-and-bake 2069160 small-enough? ] unit-test -[ "math-threads-compiler-ui" ] [ +[ "math-threads-compiler-io-ui" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name "." split second ] with-variables ] unit-test -[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test +! [ ] [ "maze" shake-and-bake 1520000 small-enough? ] unit-test +[ ] [ "maze" shake-and-bake 2000000 small-enough? ] unit-test -[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test +! [ ] [ "tetris" shake-and-bake 1734000 small-enough? ] unit-test +[ ] [ "tetris" shake-and-bake 2186392 small-enough? ] unit-test -[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test +! [ ] [ "spheres" shake-and-bake 1557000 small-enough? ] unit-test +[ ] [ "spheres" shake-and-bake 2031096 small-enough? ] unit-test -[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test +! [ ] [ "terrain" shake-and-bake 2053000 small-enough? ] unit-test +[ ] [ "terrain" shake-and-bake 2671928 small-enough? ] unit-test -[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test +! [ ] [ "gpu.demos.raytrace" shake-and-bake 2764000 small-enough? ] unit-test +[ ] [ "gpu.demos.raytrace" shake-and-bake 3307816 small-enough? ] unit-test [ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test [ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test os macosx? [ - [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test + [ ] [ "webkit-demo" shake-and-bake 600000 small-enough? ] unit-test ] when [ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test @@ -71,7 +77,7 @@ http.server.responses http.server.static io.servers ; SINGLETON: quit-responder M: quit-responder call-responder* - 2drop stop-this-server "Goodbye" "text/html" ; + 2drop stop-this-server "Goodbye" ; : add-quot-responder ( responder -- responder ) quit-responder "quit" add-responder ; @@ -154,13 +160,14 @@ os macosx? [ [ "Factor" ] [ deploy-test-command ascii [ readln ] with-process-reader ] unit-test -[ ] [ "tools.deploy.test.20" drop 870000 small-enough? ] unit-test +! [ ] [ "tools.deploy.test.20" drop 1353000 small-enough? ] unit-test +[ ] [ "tools.deploy.test.20" drop 1363000 small-enough? ] unit-test [ ] [ "tools.deploy.test.21" shake-and-bake ] unit-test [ "1 2 3" ] [ deploy-test-command ascii [ readln ] with-process-reader ] unit-test -[ ] [ "tools.deploy.test.21" drop 800000 small-enough? ] unit-test +[ ] [ "tools.deploy.test.21" drop 1260000 small-enough? ] unit-test [ ] [ "benchmark.ui-panes" shake-and-bake run-temp-image ] unit-test diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor index ab35070ac6..bd05c251de 100644 --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -31,6 +31,8 @@ IN: tools.deploy.macosx [ "org.factor." prepend "CFBundleIdentifier" ,, ] bi [ "Icon.icns" "CFBundleIconFile" ,, ] when + + t "NSHighResolutionCapable" ,, ] H{ } make ; : create-app-plist ( icon? executable bundle-name -- ) @@ -74,7 +76,7 @@ IN: tools.deploy.macosx [ % "/Contents/Resources/" % % ".image" % ] "" make ; : deploy-app-bundle ( vocab -- ) - "resource:" [ + deploy-directory get [ dup deploy-config [ bundle-name dup exists? [ delete-tree ] [ drop ] if [ bundle-name create-app-dir ] keep diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index f25247cd48..47e2256ead 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -558,7 +558,7 @@ SYMBOL: deploy-vocab "Preparing deployed libraries" show deploy-libraries get [ libraries get [ - [ path>> >deployed-library-path ] [ abi>> ] bi + [ path>> >deployed-library-path ] [ abi>> ] bi make-library ] change-at ] each diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index 5372ddf320..db016f15c3 100644 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -9,10 +9,10 @@ IN: tools.deploy.test : shake-and-bake ( vocab -- ) [ test-image temp-file delete-file ] ignore-errors - "resource:" [ + [ [ vm test-image temp-file ] dip dup deploy-config make-deploy-image drop - ] with-directory ; + ] with-resource-directory ; ERROR: image-too-big actual-size max-size ; @@ -21,7 +21,7 @@ ERROR: image-too-big actual-size max-size ; [ cell 4 / * cpu ppc? [ 100000 + ] when - os windows? [ 150000 + ] when + os windows? [ 160000 + ] when ] bi* 2dup <= [ 2drop ] [ image-too-big ] if ; diff --git a/basis/tools/deploy/unix/unix.factor b/basis/tools/deploy/unix/unix.factor index 0b4b58ee66..e8fd2c745b 100644 --- a/basis/tools/deploy/unix/unix.factor +++ b/basis/tools/deploy/unix/unix.factor @@ -14,7 +14,7 @@ IN: tools.deploy.unix deploy-name get ; M: unix deploy* ( vocab -- ) - "resource:" [ + deploy-directory get [ dup deploy-config [ [ bundle-name create-app-dir ] keep [ deployed-image-name ] keep diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 8de593c1fb..0a9cd8d105 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -29,7 +29,7 @@ CONSTANT: app-icon-resource-id "APPICON" [ 2drop ] if ; M: windows deploy* - "resource:" [ + deploy-directory get [ dup deploy-config [ deploy-name get { diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor index 1e8630418c..4f58ae1038 100644 --- a/basis/tools/deprecation/deprecation.factor +++ b/basis/tools/deprecation/deprecation.factor @@ -27,6 +27,7 @@ T{ error-type-holder { icon "vocab:ui/tools/error-list/icons/deprecation-note.tiff" } { quot [ deprecation-notes get values ] } { forget-quot [ deprecation-notes get delete-at ] } + { fatal? f } } define-error-type : ( error word -- deprecation-note ) diff --git a/basis/tools/destructors/destructors-docs.factor b/basis/tools/destructors/destructors-docs.factor index 3491caf462..41e0849052 100644 --- a/basis/tools/destructors/destructors-docs.factor +++ b/basis/tools/destructors/destructors-docs.factor @@ -1,25 +1,34 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax help.tips quotations destructors ; +USING: destructors help.markup help.syntax help.tips quotations sequences ; IN: tools.destructors HELP: disposables. { $description "Print the number of disposable objects of each class." } ; -HELP: leaks +HELP: leaks. { $values { "quot" quotation } } { $description "Runs a quotation, printing any increases in the number of disposable objects after the quotation returns. The " { $link debug-leaks? } " variable is also switched on while the quotation runs, recording the current continuation in every newly-created disposable object." } ; -TIP: "Use the " { $link leaks } " combinator to track down resource leaks." ; +HELP: leaks +{ $values + { "quot" quotation } + { "disposables" sequence } +} +{ $description + "Runs the quotation and collects all disposables leaked by it. Used by " { $link leaks. } "." +} ; + +TIP: "Use the " { $link leaks. } " combinator to track down resource leaks." ; ARTICLE: "tools.destructors" "Destructor tools" "The " { $vocab-link "tools.destructors" } " vocabulary provides words for tracking down resource leaks." { $subsections debug-leaks? disposables. - leaks + leaks. } { $see-also "destructors" } ; diff --git a/basis/tools/destructors/destructors-tests.factor b/basis/tools/destructors/destructors-tests.factor index 24904f76f6..788b67133a 100644 --- a/basis/tools/destructors/destructors-tests.factor +++ b/basis/tools/destructors/destructors-tests.factor @@ -3,11 +3,10 @@ IN: tools.destructors.tests f debug-leaks? set-global -[ [ 3 throw ] leaks ] must-fail +[ [ 3 throw ] leaks. ] must-fail [ f ] [ debug-leaks? get-global ] unit-test -[ ] [ [ ] leaks ] unit-test +[ ] [ [ ] leaks. ] unit-test [ f ] [ debug-leaks? get-global ] unit-test - diff --git a/basis/tools/destructors/destructors.factor b/basis/tools/destructors/destructors.factor index b923c7ba94..d76c242ff5 100644 --- a/basis/tools/destructors/destructors.factor +++ b/basis/tools/destructors/destructors.factor @@ -45,10 +45,13 @@ PRIVATE> [ disposables get members sort-disposables ] dip '[ _ instance? ] filter stack. ; -: leaks ( quot -- ) +: leaks ( quot -- disposables ) disposables get clone t debug-leaks? set-global [ [ call disposables get clone ] dip ] [ f debug-leaks? set-global ] [ ] cleanup - diff (disposables.) ; inline + diff ; inline + +: leaks. ( quot -- ) + leaks (disposables.) ; inline diff --git a/basis/tools/disassembler/udis/udis-tests.factor b/basis/tools/disassembler/udis/udis-tests.factor deleted file mode 100644 index 55e113e1bd..0000000000 --- a/basis/tools/disassembler/udis/udis-tests.factor +++ /dev/null @@ -1,15 +0,0 @@ -IN: tools.disassembler.udis.tests -USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ; - -{ - { - [ cpu x86.32? ] - [ - os windows? - [ [ 624 ] [ ud heap-size ] unit-test ] - [ [ 604 ] [ ud heap-size ] unit-test ] if - ] - } - { [ cpu x86.64? ] [ [ 672 ] [ ud heap-size ] unit-test ] } - [ ] -} cond \ No newline at end of file diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index fb11a5d038..fcda932cb2 100644 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -17,61 +17,7 @@ IN: tools.disassembler.udis LIBRARY: libudis86 -STRUCT: ud_operand - { type int } - { size uchar } - { lval ulonglong } - { base int } - { index int } - { offset uchar } - { scale uchar } ; - -STRUCT: ud - { inp_hook void* } - { inp_curr uchar } - { inp_fill uchar } - { inp_file void* } - { inp_ctr uchar } - { inp_buff c-string } - { inp_buff_end c-string } - { inp_end uchar } - { translator void* } - { insn_offset ulonglong } - { insn_hexcode char[32] } - { insn_buffer char[64] } - { insn_fill uint } - { dis_mode uchar } - { pc ulonglong } - { vendor uchar } - { mapen void* } - { mnemonic int } - { operand ud_operand[3] } - { error uchar } - { pfx_rex uchar } - { pfx_seg uchar } - { pfx_opr uchar } - { pfx_adr uchar } - { pfx_lock uchar } - { pfx_rep uchar } - { pfx_repe uchar } - { pfx_repne uchar } - { pfx_insn uchar } - { default64 uchar } - { opr_mode uchar } - { adr_mode uchar } - { br_far uchar } - { br_near uchar } - { implicit_addr uchar } - { c1 uchar } - { c2 uchar } - { c3 uchar } - { inp_cache uchar[256] } - { inp_sess uchar[64] } - { have_modrm uchar } - { modrm uchar } - { user_opaque_data void* } - { itab_entry void* } - { le void* } ; +TYPEDEF: void ud FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ; @@ -102,7 +48,7 @@ FUNCTION: uint ud_insn_len ( ud* u ) ; FUNCTION: c-string ud_lookup_mnemonic ( int c ) ; : ( -- ud ) - ud malloc-struct &free + 1,000 malloc &free dup ud_init dup cell-bits ud_set_mode dup UD_SYN_INTEL ud_set_syntax ; diff --git a/basis/tools/memory/memory-docs.factor b/basis/tools/memory/memory-docs.factor index 61c51dbf92..3588ac953a 100644 --- a/basis/tools/memory/memory-docs.factor +++ b/basis/tools/memory/memory-docs.factor @@ -51,8 +51,12 @@ HELP: gc-events HELP: data-room { $values { "data-heap-room" data-heap-room } } -{ $description "Queries the VM for memory usage information." } ; +{ $description "Queries the VM for memory usage in the data heap." } ; HELP: code-room { $values { "mark-sweep-sizes" mark-sweep-sizes } } -{ $description "Queries the VM for memory usage information." } ; +{ $description "Queries the VM for memory usage in the code heap." } ; + +HELP: callback-room +{ $values { "mark-sweep-sizes" mark-sweep-sizes } } +{ $description "Queries the VM for memory usage in the callback heap." } ; diff --git a/basis/tools/memory/memory-tests.factor b/basis/tools/memory/memory-tests.factor index 1ea5854939..52c06f4fb0 100644 --- a/basis/tools/memory/memory-tests.factor +++ b/basis/tools/memory/memory-tests.factor @@ -7,3 +7,4 @@ IN: tools.memory.tests [ ] [ gc-events. ] unit-test [ ] [ gc-stats. ] unit-test [ ] [ gc-summary. ] unit-test +[ ] [ callback-room. ] unit-test diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index fd8cd7dda6..7250c47edd 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -291,10 +291,17 @@ PRIVATE> : code-room ( -- mark-sweep-sizes ) (code-room) mark-sweep-sizes memory>struct ; +: callback-room ( -- mark-sweep-sizes ) + (callback-room) mark-sweep-sizes memory>struct ; + : code-room. ( -- ) "== Code heap ==" print nl code-room mark-sweep-table. nl get-code-blocks code-block-stats code-block-table. ; +: callback-room. ( -- ) + "== Callback heap ==" print nl + callback-room mark-sweep-table. ; + : room. ( -- ) - data-room. nl code-room. ; + data-room. nl code-room. nl callback-room. ; diff --git a/basis/tools/profiler/sampling/sampling-tests.factor b/basis/tools/profiler/sampling/sampling-tests.factor index e7490bf024..9a05aadda3 100644 --- a/basis/tools/profiler/sampling/sampling-tests.factor +++ b/basis/tools/profiler/sampling/sampling-tests.factor @@ -11,8 +11,8 @@ TUPLE: boom ; { } [ 10 [ [ 100 [ 1000 random (byte-array) drop ] times compact-gc ] profile ] times ] unit-test { } [ 2 [ [ 1 seconds sleep ] profile ] times ] unit-test -[ ] [ [ 3,000,000 iota [ sq sq sq ] map drop ] profile flat profile. ] unit-test -[ ] [ [ 3,000,000 iota [ sq sq sq ] map drop ] profile top-down profile. ] unit-test +[ ] [ [ 300,000 iota [ sq sq sq ] map drop ] profile flat profile. ] unit-test +[ ] [ [ 300,000 iota [ sq sq sq ] map drop ] profile top-down profile. ] unit-test (clear-samples) f raw-profile-data set-global diff --git a/basis/tools/profiler/sampling/sampling.factor b/basis/tools/profiler/sampling/sampling.factor index d6947f1dad..d90efdaafe 100644 --- a/basis/tools/profiler/sampling/sampling.factor +++ b/basis/tools/profiler/sampling/sampling.factor @@ -1,10 +1,9 @@ ! (c)2011 Joe Groff bsd license -USING: accessors assocs combinators -combinators.short-circuit continuations fry generalizations -hashtables.identity io kernel kernel.private layouts locals -math math.parser math.parser.private math.statistics -math.vectors memory namespaces prettyprint sequences -sequences.generalizations sets sorting ; +USING: accessors assocs combinators combinators.short-circuit +continuations formatting fry generalizations hashtables.identity +io kernel kernel.private layouts locals math math.parser +math.statistics math.vectors memory namespaces prettyprint +sequences sequences.generalizations sets sorting ; FROM: sequences => change-nth ; FROM: assocs => change-at ; IN: tools.profiler.sampling @@ -101,7 +100,9 @@ CONSTANT: zero-counts { 0 0 0 0 0 } ] [ f ] if ; inline :: collect-tops ( samples max-depth depth -- node ) - samples [ drop unclip-callstack ] collect-by [ + samples H{ } clone [ + '[ unclip-callstack _ push-at ] each + ] keep [ [ sum-counts ] [ max-depth depth [ max-depth depth 1 + collect-tops ] (collect-subtrees) ] bi depth @@ -199,10 +200,10 @@ PRIVATE> >alist [ second total-time>> ] inv-sort-with ; : duration. ( duration -- ) - 1000 * >float "%9.1f" format-float write ; + 1000 * "%9.1f" printf ; : percentage. ( num denom -- ) - [ 100 * ] dip /f "%6.2f" format-float write ; + [ 100 * ] dip /f "%6.2f" printf ; DEFER: (profile.) diff --git a/basis/tools/ps/linux/authors.txt b/basis/tools/ps/linux/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/tools/ps/linux/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/tools/ps/linux/linux.factor b/basis/tools/ps/linux/linux.factor new file mode 100644 index 0000000000..6cddf7b678 --- /dev/null +++ b/basis/tools/ps/linux/linux.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2012 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs io.directories io.pathnames kernel +math.parser prettyprint sequences splitting system +tools.ps unix.linux.proc ; +IN: tools.ps.linux + +! If cmdline is empty, read the filename from /proc/pid/stat +: ps-cmdline ( path -- path string ) + dup parse-proc-pid-cmdline [ + dup parse-proc-pid-stat filename>> + [ "()" member? ] trim + "[" "]" surround + ] [ + "\0" split " " join + ] if-empty ; + +M: linux ps ( -- assoc ) + "/proc" [ + "." directory-files + [ file-name string>number ] filter + [ ps-cmdline ] { } map>assoc + ] with-directory ; diff --git a/basis/tools/ps/linux/platforms.txt b/basis/tools/ps/linux/platforms.txt new file mode 100644 index 0000000000..a08e1f35eb --- /dev/null +++ b/basis/tools/ps/linux/platforms.txt @@ -0,0 +1 @@ +linux diff --git a/basis/tools/ps/macosx/authors.txt b/basis/tools/ps/macosx/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/tools/ps/macosx/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/tools/ps/macosx/macosx.factor b/basis/tools/ps/macosx/macosx.factor new file mode 100644 index 0000000000..e2bd4e2912 --- /dev/null +++ b/basis/tools/ps/macosx/macosx.factor @@ -0,0 +1,150 @@ +! Copyright (C) 2013 John Benediktsson +! See http://factorcode.org/license.txt for BSD license + +USING: accessors alien.c-types alien.data alien.syntax arrays +assocs byte-arrays classes.struct continuations fry grouping +kernel libc literals math sequences splitting strings system +system-info.macosx tools.ps unix unix.time unix.types ; + +QUALIFIED-WITH: alien.c-types c + +IN: tools.ps.macosx + +c-array ] [ length ] bi f 0 uint + [ f 0 sysctl io-error ] keep uint deref ; + +STRUCT: _pcred + { pc_lock char[72] } + { pc_ucred void* } + { p_ruid uid_t } + { p_svuid uid_t } + { p_rgid gid_t } + { p_svgid gid_t } + { p_refcnt int } ; + +STRUCT: _ucred + { cr_ref int32_t } + { cr_uid uid_t } + { cr_ngroups c:short } + { cr_groups gid_t[16] } ; + +STRUCT: vmspace + { dummy int32_t } + { dummy2 caddr_t } + { dummy3 int32_t[5] } + { dummy4 caddr_t[3] } ; + +TYPEDEF: int32_t segsz_t +TYPEDEF: uint32_t fixpt_t +TYPEDEF: uint64_t u_quad_t +TYPEDEF: uint32_t sigset_t + +STRUCT: itimerval + { it_interval timeval } + { it_value timeval } ; + +STRUCT: extern_proc + { __p_starttime timeval } + { p_vmspace void* } + { p_sigacts void* } + { p_flag int } + { p_stat char } + { p_pid pid_t } + { p_oppid pid_t } + { p_dupfd int } + { user_stack caddr_t } + { exit_thread void* } + { p_debugger int } + { sigwait boolean_t } + { p_estcpu uint } + { p_cpticks int } + { p_pctcpu fixpt_t } + { p_wchan void* } + { p_wmesg void* } + { p_swtime uint } + { p_slptime uint } + { p_realtimer itimerval } + { p_rtime timeval } + { p_uticks u_quad_t } + { p_sticks u_quad_t } + { p_iticks u_quad_t } + { p_traceflag int } + { p_tracep void* } + { p_siglist int } + { p_textvp void* } + { p_holdcnt int } + { p_sigmask sigset_t } + { p_sigignore sigset_t } + { p_sigcatch sigset_t } + { p_priority uchar } + { p_usrpri uchar } + { p_nice char } + { p_comm char[16] } + { p_pgrp void* } + { p_addr void* } + { p_xstat ushort } + { p_acflag ushort } + { p_ru void* } ; + +STRUCT: kinfo_proc + { kp_proc extern_proc } + { e_paddr void* } + { e_sess void* } + { e_pcred _pcred } + { e_ucred _ucred } + { e_vm vmspace } + { e_ppid pid_t } + { e_pgid pid_t } + { e_joc c:short } + { e_tdev dev_t } + { e_tpgid pid_t } + { e_tsess void* } + { e_mesg char[8] } + { e_xsize segsz_t } + { e_xrssize c:short } + { e_xccount c:short } + { e_xswrss c:short } + { e_flag int32_t } + { e_login char[12] } + { e_spare int32_t[4] } ; + +: head-split-skip ( seq n quot: ( elt -- ? ) -- pieces ) + [ dup 0 >= ] swap '[ + [ _ [ trim-head-slice ] [ split1-when-slice ] bi ] + [ 1 - rot ] bi* + ] produce 2nip ; inline + +: args ( pid -- args ) + [ 1 49 ] dip 0 4array max-arguments sysctl-query + 4 cut-slice swap >byte-array uint deref + [ zero? ] head-split-skip [ >string ] map ; + +: procs ( -- seq ) + { 1 14 0 0 } dup sysctl-query-bytes sysctl-query + kinfo_proc struct-size group + [ kinfo_proc memory>struct ] map ; + +: ps-arg ( kp_proc -- arg ) + [ p_pid>> args rest " " join ] [ + drop p_comm>> 0 over index [ head ] when* >string + ] recover ; + +PRIVATE> + +M: macosx ps ( -- assoc ) + procs [ kp_proc>> p_pid>> 0 > ] filter + [ kp_proc>> [ p_pid>> ] [ ps-arg ] bi ] { } map>assoc ; diff --git a/basis/tools/ps/macosx/platforms.txt b/basis/tools/ps/macosx/platforms.txt new file mode 100644 index 0000000000..6e806f449e --- /dev/null +++ b/basis/tools/ps/macosx/platforms.txt @@ -0,0 +1 @@ +macosx diff --git a/basis/tools/ps/ps.factor b/basis/tools/ps/ps.factor index f0c7125909..ce4b808fcf 100644 --- a/basis/tools/ps/ps.factor +++ b/basis/tools/ps/ps.factor @@ -1,25 +1,15 @@ -! Copyright (C) 2012 Doug Coleman. +! Copyright (C) 2012-2013 Doug Coleman, John Benediktsson. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs io.directories io.pathnames kernel -math.parser prettyprint sequences splitting unix.linux.proc ; +USING: combinators prettyprint sequences sorting system vocabs ; IN: tools.ps -! If cmdline is empty, read the filename from /proc/pid/stat -: ps-cmdline ( path -- path string ) - dup parse-proc-pid-cmdline [ - dup parse-proc-pid-stat filename>> - [ "()" member? ] trim - "[" "]" surround - ] [ - "\0" split " " join - ] if-empty ; +HOOK: ps os ( -- assoc ) -: ps ( -- assoc ) - "/proc" [ - "." directory-files - [ file-name string>number ] filter - [ ps-cmdline ] { } map>assoc - ] with-directory ; +{ + { [ os macosx? ] [ "tools.ps.macosx" ] } + { [ os linux? ] [ "tools.ps.linux" ] } + { [ os windows? ] [ "tools.ps.windows" ] } +} cond require : ps. ( -- ) - ps simple-table. ; + ps sort-keys { "PID" "CMD" } prefix simple-table. ; diff --git a/basis/tools/ps/summary.txt b/basis/tools/ps/summary.txt index b6c670821b..19af4b04cd 100644 --- a/basis/tools/ps/summary.txt +++ b/basis/tools/ps/summary.txt @@ -1 +1 @@ -A basic ps utility for Linux. +Process listing utility diff --git a/basis/tools/ps/windows/platforms.txt b/basis/tools/ps/windows/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/basis/tools/ps/windows/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/basis/tools/ps/windows/windows.factor b/basis/tools/ps/windows/windows.factor new file mode 100644 index 0000000000..e169befe24 --- /dev/null +++ b/basis/tools/ps/windows/windows.factor @@ -0,0 +1,92 @@ +USING: accessors alien alien.c-types alien.data alien.syntax +arrays byte-arrays classes.struct destructors fry io +io.encodings.string io.encodings.utf16n kernel literals locals +math nested-comments sequences strings system tools.ps +windows.errors windows.handles windows.kernel32 windows.ntdll +windows.types ; +IN: tools.ps.windows + +: do-snapshot ( snapshot-type -- handle ) + 0 CreateToolhelp32Snapshot dup win32-error=0/f ; + +: default-process-entry ( -- obj ) + PROCESSENTRY32 PROCESSENTRY32 heap-size >>dwSize ; + +: first-process ( handle -- PROCESSENTRY32 ) + default-process-entry + [ Process32First win32-error=0/f ] keep ; + +: next-process ( handle -- PROCESSENTRY32/f ) + default-process-entry [ Process32Next ] keep swap + FALSE = [ drop f ] when ; + +: open-process-read ( dwProcessId -- HANDLE ) + [ + flags{ PROCESS_QUERY_INFORMATION PROCESS_VM_READ } + FALSE + ] dip OpenProcess ; + +: query-information-process ( HANDLE -- PROCESS_BASIC_INFORMATION ) + 0 + PROCESS_BASIC_INFORMATION [ + dup byte-length + f + NtQueryInformationProcess drop + ] keep ; + +:: read-process-memory ( HANDLE alien offset len -- byte-array ) + HANDLE + offset alien + len dup :> ba + len + f + ReadProcessMemory win32-error=0/f + ba ; + +: read-peb ( handle address -- peb ) + 0 PEB heap-size read-process-memory PEB memory>struct ; + +: my-peb ( -- peb ) + GetCurrentProcessId [ + open-process-read + [ &dispose drop ] + [ dup query-information-process PebBaseAddress>> read-peb ] bi + ] with-destructors ; + +:: read-args ( handle -- string/f ) + handle &dispose drop + handle query-information-process :> process-basic-information + handle process-basic-information PebBaseAddress>> + [ + "ProcessParameters" PEB offset-of + PVOID heap-size + read-process-memory + PVOID deref :> args-offset + args-offset ALIEN: 0 = [ + f + ] [ + handle + args-offset + "CommandLine" RTL_USER_PROCESS_PARAMETERS offset-of + UNICODE_STRING heap-size + read-process-memory + [ handle ] dip + UNICODE_STRING deref [ Buffer>> 0 ] [ Length>> ] bi read-process-memory + utf16n decode + ] if + ] [ drop f ] if* ; + +: process-list ( -- assoc ) + [ + TH32CS_SNAPALL do-snapshot + [ &dispose drop ] + [ first-process ] + [ '[ drop _ next-process ] follow ] tri + [ + [ th32ProcessID>> ] + [ th32ProcessID>> open-process-read dup [ read-args ] when ] + [ szExeFile>> [ 0 = ] trim-tail >string or ] tri 2array + ] map + ] with-destructors ; + +M: windows ps ( -- assoc ) process-list ; diff --git a/basis/tools/scaffold/scaffold-docs.factor b/basis/tools/scaffold/scaffold-docs.factor index 271b74b9f7..c070e5ec71 100644 --- a/basis/tools/scaffold/scaffold-docs.factor +++ b/basis/tools/scaffold/scaffold-docs.factor @@ -21,7 +21,50 @@ HELP: scaffold-undocumented { "string" string } } { $description "Prints scaffolding documentation for undocumented words in a vocabulary except for automatically generated class predicates." } ; -{ scaffold-docs scaffold-undocumented } related-words +{ scaffold-docs scaffold-undocumented scaffold-examples } related-words + +HELP: scaffold-examples +{ $values + { "word" word } +} +{ $description "Create some examples for a word with a using list that includes vocabularies the word is in and the " { $vocab-link "prettyprint" } " vocabulary. You are then expected to change the header " { $snippet "Example:" } " to something more descriptive." } +{ $examples + "Create docs for the + word:" + { $example "USING: math tools.scaffold prettyprint ;" + "\\ + scaffold-examples" + """{ $examples + "Example:" + { $example "USING: math prettyprint ;" + "" + "" + } + "Example:" + { $example "USING: math prettyprint ;" + "" + "" + } +}""" + } +} ; + +HELP: scaffold-core +{ $values + { "string" string } +} +{ $description "Create a placeholder vocabulary in the core vocabulary root." } ; + +HELP: scaffold-basis +{ $values + { "string" string } +} +{ $description "Create a placeholder vocabulary in the basis vocabulary root." } ; + +HELP: scaffold-extra +{ $values + { "string" string } +} +{ $description "Create a placeholder vocabulary in the extra vocabulary root." } ; + HELP: scaffold-authors { $values @@ -77,11 +120,13 @@ ARTICLE: "tools.scaffold" "Scaffold tool" "Scaffold setup:" { $subsections developer-name } "Generate new vocabs:" -{ $subsections scaffold-vocab } +{ $subsections scaffold-vocab scaffold-core scaffold-basis scaffold-extra } "Generate help scaffolding:" { $subsections scaffold-docs scaffold-undocumented + scaffold-examples + scaffold-n-examples help. } "Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead." $nl diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 7009636107..d95af0fd68 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs io.files io.pathnames io.directories -io.encodings.utf8 hashtables kernel namespaces sequences -vocabs.loader vocabs.metadata 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 timers -words.symbol system summary ; +USING: accessors alien arrays assocs calendar classes +combinators combinators.short-circuit fry hashtables interpolate +io io.directories io.encodings.utf8 io.files io.pathnames +io.streams.string kernel math math.parser namespaces prettyprint +quotations sequences sets sorting splitting strings system +timers unicode.categories urls vocabs vocabs.loader +vocabs.metadata words words.symbol ; FROM: sets => members ; IN: tools.scaffold @@ -144,23 +144,26 @@ ERROR: vocab-name-contains-dot path ; : add-using ( object -- ) vocabulary>> using get [ adjoin ] [ drop ] if* ; -: ($values.) ( array -- ) - [ bl ] [ - "{ " write - dup array? [ first ] when - dup lookup-type [ - [ unparse write bl ] - [ [ pprint ] [ dup string? [ drop ] [ add-using ] if ] bi ] bi* - ] [ - drop unparse write bl null pprint - null add-using - ] if - " }" write - ] interleave ; - : 4bl ( -- ) " " write ; inline +: ($values.) ( array -- ) + [ + 4bl + [ bl ] [ + "{ " write + dup array? [ first ] when + dup lookup-type [ + [ unparse write bl ] + [ [ pprint ] [ dup string? [ drop ] [ add-using ] if ] bi ] bi* + ] [ + drop unparse write bl null pprint + null add-using + ] if + " }" write + ] interleave + ] unless-empty ; + : ?print-nl ( seq1 seq2 -- ) [ empty? ] either? [ nl ] unless ; @@ -172,9 +175,9 @@ ERROR: vocab-name-contains-dot path ; ] [ [ members ] dip over diff "{ $values" print - [ drop 4bl ($values.) ] + [ drop ($values.) ] [ ?print-nl ] - [ nip 4bl ($values.) ] 2tri + [ nip ($values.) ] 2tri nl "}" print ] if ] when* ; @@ -313,23 +316,36 @@ PRIVATE> 2drop ] if ; -SYMBOL: examples-flag +SYMBOL: nested-examples -: example ( -- ) - { - "{ $example \"\" \"USING: prettyprint ;\"" - " \"\"" - " \"\"" - "}" - } [ examples-flag get [ 4bl ] when print ] each ; +: example-using ( using -- ) + " " join "example-using" [ + nested-examples get 4 0 ? CHAR: \s "example-indent" [ + """${example-indent}"Example:" +${example-indent}{ $example "USING: ${example-using} ;" +${example-indent} "" +${example-indent} "" +${example-indent}} +""" + interpolate + ] with-variable + ] with-variable ; -: examples ( n -- ) - t \ examples-flag [ - "{ $examples " print - [ example ] times +: n-examples-using ( n using -- ) + '[ _ example-using ] times ; + +: scaffold-n-examples ( n word -- ) + vocabulary>> "prettyprint" 2array + [ t nested-examples ] 2dip + '[ + "{ $examples" print + _ _ n-examples-using "}" print ] with-variable ; +: scaffold-examples ( word -- ) + 2 swap scaffold-n-examples ; + : touch. ( path -- ) [ touch-file ] [ "Click to edit: " write . ] bi ; @@ -343,6 +359,9 @@ SYMBOL: examples-flag : scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ; +: scaffold-mason-rc ( -- ) + ".factor-mason-rc" scaffold-rc ; + : scaffold-factor-roots ( -- ) ".factor-roots" scaffold-rc ; diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor index e1e9068722..dcc029931a 100644 --- a/basis/tools/test/test-docs.factor +++ b/basis/tools/test/test-docs.factor @@ -63,7 +63,7 @@ HELP: must-fail { $notes "This word is used to test boundary conditions and fail-fast behavior." } ; HELP: must-fail-with -{ $values { "quot" "a quotation run with an empty stack" } { "pred" { $quotation "( error -- ? )" } } } +{ $values { "quot" "a quotation run with an empty stack" } { "pred" { $quotation ( error -- ? ) } } } { $description "Runs a quotation with an empty stack, expecting it to throw an error which must satisfy " { $snippet "pred" } ". If the quotation does not throw an error, or if the error does not match the predicate, the unit test fails." } { $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 4a82a9eed4..b559bf3977 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -1,14 +1,13 @@ ! Copyright (C) 2003, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs combinators compiler.units -continuations debugger effects fry generalizations -sequences.generalizations io io.files io.styles kernel lexer -locals macros math.parser namespaces parser vocabs.parser -prettyprint quotations sequences source-files splitting -stack-checker summary unicode.case vectors vocabs vocabs.loader -vocabs.files vocabs.metadata words tools.errors -source-files.errors source-files.errors.debugger io.streams.string -make compiler.errors ; +USING: accessors arrays assocs combinators command-line +compiler.units continuations debugger effects fry +generalizations io kernel lexer locals macros namespaces parser +prettyprint quotations sequences sequences.generalizations +source-files source-files.errors source-files.errors.debugger +splitting stack-checker summary tools.errors unicode.case vocabs +vocabs.files vocabs.metadata vocabs.parser words ; +FROM: vocabs.hierarchy => load ; IN: tools.test TUPLE: test-failure < source-file-error continuation ; @@ -171,3 +170,7 @@ M: test-failure error. ( error -- ) : test-all ( -- ) vocabs filter-don't-test test-vocabs ; +: test-main ( -- ) + command-line get [ [ load ] [ test ] bi ] each ; + +MAIN: test-main diff --git a/basis/tools/walker/walker-docs.factor b/basis/tools/walker/walker-docs.factor index 6571afc64a..94c1a7790d 100644 --- a/basis/tools/walker/walker-docs.factor +++ b/basis/tools/walker/walker-docs.factor @@ -11,7 +11,7 @@ HELP: breakpoint } ; HELP: breakpoint-if -{ $values { "word" word } { "quot" { $quotation "( -- ? )" } } } +{ $values { "word" word } { "quot" { $quotation ( -- ? ) } } } { $description "Annotates a word definition to enter the single stepper if the quotation yields true. The quotation has access to the datastack as it exists just before " { $snippet "word" } " is called." } { $examples "Break if the input to sq is 3:" diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor index 433ac3b5bf..2c255e388c 100644 --- a/basis/typed/typed-tests.factor +++ b/basis/typed/typed-tests.factor @@ -13,8 +13,12 @@ TYPED: f+ ( a: float b: float -- c: float ) TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum ) + ; -most-positive-fixnum neg 1 - 1quotation -[ most-positive-fixnum 1 fix+ ] unit-test +! XXX: As of .97, we don't require that the output is a fixnum. +! most-positive-fixnum neg 1 - 1quotation +! [ most-positive-fixnum 1 fix+ ] unit-test + +! XXX: Check that we throw an error. This used to underflow to the least-positive-fixnum. +[ most-positive-fixnum 1 fix+ ] [ { "kernel-error" 7 } head? ] must-fail-with TUPLE: tweedle-dee ; final TUPLE: tweedle-dum ; final diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index 1a368c9446..a492a9b567 100644 --- a/basis/typed/typed.factor +++ b/basis/typed/typed.factor @@ -1,7 +1,7 @@ ! (c)Joe Groff bsd license USING: accessors arrays classes classes.tuple combinators -combinators.short-circuit definitions effects fry hints -math kernel kernel.private namespaces parser quotations +combinators.short-circuit definitions effects fry generalizations +hints math kernel kernel.private namespaces parser quotations sequences slots words locals effects.parser locals.parser macros stack-checker.dependencies classes.maybe classes.algebra ; @@ -52,7 +52,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ; compose compose ; : make-unboxer ( error-quot word types -- quot ) - dup [ unboxer ] with with with + dup [ unboxer ] 3 nwith [ swap \ dip [ ] 2sequence prepend ] map-reduce ; : (unboxed-types) ( type -- types ) @@ -128,7 +128,7 @@ M: typed-gensym where parent-word where ; [ 2nip ] 3tri define-declared ; MACRO: typed ( quot word effect -- quot' ) - [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] + [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ] [ nip effect-out-types dup typed-stack-effect? [ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if @@ -152,7 +152,7 @@ M: typed-word subwords PRIVATE> : define-typed ( word def effect -- ) - [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ] + [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ] [ drop "typed-def" set-word-prop ] [ 2drop "typed-word" word-prop set-last-word ] 3tri ; diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 2cea326826..5d56003e15 100644 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: command-line kernel namespaces opengl opengl.gl fry ; +USING: command-line kernel namespaces ; IN: ui.backend SYMBOL: ui-backend diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index d700df398c..9674a72892 100644 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -112,6 +112,8 @@ M: cocoa-ui-backend (set-fullscreen) ( world ? -- ) M: cocoa-ui-backend (fullscreen?) ( world -- ? ) handle>> view>> -> isInFullScreenMode zero? not ; +! XXX: Until someone tests OSX with a tiling window manager, +! dialog-window is the same as normal-title-window CONSTANT: window-control>styleMask H{ { close-button $ NSClosableWindowMask } @@ -119,8 +121,9 @@ CONSTANT: window-control>styleMask { maximize-button 0 } { resize-handles $ NSResizableWindowMask } { small-title-bar $[ NSTitledWindowMask NSUtilityWindowMask bitor ] } - { normal-title-bar $ NSTitledWindowMask } { textured-background $ NSTexturedBackgroundWindowMask } + { normal-title-bar $ NSTitledWindowMask } + { dialog-window $ NSTitledWindowMask } } : world>styleMask ( world -- n ) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index c8b6f88d9c..0c0d37af94 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -2,12 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.data alien.strings arrays assocs cocoa cocoa.application cocoa.classes -cocoa.messages cocoa.pasteboard cocoa.runtime cocoa.subclassing -cocoa.types cocoa.views combinators core-foundation.strings -core-graphics core-graphics.types core-text io.encodings.utf8 -kernel locals math math.rectangles namespaces opengl sequences -threads ui.gadgets ui.gadgets.private ui.gadgets.worlds -ui.gestures ui.private ; +cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types +cocoa.views combinators core-foundation.strings core-graphics +core-graphics.types core-text io.encodings.utf8 kernel locals +math math.rectangles namespaces opengl sequences threads +ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures +ui.private ; IN: ui.backend.cocoa.views : send-mouse-moved ( view event -- ) @@ -16,7 +16,11 @@ IN: ui.backend.cocoa.views : button ( event -- n ) #! Cocoa -> Factor UI button mapping - -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ; + -> buttonNumber { + { 0 [ 1 ] } + { 1 [ 3 ] } + { 2 [ 2 ] } + } case ; CONSTANT: modifiers { @@ -154,12 +158,15 @@ CLASS: FactorView < NSOpenGLView NSTextInput self SEL: setWantsBestResolutionOpenGLSurface: -> respondsToSelector: c-bool> [ - self SEND: setWantsBestResolutionOpenGLSurface: - 1 swap execute( x x x -- ) + self SEL: setWantsBestResolutionOpenGLSurface: 1 + void f "objc_msgSend" { id SEL char } alien-invoke + + self SEL: backingScaleFactor + double f "objc_msgSend" { id SEL } alien-invoke - self SEND: backingScaleFactor execute( x x -- x ) dup 1.0 > [ gl-scale-factor set-global t retina? set-global + cached-lines get-global clear-assoc ] [ drop ] if ] when @@ -390,6 +397,20 @@ CLASS: FactorWindowDelegate < NSObject notification -> object -> contentView [ window ungraft ] [ unregister-window ] bi ] + + METHOD: void windowDidChangeBackingProperties: id notification + [ + + notification -> object dup SEL: backingScaleFactor + -> respondsToSelector: c-bool> [ + + SEL: backingScaleFactor + double f "objc_msgSend" { id SEL } alien-invoke + + [ [ 1.0 > ] keep f ? gl-scale-factor set-global ] + [ 1.0 > retina? set-global ] bi + ] [ drop ] if + ] ] : install-window-delegate ( window -- ) diff --git a/basis/ui/backend/gtk/gtk.factor b/basis/ui/backend/gtk/gtk.factor index adcad20e0e..87846ffe78 100644 --- a/basis/ui/backend/gtk/gtk.factor +++ b/basis/ui/backend/gtk/gtk.factor @@ -60,22 +60,18 @@ M: gtk-clipboard set-clipboard-contents ! Timer -SYMBOL: next-fire-time - : set-timeout*-value ( alien value -- ) swap 0 set-alien-signed-4 ; inline : timer-prepare ( source timeout* -- ? ) - nip next-fire-time get-global nano-count [-] + nip sleep-time 1,000,000,000 or [ 1,000,000 /i set-timeout*-value ] keep 0 = ; : timer-check ( source -- ? ) - drop next-fire-time get-global nano-count [-] 0 = ; + drop sleep-time 0 = ; : timer-dispatch ( source callback user_data -- ? ) - 3drop sleep-time [ 1,000,000,000 ] unless* nano-count + - next-fire-time set-global - yield t ; + 3drop yield t ; : ( -- timer-funcs ) GSourceFuncs malloc-struct @@ -84,7 +80,6 @@ SYMBOL: next-fire-time [ timer-dispatch ] GSourceFuncsDispatchFunc >>dispatch ; :: with-timer ( quot -- ) - nano-count next-fire-time set-global &free GSource heap-size g_source_new &g_source_unref :> source source f g_source_attach drop @@ -361,6 +356,7 @@ CONSTANT: window-controls>decor-flags { small-title-bar $ GDK_DECOR_TITLE } { normal-title-bar $ GDK_DECOR_TITLE } { textured-background 0 } + { dialog-window 0 } } CONSTANT: window-controls>func-flags @@ -372,13 +368,19 @@ CONSTANT: window-controls>func-flags { small-title-bar 0 } { normal-title-bar 0 } { textured-background 0 } + { dialog-window 0 } } +: set-window-hint ( win controls -- ) + { + { [ dialog-window over member-eq? ] [ drop GDK_WINDOW_TYPE_HINT_DIALOG ] } + { [ small-title-bar over member-eq? ] [ drop GDK_WINDOW_TYPE_HINT_UTILITY ] } + [ drop GDK_WINDOW_TYPE_HINT_NORMAL ] + } cond gtk_window_set_type_hint ; + : configure-window-controls ( win controls -- ) [ - small-title-bar swap member-eq? - GDK_WINDOW_TYPE_HINT_UTILITY GDK_WINDOW_TYPE_HINT_NORMAL ? - gtk_window_set_type_hint + set-window-hint ] [ [ gtk_widget_get_window ] dip window-controls>decor-flags symbols>flags @@ -465,14 +467,13 @@ M:: gtk-ui-backend (open-window) ( world -- ) gtk_window_set_wmclass world configure-gl - - win gtk_widget_realize - win world window-controls>> configure-window-controls - win im configure-im win connect-user-input-signals win connect-win-state-signals + win gtk_widget_realize + win world window-controls>> configure-window-controls + win gtk_widget_show_all ; M: gtk-ui-backend (close-window) ( handle -- ) @@ -552,4 +553,3 @@ os unix? os macosx? not and [ M: gtk-ui-backend ui-backend-available? "DISPLAY" os-env >boolean ; - diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 15ee943c15..563ab5e44d 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -237,6 +237,7 @@ CONSTANT: window-control>style { resize-handles $ WS_THICKFRAME } { small-title-bar $ WS_CAPTION } { normal-title-bar $ WS_CAPTION } + { dialog-window 0 } } CONSTANT: window-control>ex-style @@ -248,6 +249,7 @@ CONSTANT: window-control>ex-style { resize-handles $ WS_EX_WINDOWEDGE } { small-title-bar $[ WS_EX_TOOLWINDOW WS_EX_TOPMOST bitor ] } { normal-title-bar $ WS_EX_APPWINDOW } + { dialog-window 0 } } : needs-sysmenu? ( controls -- ? ) @@ -611,7 +613,7 @@ SYMBOL: trace-messages? ! return 0 if you handle the message, else just let DefWindowProc return its val : ui-wndproc ( -- object ) - c:uint { c:void* c:uint c:long c:long } stdcall [ + c:uint { c:void* c:uint WPARAM LPARAM } stdcall [ pick trace-messages? get-global diff --git a/basis/ui/clipboards/clipboards-docs.factor b/basis/ui/clipboards/clipboards-docs.factor index de6a5ac97c..675f61dbd2 100644 --- a/basis/ui/clipboards/clipboards-docs.factor +++ b/basis/ui/clipboards/clipboards-docs.factor @@ -1,4 +1,5 @@ -USING: ui.gadgets ui.gestures help.markup help.syntax strings ; +USING: help.markup help.syntax kernel strings ui.gadgets +ui.gestures ; IN: ui.clipboards HELP: clipboard @@ -6,11 +7,11 @@ HELP: clipboard { $class-description "A mutable container for a single string implementing the " { $link "clipboard-protocol" } "." } ; HELP: paste-clipboard -{ $values { "gadget" gadget } { "clipboard" "an object" } } +{ $values { "gadget" gadget } { "clipboard" object } } { $contract "Arranges for the contents of the clipboard to be inserted into the gadget at some point in the near future via a call to " { $link user-input } ". The gadget must be grafted." } ; HELP: copy-clipboard -{ $values { "string" string } { "gadget" gadget } { "clipboard" "an object" } } +{ $values { "string" string } { "gadget" gadget } { "clipboard" object } } { $contract "Arranges for the string to be copied to the clipboard on behalf of the gadget. The gadget must be grafted." } ; HELP: selection diff --git a/basis/ui/event-loop/event-loop.factor b/basis/ui/event-loop/event-loop.factor index f054d2b404..0d8aaf46e5 100644 --- a/basis/ui/event-loop/event-loop.factor +++ b/basis/ui/event-loop/event-loop.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: calendar combinators deques kernel namespaces sequences -threads ui ui.private ui.backend ui.gadgets ui.gadgets.private ; +threads ui.backend ui.gadgets.private ui.private ; IN: ui.event-loop : event-loop? ( -- ? ) diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor index f39d45b978..3fb40b90a6 100644 --- a/basis/ui/gadgets/buttons/buttons-docs.factor +++ b/basis/ui/gadgets/buttons/buttons-docs.factor @@ -12,19 +12,19 @@ $nl "A button can optionally display a message in the window's status bar whenever the mouse cursor hovers over the button. To enable this behavior, just set a string to the button's " { $snippet "tooltip" } " slot." } ; HELP: