diff --git a/.gitignore b/.gitignore index a7cbeeeef3..05a53c02c6 100644 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,4 @@ work build-support/wordsize *.bak .#* +*.swo diff --git a/Makefile b/Makefile index ffcbf6364c..b41e756729 100644 --- a/Makefile +++ b/Makefile @@ -3,6 +3,7 @@ AR = ar LD = ld EXECUTABLE = factor +CONSOLE_EXECUTABLE = factor-console VERSION = 0.92 IMAGE = factor.image @@ -25,23 +26,25 @@ ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/alien.o \ vm/bignum.o \ + vm/callstack.o \ + vm/code_block.o \ + vm/code_gc.o \ vm/code_heap.o \ + vm/data_gc.o \ + vm/data_heap.o \ vm/debug.o \ + vm/errors.o \ vm/factor.o \ vm/ffi_test.o \ vm/image.o \ vm/io.o \ vm/math.o \ - vm/data_gc.o \ - vm/code_gc.o \ vm/primitives.o \ - vm/run.o \ - vm/callstack.o \ - vm/types.o \ + vm/profiler.o \ vm/quotations.o \ - vm/utilities.o \ - vm/errors.o \ - vm/profiler.o + vm/run.o \ + vm/types.o \ + vm/utilities.o EXE_OBJS = $(PLAF_EXE_OBJS) @@ -136,9 +139,11 @@ zlib1.dll: winnt-x86-32: freetype6.dll zlib1.dll $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 + $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 winnt-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 + $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 wince-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm @@ -159,6 +164,11 @@ factor: $(DLL_OBJS) $(EXE_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) +factor-console: $(DLL_OBJS) $(EXE_OBJS) + $(LINKER) $(ENGINE) $(DLL_OBJS) + $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ + $(CFLAGS) $(CFLAGS_CONSOLE) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) + clean: rm -f vm/*.o rm -f factor*.dll libfactor.{a,so,dylib} diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 9cd9050ea8..4da06ec4c9 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -15,7 +15,7 @@ IN: alien.remote-control "void" { "long" } "cdecl" [ sleep ] alien-callback ; : ?callback ( word -- alien ) - dup compiled>> [ execute ] [ drop f ] if ; inline + dup optimized>> [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) \ eval-callback ?callback 16 setenv diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor index 4c783e609c..b2bbc16836 100644 --- a/basis/ascii/ascii-docs.factor +++ b/basis/ascii/ascii-docs.factor @@ -57,8 +57,10 @@ HELP: >upper { $values { "str" "a string" } { "upper" "a string" } } { $description "Converts an ASCII string to upper case." } ; -ARTICLE: "ascii" "ASCII character classes" -"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:" +ARTICLE: "ascii" "ASCII" +"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead." +$nl +"ASCII character classes:" { $subsection blank? } { $subsection letter? } { $subsection LETTER? } @@ -67,11 +69,10 @@ ARTICLE: "ascii" "ASCII character classes" { $subsection control? } { $subsection quotable? } { $subsection ascii? } -"ASCII case conversion is also implemented:" +"ASCII case conversion:" { $subsection ch>lower } { $subsection ch>upper } { $subsection >lower } -{ $subsection >upper } -"Modern applications should use Unicode 5.1 instead (" { $vocab-link "unicode.categories" } ")." ; +{ $subsection >upper } ; ABOUT: "ascii" diff --git a/basis/ascii/ascii.factor b/basis/ascii/ascii.factor index a64a7b8eb5..193e847d27 100644 --- a/basis/ascii/ascii.factor +++ b/basis/ascii/ascii.factor @@ -1,41 +1,23 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.order sequences -combinators.short-circuit ; +USING: kernel math math.order sequences strings +combinators.short-circuit hints ; IN: ascii : ascii? ( ch -- ? ) 0 127 between? ; inline - : blank? ( ch -- ? ) " \t\n\r" member? ; inline - : letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline - : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline - : digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline - : printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline +: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline +: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline +: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline +: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline +: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ; inline +: >lower ( str -- lower ) [ ch>lower ] map ; +: ch>upper ( ch -- upper ) dup letter? [ HEX: 20 - ] when ; inline +: >upper ( str -- upper ) [ ch>upper ] map ; -: control? ( ch -- ? ) - "\0\e\r\n\t\u000008\u00007f" member? ; inline - -: quotable? ( ch -- ? ) - dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline - -: Letter? ( ch -- ? ) - [ [ letter? ] [ LETTER? ] ] 1|| ; - -: alpha? ( ch -- ? ) - [ [ Letter? ] [ digit? ] ] 1|| ; - -: ch>lower ( ch -- lower ) - dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ; - -: >lower ( str -- lower ) - [ ch>lower ] map ; - -: ch>upper ( ch -- upper ) - dup CHAR: a CHAR: z between? [ HEX: 20 - ] when ; - -: >upper ( str -- upper ) - [ ch>upper ] map ; +HINTS: >lower string ; +HINTS: >upper string ; \ No newline at end of file diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor index e5972991e5..7f96e19430 100644 --- a/basis/base64/base64.factor +++ b/basis/base64/base64.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators io io.binary io.encodings.binary io.streams.byte-array io.streams.string kernel math namespaces -sequences strings ; +sequences strings io.crlf ; IN: base64 > not ] filter compile ; +: compile-unoptimized ( words -- ) + [ optimized>> not ] filter compile ; nl "Compiling..." write flush @@ -48,70 +48,70 @@ nl wrap probe namestack* -} compile-uncompiled +} compile-unoptimized "." write flush { bitand bitor bitxor bitnot -} compile-uncompiled +} compile-unoptimized "." write flush { + 1+ 1- 2/ < <= > >= shift -} compile-uncompiled +} compile-unoptimized "." write flush { new-sequence nth push pop peek flip -} compile-uncompiled +} compile-unoptimized "." write flush { hashcode* = get set -} compile-uncompiled +} compile-unoptimized "." write flush { memq? split harvest sift cut cut-slice start index clone set-at reverse push-all class number>string string>number -} compile-uncompiled +} compile-unoptimized "." write flush { lines prefix suffix unclip new-assoc update word-prop set-word-prop 1array 2array 3array ?nth -} compile-uncompiled +} compile-unoptimized "." write flush { malloc calloc free memcpy -} compile-uncompiled +} compile-unoptimized "." write flush -{ build-tree } compile-uncompiled +{ build-tree } compile-unoptimized "." write flush -{ optimize-tree } compile-uncompiled +{ optimize-tree } compile-unoptimized "." write flush -{ optimize-cfg } compile-uncompiled +{ optimize-cfg } compile-unoptimized "." write flush -{ (compile) } compile-uncompiled +{ (compile) } compile-unoptimized "." write flush -vocabs [ words compile-uncompiled "." write flush ] each +vocabs [ words compile-unoptimized "." write flush ] each " done" print flush diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index bbd7df9108..221ffffb91 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays generic assocs hashtables assocs hashtables.private io io.binary io.files io.encodings.binary @@ -10,7 +10,7 @@ classes.tuple.private words.private vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators math.order math.private accessors -slots.private compiler.units ; +slots.private compiler.units fry ; IN: bootstrap.image : arch ( os cpu -- arch ) @@ -73,7 +73,7 @@ SYMBOL: objects : put-object ( n obj -- ) (objects) set-at ; : cache-object ( obj quot -- value ) - [ (objects) ] dip [ obj>> ] prepose cache ; inline + [ (objects) ] dip '[ obj>> @ ] cache ; inline ! Constants @@ -95,7 +95,7 @@ SYMBOL: objects SYMBOL: sub-primitives : make-jit ( quot rc rt offset -- quad ) - { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline + [ { } make ] 3dip 4array ; inline : jit-define ( quot rc rt offset name -- ) [ make-jit ] dip set ; inline @@ -344,25 +344,37 @@ M: wrapper ' [ emit ] emit-object ; ! Strings +: native> ( object -- object ) + big-endian get [ [ be> ] map ] [ [ le> ] map ] if ; + : emit-bytes ( seq -- ) - bootstrap-cell - big-endian get [ [ be> ] map ] [ [ le> ] map ] if - emit-seq ; + bootstrap-cell native> emit-seq ; : pad-bytes ( seq -- newseq ) - dup length bootstrap-cell align 0 pad-right ; + dup length bootstrap-cell align 0 pad-tail ; -: check-string ( string -- ) - [ 127 > ] contains? - [ "Bootstrap cannot emit non-ASCII strings" throw ] when ; +: extended-part ( str -- str' ) + dup [ 128 < ] all? [ drop f ] [ + [ -7 shift 1 bitxor ] { } map-as + big-endian get + [ [ 2 >be ] { } map-as ] + [ [ 2 >le ] { } map-as ] if + B{ } join + ] if ; + +: ascii-part ( str -- str' ) + [ + [ 128 mod ] [ 128 >= ] bi + [ 128 bitor ] when + ] B{ } map-as ; : emit-string ( string -- ptr ) - dup check-string + [ length ] [ extended-part ' ] [ ] tri string type-number object tag-number [ - dup length emit-fixnum - f ' emit - f ' emit - pad-bytes emit-bytes + [ emit-fixnum ] + [ emit ] + [ f ' emit ascii-part pad-bytes emit-bytes ] + tri* ] emit-object ; M: string ' @@ -433,7 +445,7 @@ M: quotation ' array>> ' quotation type-number object tag-number [ emit ! array - f ' emit ! compiled>> + f ' emit ! compiled 0 emit ! xt 0 emit ! code ] emit-object @@ -524,11 +536,9 @@ M: quotation ' ! Image output : (write-image) ( image -- ) - bootstrap-cell big-endian get [ - [ >be write ] curry each - ] [ - [ >le write ] curry each - ] if ; + bootstrap-cell big-endian get + [ '[ _ >be write ] each ] + [ '[ _ >le write ] each ] if ; : write-image ( image -- ) "Writing image to " write diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index f0622726f5..b521244fe0 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -13,7 +13,7 @@ SYMBOL: core-bootstrap-time SYMBOL: bootstrap-time : default-image-name ( -- string ) - vm file-name os windows? [ "." split1 drop ] when + vm file-name os windows? [ "." split1-last drop ] when ".image" append resource-path ; : do-crossref ( -- ) @@ -42,7 +42,7 @@ SYMBOL: bootstrap-time "Core bootstrap completed in " write core-bootstrap-time get print-time "Bootstrap completed in " write bootstrap-time get print-time - [ compiled>> ] count-words " compiled words" print + [ optimized>> ] count-words " compiled words" print [ symbol? ] count-words " symbol words" print [ ] count-words " words total" print diff --git a/basis/bootstrap/unicode/unicode.factor b/basis/bootstrap/unicode/unicode.factor index e69de29bb2..3530c9d99f 100644 --- a/basis/bootstrap/unicode/unicode.factor +++ b/basis/bootstrap/unicode/unicode.factor @@ -0,0 +1 @@ +USE: unicode \ No newline at end of file diff --git a/basis/cairo/gadgets/gadgets.factor b/basis/cairo/gadgets/gadgets.factor index 131f7425c9..87942b4c91 100644 --- a/basis/cairo/gadgets/gadgets.factor +++ b/basis/cairo/gadgets/gadgets.factor @@ -2,19 +2,26 @@ ! See http://factorcode.org/license.txt for BSD license. USING: sequences math kernel byte-arrays cairo.ffi cairo io.backend ui.gadgets accessors opengl.gl arrays fry -classes ui.render namespaces ; - +classes ui.render namespaces destructors libc ; IN: cairo.gadgets +stride ( width -- stride ) 4 * ; + +: image-dims ( gadget -- width height stride ) + dim>> first2 over width>stride ; inline +: image-buffer ( width height stride -- alien ) + * nip malloc ; inline +PRIVATE> GENERIC: render-cairo* ( gadget -- ) -: render-cairo ( gadget -- byte-array ) - dup dim>> first2 over width>stride - [ * nip dup CAIRO_FORMAT_ARGB32 ] - [ cairo_image_surface_create_for_data ] 3bi - rot '[ _ render-cairo* ] with-cairo-from-surface ; inline +: render-cairo ( gadget -- alien ) + [ + image-dims + [ image-buffer dup CAIRO_FORMAT_ARGB32 ] + [ cairo_image_surface_create_for_data ] 3bi + ] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ; TUPLE: cairo-gadget < gadget ; @@ -23,11 +30,13 @@ TUPLE: cairo-gadget < gadget ; swap >>dim ; M: cairo-gadget draw-gadget* - [ dim>> ] [ render-cairo ] bi - origin get first2 glRasterPos2i - 1.0 -1.0 glPixelZoom - [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip - glDrawPixels ; + [ + [ dim>> ] [ render-cairo &free ] bi + origin get first2 glRasterPos2i + 1.0 -1.0 glPixelZoom + [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip + glDrawPixels + ] with-destructors ; : copy-surface ( surface -- ) cr swap 0 0 cairo_set_source_surface diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index a7c4410aa5..15a4cb8266 100644 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -5,11 +5,11 @@ sequences io accessors arrays io.streams.string splitting combinators accessors calendar calendar.format.macros present ; IN: calendar.format -: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ; +: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ; -: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ; +: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ; -: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ; +: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ; : write-00 ( n -- ) pad-00 write ; diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor index ede8a8f653..e7aee0dd09 100644 --- a/basis/checksums/sha1/sha1.factor +++ b/basis/checksums/sha1/sha1.factor @@ -128,7 +128,7 @@ M: sha1 checksum-stream ( stream -- sha1 ) [ zip concat ] keep like ; : sha1-interleave ( string -- seq ) - [ zero? ] trim-left + [ zero? ] trim-head dup length odd? [ rest ] when seq>2seq [ sha1 checksum-bytes ] bi@ 2seq>seq ; diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 898a695b34..026c4d6f27 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -62,7 +62,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; [ + + w+ ] 2dip swap set-nth ; inline : prepare-message-schedule ( seq -- w-seq ) - word-size get group [ be> ] map block-size get 0 pad-right + word-size get group [ be> ] map block-size get 0 pad-tail dup 16 64 dup [ process-M-256 ] with each ; diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor index d8bad5ec41..81359690db 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor @@ -13,7 +13,7 @@ IN: compiler.cfg.alias-analysis.tests [ ] [ { - T{ ##load-indirect f V int-regs 1 "hello" } + T{ ##load-reference f V int-regs 1 "hello" } T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 } } alias-analysis drop ] unit-test diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 86bd388d8d..ec8fe62dfb 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -224,7 +224,7 @@ GENERIC: analyze-aliases* ( insn -- insn' ) M: ##load-immediate analyze-aliases* dup [ val>> ] [ dst>> ] bi constants get set-at ; -M: ##load-indirect analyze-aliases* +M: ##load-reference analyze-aliases* dup dst>> set-heap-ac ; M: ##alien-global analyze-aliases* diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 5619a70740..d152a8cc33 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -36,13 +36,13 @@ TUPLE: ##alien-setter < ##effect { value vreg } ; ! Stack operations INSN: ##load-immediate < ##pure { val integer } ; -INSN: ##load-indirect < ##pure obj ; +INSN: ##load-reference < ##pure obj ; GENERIC: ##load-literal ( dst value -- ) M: fixnum ##load-literal tag-fixnum ##load-immediate ; M: f ##load-literal drop \ f tag-number ##load-immediate ; -M: object ##load-literal ##load-indirect ; +M: object ##load-literal ##load-reference ; INSN: ##peek < ##read { loc loc } ; INSN: ##replace < ##write { loc loc } ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor old mode 100644 new mode 100755 index 584c4cd662..8ef3abda39 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -63,7 +63,7 @@ M: ##compare-float-branch linearize-insn ##box-float ##box-alien } memq? - ] contains? ; + ] any? ; : linearize-basic-block ( bb -- ) [ number>> _label ] diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index 476ba7d0ab..cc790c6c0a 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -39,8 +39,6 @@ GENERIC: >expr ( insn -- expr ) M: ##load-immediate >expr val>> ; -M: ##load-indirect >expr obj>> ; - M: ##unary >expr [ class ] [ src>> vreg>vn ] bi unary-expr boa ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 641ccceb5d..ac9603522e 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -81,7 +81,7 @@ sequences ; [ { - T{ ##load-indirect f V int-regs 1 + } + T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } @@ -89,7 +89,7 @@ sequences ; } ] [ { - T{ ##load-indirect f V int-regs 1 + } + T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } @@ -99,7 +99,7 @@ sequences ; [ { - T{ ##load-indirect f V int-regs 1 + } + T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } @@ -107,7 +107,7 @@ sequences ; } ] [ { - T{ ##load-indirect f V int-regs 1 + } + T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= } T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor old mode 100644 new mode 100755 index 91acbeed19..71d9c36412 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -70,8 +70,8 @@ SYMBOL: labels M: ##load-immediate generate-insn [ dst>> register ] [ val>> ] bi %load-immediate ; -M: ##load-indirect generate-insn - [ dst>> register ] [ obj>> ] bi %load-indirect ; +M: ##load-reference generate-insn + [ dst>> register ] [ obj>> ] bi %load-reference ; M: ##peek generate-insn [ dst>> register ] [ loc>> ] bi %peek ; @@ -400,7 +400,7 @@ M: no-such-symbol compiler-error-type : check-dlsym ( symbols dll -- ) dup dll-valid? [ - dupd '[ _ dlsym ] contains? + dupd '[ _ dlsym ] any? [ drop ] [ no-such-symbol ] if ] [ dll-path no-such-library drop diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 2fa234e381..f2f4e7aa9e 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -24,7 +24,7 @@ SYMBOL: compiled } cond drop ; : maybe-compile ( word -- ) - dup compiled>> [ drop ] [ queue-compile ] if ; + dup optimized>> [ drop ] [ queue-compile ] if ; SYMBOL: +failed+ @@ -110,7 +110,7 @@ t compile-dependencies? set-global [ (compile) yield-hook get call ] slurp-deque ; : decompile ( word -- ) - f 2array 1array t modify-code-heap ; + f 2array 1array modify-code-heap ; : optimized-recompile-hook ( words -- alist ) [ diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 3d17009e31..78e95ffb91 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -211,7 +211,7 @@ TUPLE: my-tuple ; { tuple vector } 3 slot { word } declare dup 1 slot 0 fixnum-bitand { [ ] } dispatch ; -[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test +[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test [ vector ] [ dispatch-alignment-regression ] unit-test @@ -276,3 +276,9 @@ TUPLE: id obj ; [ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test [ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test + +TUPLE: cucumber ; + +M: cucumber equal? "The cucumber has no equal" throw ; + +[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index bb1cb2eab5..c5bbe4a6c3 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -9,7 +9,7 @@ IN: optimizer.tests GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; -[ t ] [ \ xyz compiled>> ] unit-test +[ t ] [ \ xyz optimized>> ] unit-test ! Test predicate inlining : pred-test-1 @@ -94,7 +94,7 @@ TUPLE: pred-test ; ! regression GENERIC: void-generic ( obj -- * ) : breakage ( -- * ) "hi" void-generic ; -[ t ] [ \ breakage compiled>> ] unit-test +[ t ] [ \ breakage optimized>> ] unit-test [ breakage ] must-fail ! regression @@ -119,7 +119,7 @@ GENERIC: void-generic ( obj -- * ) ! compiling with a non-literal class failed : -regression ( class -- tuple ) ; -[ t ] [ \ -regression compiled>> ] unit-test +[ t ] [ \ -regression optimized>> ] unit-test GENERIC: foozul ( a -- b ) M: reversed foozul ; @@ -228,7 +228,7 @@ USE: binary-search.private : node-successor-f-bug ( x -- * ) [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; -[ t ] [ \ node-successor-f-bug compiled>> ] unit-test +[ t ] [ \ node-successor-f-bug optimized>> ] unit-test [ ] [ [ new ] build-tree optimize-tree drop ] unit-test @@ -242,7 +242,7 @@ USE: binary-search.private ] if ] if ; -[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test +[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test @@ -271,7 +271,7 @@ HINTS: recursive-inline-hang array ; : recursive-inline-hang-1 ( -- a ) { } recursive-inline-hang ; -[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test +[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test DEFER: recursive-inline-hang-3 diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor index a0262fdc81..56a4021eed 100644 --- a/basis/compiler/tests/peg-regression.factor +++ b/basis/compiler/tests/peg-regression.factor @@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]] USE: tools.test -[ t ] [ \ expr compiled>> ] unit-test -[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test +[ t ] [ \ expr optimized>> ] unit-test +[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index 1b349d2296..b5835de5fd 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ; : hey ( -- ) ; : there ( -- ) hey ; -[ t ] [ \ hey compiled>> ] unit-test -[ t ] [ \ there compiled>> ] unit-test +[ t ] [ \ hey optimized>> ] unit-test +[ t ] [ \ there optimized>> ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test -[ f ] [ \ hey compiled>> ] unit-test -[ f ] [ \ there compiled>> ] unit-test +[ f ] [ \ hey optimized>> ] unit-test +[ f ] [ \ there optimized>> ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test -[ t ] [ \ there compiled>> ] unit-test +[ t ] [ \ there optimized>> ] unit-test : good ( -- ) ; : bad ( -- ) good ; : ugly ( -- ) bad ; -[ t ] [ \ good compiled>> ] unit-test -[ t ] [ \ bad compiled>> ] unit-test -[ t ] [ \ ugly compiled>> ] unit-test +[ t ] [ \ good optimized>> ] unit-test +[ t ] [ \ bad optimized>> ] unit-test +[ t ] [ \ ugly optimized>> ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test -[ f ] [ \ good compiled>> ] unit-test -[ f ] [ \ bad compiled>> ] unit-test -[ f ] [ \ ugly compiled>> ] unit-test +[ f ] [ \ good optimized>> ] unit-test +[ f ] [ \ bad optimized>> ] unit-test +[ f ] [ \ ugly optimized>> ] unit-test [ t ] [ \ good compiled-usage assoc-empty? ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test -[ t ] [ \ good compiled>> ] unit-test -[ t ] [ \ bad compiled>> ] unit-test -[ t ] [ \ ugly compiled>> ] unit-test +[ t ] [ \ good optimized>> ] unit-test +[ t ] [ \ bad optimized>> ] unit-test +[ t ] [ \ ugly optimized>> ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 941d086312..b25b5a1a5e 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ; : sheeple-test ( -- string ) { } sheeple ; [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test compiled>> ] unit-test +[ t ] [ \ sheeple-test optimized>> ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test @@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ; [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test -[ t ] [ \ sheeple-test compiled>> ] unit-test +[ t ] [ \ sheeple-test optimized>> ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index c1e23c3e1e..a6d6c5dfb9 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ; 10 [ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ t ] [ - "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval + "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval ] unit-test ] times diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index ee8c2f056a..4092352fd5 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -47,7 +47,7 @@ IN: compiler.tests [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ] [ 1.0 float-spill-bug ] unit-test -[ t ] [ \ float-spill-bug compiled>> ] unit-test +[ t ] [ \ float-spill-bug optimized>> ] unit-test : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object ) { @@ -132,7 +132,7 @@ IN: compiler.tests [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ] [ 1.0 float-fixnum-spill-bug ] unit-test -[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test +[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test : resolve-spill-bug ( a b -- c ) [ 1 fixnum+fast ] bi@ dup 10 fixnum< [ @@ -159,7 +159,7 @@ IN: compiler.tests 16 narray ] if ; -[ t ] [ \ resolve-spill-bug compiled>> ] unit-test +[ t ] [ \ resolve-spill-bug optimized>> ] unit-test [ 4 ] [ 1 1 resolve-spill-bug ] unit-test diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor old mode 100644 new mode 100755 index c6cbb79ce5..cfbea3bcb9 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -19,14 +19,14 @@ words splitting grouping sorting accessors ; : bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ; -: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ; +: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ; [ t ] [ - [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains? + [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any? ] unit-test [ t f ] [ [ { "hi" } bleh ] ignore-errors - \ + stack-trace-contains? - \ > stack-trace-contains? + \ + stack-trace-any? + \ > stack-trace-any? ] unit-test diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor old mode 100644 new mode 100755 index 30244725b2..d758e2a34d --- a/basis/compiler/tree/builder/builder-tests.factor +++ b/basis/compiler/tree/builder/builder-tests.factor @@ -8,4 +8,4 @@ compiler.tree ; : inline-recursive ( -- ) inline-recursive ; inline recursive -[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test +[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? nip ] unit-test diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor old mode 100644 new mode 100755 index a5f18d6389..e25f152aef --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -175,7 +175,7 @@ M: #branch check-stack-flow* branch-out get [ ] find nip swap head* >vector datastack set ; M: #phi check-stack-flow* - branch-out get [ ] contains? [ + branch-out get [ ] any? [ [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri ] [ drop terminated? on ] if ; diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor old mode 100644 new mode 100755 index 71c6fb5675..751a335a13 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -498,7 +498,7 @@ cell-bits 32 = [ [ t ] [ [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree - [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains? + [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any? ] unit-test [ ] [ diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor old mode 100644 new mode 100755 index 030df8484f..1fffa06336 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/basis/compiler/tree/combinators/combinators.factor @@ -34,14 +34,14 @@ IN: compiler.tree.combinators dup dup '[ _ keep swap [ drop t ] [ dup #branch? [ - children>> [ _ contains-node? ] contains? + children>> [ _ contains-node? ] any? ] [ dup #recursive? [ child>> _ contains-node? ] [ drop f ] if ] if ] if - ] contains? ; inline recursive + ] any? ; inline recursive : select-children ( seq flags -- seq' ) [ [ drop f ] unless ] 2map ; diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor old mode 100644 new mode 100755 index 185c776c4e..886233a08b --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -79,7 +79,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ; dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ; : some-outputs-dead? ( #call -- ? ) - out-d>> [ live-value? not ] contains? ; + out-d>> [ live-value? not ] any? ; : maybe-drop-dead-outputs ( node -- nodes ) dup some-outputs-dead? [ diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index 8c13de296a..3f1e9e2667 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -60,7 +60,7 @@ M: #branch normalize* : eliminate-phi-introductions ( introductions seq terminated -- seq' ) [ [ nip ] [ - dup [ +bottom+ eq? ] trim-left + dup [ +bottom+ eq? ] trim-head [ [ length ] bi@ - tail* ] keep append ] if ] 3map ; diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor old mode 100644 new mode 100755 diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor old mode 100644 new mode 100755 index 7b3135e85c..f3b3238b4e --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -124,7 +124,7 @@ DEFER: (flat-length) [ class-types length 1 = ] [ union-class? not ] bi and - ] contains? ; + ] any? ; : node-count-bias ( -- n ) 45 node-count get [-] 8 /i ; diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor old mode 100644 new mode 100755 index f6726e4404..1e00efa835 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -118,7 +118,7 @@ M: #return-recursive unbox-tuples* ! These nodes never participate in unboxing : assert-not-unboxed ( values -- ) dup array? - [ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if + [ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if [ "Unboxing wrong value" throw ] when ; M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ; diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor old mode 100644 new mode 100755 index 63707041a2..656fbbb591 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -25,7 +25,7 @@ M: mailbox dispose* threads>> notify-all ; :: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- ) mailbox check-disposed - mailbox data>> pred dlist-contains? [ + mailbox data>> pred dlist-any? [ mailbox timeout wait-for-mailbox mailbox timeout pred block-unless-pred ] unless ; inline recursive diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor index 3bd2d330c3..41beedb6dc 100644 --- a/basis/concurrency/messaging/messaging-docs.factor +++ b/basis/concurrency/messaging/messaging-docs.factor @@ -53,7 +53,8 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" { $subsection reply-synchronous } "An example:" { $example - "USING: concurrency.messaging kernel threads ;" + "USING: concurrency.messaging kernel prettyprint threads ;" + "IN: scratchpad" ": pong-server ( -- )" " receive [ \"pong\" ] dip reply-synchronous ;" "[ pong-server t ] \"pong-server\" spawn-server" diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index c609b9e98d..5670110f04 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -38,7 +38,7 @@ M: object param-reg param-regs nth ; HOOK: two-operand? cpu ( -- ? ) HOOK: %load-immediate cpu ( reg obj -- ) -HOOK: %load-indirect cpu ( reg obj -- ) +HOOK: %load-reference cpu ( reg obj -- ) HOOK: %peek cpu ( vreg loc -- ) HOOK: %replace cpu ( vreg loc -- ) diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor index 0bb0d70ee0..fbb878a888 100644 --- a/basis/cpu/ppc/assembler/assembler.factor +++ b/basis/cpu/ppc/assembler/assembler.factor @@ -97,10 +97,10 @@ X: XOR 0 316 31 X: XOR. 1 316 31 X1: EXTSB 0 954 31 X1: EXTSB. 1 954 31 -: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ; -: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ; -: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ; -: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ; +: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ; +: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ; +: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ; +: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ; ! XO-form XO: ADD 0 0 266 31 diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor index a2c3a6c8d5..c6a3a94194 100644 --- a/basis/cpu/ppc/assembler/backend/backend.factor +++ b/basis/cpu/ppc/assembler/backend/backend.factor @@ -74,8 +74,8 @@ IN: cpu.ppc.assembler.backend GENERIC# (B) 2 ( dest aa lk -- ) M: integer (B) 18 i-insn ; -M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ; -M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ; +M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ; +M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; GENERIC: BC ( a b c -- ) M: integer BC 0 0 16 b-insn ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 232608e4ef..b177c71d77 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -34,7 +34,7 @@ M: ppc two-operand? f ; M: ppc %load-immediate ( reg n -- ) swap LOAD ; -M: ppc %load-indirect ( reg obj -- ) +M: ppc %load-reference ( reg obj -- ) [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ; M: ppc %alien-global ( register symbol dll -- ) @@ -261,7 +261,7 @@ M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- ) M:: ppc %integer>bignum ( dst src temp -- ) [ "end" define-label - dst 0 >bignum %load-indirect + dst 0 >bignum %load-reference ! Is it zero? Then just go to the end and return this zero 0 src 0 CMPI "end" get BEQ @@ -321,7 +321,7 @@ M:: ppc %integer>float ( dst src -- ) scratch-reg dup HEX: 8000 XORIS scratch-reg 1 4 scratch@ STW dst 1 0 scratch@ LFD - scratch-reg 4503601774854144.0 %load-indirect + scratch-reg 4503601774854144.0 %load-reference fp-scratch-reg scratch-reg float-offset LFD dst dst fp-scratch-reg FSUB ; @@ -488,7 +488,7 @@ M: ppc %epilogue ( n -- ) "end" define-label dst \ f tag-number %load-immediate "end" get word execute - dst \ t %load-indirect + dst \ t %load-reference "end" get resolve-label ; inline : %boolean ( dst temp cc -- ) @@ -637,7 +637,7 @@ M: ppc %alien-invoke ( symbol dll -- ) [ 11 ] 2dip %alien-global 11 MTLR BLRL ; M: ppc %alien-callback ( quot -- ) - 3 swap %load-indirect "c_to_factor" f %alien-invoke ; + 3 swap %load-reference "c_to_factor" f %alien-invoke ; M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 5e06e72118..affd39ffc5 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -237,7 +237,7 @@ M: x86.32 %alien-indirect ( -- ) M: x86.32 %alien-callback ( quot -- ) 4 [ - EAX swap %load-indirect + EAX swap %load-reference EAX PUSH "c_to_factor" f %alien-invoke ] with-aligned-stack ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index e46c8f6914..8cc69958a4 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -176,7 +176,7 @@ M: x86.64 %alien-indirect ( -- ) RBP CALL ; M: x86.64 %alien-callback ( quot -- ) - param-reg-1 swap %load-indirect + param-reg-1 swap %load-reference "c_to_factor" f %alien-invoke ; M: x86.64 %callback-value ( ctype -- ) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 44300a75f9..2859e71be2 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -21,7 +21,7 @@ HOOK: param-reg-2 cpu ( -- reg ) M: x86 %load-immediate MOV ; -M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ; +M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ; HOOK: ds-reg cpu ( -- reg ) HOOK: rs-reg cpu ( -- reg ) @@ -188,7 +188,7 @@ M:: x86 %integer>bignum ( dst src temp -- ) [ "end" define-label ! Load cached zero value - dst 0 >bignum %load-indirect + dst 0 >bignum %load-reference src 0 CMP ! Is it zero? Then just go to the end and return this zero "end" get JE diff --git a/basis/csv/csv-docs.factor b/basis/csv/csv-docs.factor index e4741f4810..6ae75b6b2f 100644 --- a/basis/csv/csv-docs.factor +++ b/basis/csv/csv-docs.factor @@ -1,28 +1,52 @@ -USING: help.syntax help.markup kernel prettyprint sequences ; +USING: help.syntax help.markup kernel prettyprint sequences +io.pathnames ; IN: csv HELP: csv { $values { "stream" "an input stream" } { "rows" "an array of arrays of fields" } } -{ $description "parses a csv stream into an array of row arrays" -} ; +{ $description "Parses a csv stream into an array of row arrays." } ; + +HELP: file>csv +{ $values + { "path" pathname } { "encoding" "an encoding descriptor" } + { "csv" "csv" } +} +{ $description "Opens a file and parses it into a sequence of comma-separated-value fields." } ; + +HELP: csv>file +{ $values + { "rows" "a sequence of sequences of strings" } + { "path" pathname } { "encoding" "an encoding descriptor" } +} +{ $description "Writes a comma-separated-value structure to a file." } ; HELP: csv-row { $values { "stream" "an input stream" } { "row" "an array of fields" } } -{ $description "parses a row from a csv stream" -} ; +{ $description "parses a row from a csv stream" } ; HELP: write-csv -{ $values { "rows" "an sequence of sequences of strings" } +{ $values { "rows" "a sequence of sequences of strings" } { "stream" "an output stream" } } -{ $description "writes csv to the output stream, escaping where necessary" -} ; - +{ $description "Writes a sequence of sequences of comma-separated-values to the output stream, escaping where necessary." } ; HELP: with-delimiter -{ $values { "char" "field delimiter (e.g. CHAR: \t)" } +{ $values { "ch" "field delimiter (e.g. CHAR: \t)" } { "quot" "a quotation" } } -{ $description "Sets the field delimiter for csv or csv-row words " -} ; +{ $description "Sets the field delimiter for csv or csv-row words." } ; +ARTICLE: "csv" "Comma-separated-values parsing and writing" +"The " { $vocab-link "csv" } " vocabulary can read and write CSV (comma-separated-value) files." $nl +"Reading a csv file:" +{ $subsection file>csv } +"Writing a csv file:" +{ $subsection csv>file } +"Changing the delimiter from a comma:" +{ $subsection with-delimiter } +"Reading from a stream:" +{ $subsection csv } +"Writing to a stream:" +{ $subsection write-csv } ; + +ABOUT: "csv" diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 8261ae104a..4d78c2af86 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -1,5 +1,7 @@ +USING: io.streams.string csv tools.test shuffle kernel strings +io.pathnames io.files.unique io.encodings.utf8 io.files +io.directories ; IN: csv.tests -USING: io.streams.string csv tools.test shuffle kernel strings ; ! I like to name my unit tests : named-unit-test ( name output input -- ) @@ -76,3 +78,15 @@ USING: io.streams.string csv tools.test shuffle kernel strings ; "escapes quotes commas and newlines when writing" [ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ] [ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } tuck write-csv >string ] named-unit-test ! " + +[ { { "writing" "some" "csv" "tests" } } ] +[ + "writing,some,csv,tests" + "csv-test1-" unique-file utf8 + [ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri +] unit-test + +[ t ] [ + { { "writing,some,csv,tests" } } dup "csv-test2-" + unique-file utf8 [ csv>file ] [ file>csv ] 2bi = +] unit-test diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor old mode 100644 new mode 100755 index 483a5825a9..152b3dcbba --- a/basis/csv/csv.factor +++ b/basis/csv/csv.factor @@ -1,89 +1,100 @@ ! Copyright (C) 2007, 2008 Phil Dawes ! See http://factorcode.org/license.txt for BSD license. - -! Simple CSV Parser -! Phil Dawes phil@phildawes.net - -USING: kernel sequences io namespaces make -combinators unicode.categories ; +USING: kernel sequences io namespaces make combinators +unicode.categories io.files combinators.short-circuit ; IN: csv SYMBOL: delimiter CHAR: , delimiter set-global + ( -- delimiter ) delimiter get ; inline DEFER: quoted-field ( -- endchar ) -! trims whitespace from either end of string : trim-whitespace ( str -- str ) - [ blank? ] trim ; inline + [ blank? ] trim ; inline : skip-to-field-end ( -- endchar ) "\n" delimiter> suffix read-until nip ; inline : not-quoted-field ( -- endchar ) - "\"\n" delimiter> suffix read-until ! " - dup - { { CHAR: " [ drop drop quoted-field ] } ! " - { delimiter> [ swap trim-whitespace % ] } - { CHAR: \n [ swap trim-whitespace % ] } - { f [ swap trim-whitespace % ] } ! eof - } case ; + "\"\n" delimiter> suffix read-until + dup { + { CHAR: " [ 2drop quoted-field ] } + { delimiter> [ swap trim-whitespace % ] } + { CHAR: \n [ swap trim-whitespace % ] } + { f [ swap trim-whitespace % ] } + } case ; : maybe-escaped-quote ( -- endchar ) - read1 dup - { { CHAR: " [ , quoted-field ] } ! " is an escaped quote - { delimiter> [ ] } ! end of quoted field - { CHAR: \n [ ] } - [ 2drop skip-to-field-end ] ! end of quoted field + padding - } case ; + read1 dup { + { CHAR: " [ , quoted-field ] } + { delimiter> [ ] } + { CHAR: \n [ ] } + [ 2drop skip-to-field-end ] + } case ; : quoted-field ( -- endchar ) - "\"" read-until ! " - drop % maybe-escaped-quote ; + "\"" read-until + drop % maybe-escaped-quote ; : field ( -- sep string ) - [ not-quoted-field ] "" make ; ! trim-whitespace + [ not-quoted-field ] "" make ; : (row) ( -- sep ) - field , - dup delimiter get = [ drop (row) ] when ; + field , + dup delimiter get = [ drop (row) ] when ; : row ( -- eof? array[string] ) - [ (row) ] { } make ; - -: append-if-row-not-empty ( row -- ) - dup { "" } = [ drop ] [ , ] if ; + [ (row) ] { } make ; : (csv) ( -- ) - row append-if-row-not-empty - [ (csv) ] when ; + row harvest [ , ] unless-empty [ (csv) ] when ; +PRIVATE> + : csv-row ( stream -- row ) - [ row nip ] with-input-stream ; + [ row nip ] with-input-stream ; : csv ( stream -- rows ) - [ [ (csv) ] { } make ] with-input-stream ; + [ [ (csv) ] { } make ] with-input-stream ; -: with-delimiter ( char quot -- ) - delimiter swap with-variable ; inline +: file>csv ( path encoding -- csv ) + csv ; + +: with-delimiter ( ch quot -- ) + [ delimiter ] dip with-variable ; inline + + : write-row ( row -- ) - [ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline + [ delimiter get write1 ] + [ escape-if-required write ] interleave nl ; inline : write-csv ( rows stream -- ) - [ [ write-row ] each ] with-output-stream ; + [ [ write-row ] each ] with-output-stream ; + +: csv>file ( rows path encoding -- ) write-csv ; diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index ae7451cb48..c392ec6b85 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -173,7 +173,7 @@ HELP: with-db HELP: with-transaction { $values { "quot" quotation } } -{ $description "" } ; +{ $description "Calls the quotation inside a database transaction and commits the result to the database after the quotation finishes. If the quotation throws an error, the transaction is aborted." } ; ARTICLE: "db" "Database library" "Accessing a database:" @@ -244,13 +244,13 @@ ARTICLE: "db-protocol" "Low-level database protocol" ! { $subsection bind-tuple } ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial" -"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." +"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." $nl "Executing a SQL command:" { $subsection sql-command } "Executing a query directly:" { $subsection sql-query } "Here's an example usage where we'll make a book table, insert some objects, and query them." $nl -"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details." +"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details." { $code <" USING: db.sqlite db io.files ; : with-book-db ( quot -- ) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index a094fbc542..1f55dcf769 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -55,8 +55,10 @@ M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object ) [ swap slot-name>> rot set-slot-named ] [ ] bi ; M: postgresql-statement bind-tuple ( tuple statement -- ) - tuck in-params>> - [ postgresql-bind-conversion ] with map + [ nip ] [ + in-params>> + [ postgresql-bind-conversion ] with map + ] 2bi >>bind-params drop ; M: postgresql-result-set #rows ( result-set -- n ) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor old mode 100644 new mode 100755 index 2d7ea67107..495c25ea68 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -19,7 +19,7 @@ SINGLETON: retryable ] if ; : maybe-make-retryable ( statement -- statement ) - dup in-params>> [ generator-bind? ] contains? + dup in-params>> [ generator-bind? ] any? [ make-retryable ] when ; : regenerate-params ( statement -- statement ) diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor old mode 100644 new mode 100755 index 0f545030a3..fe3bb64d45 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -294,7 +294,7 @@ M: sqlite-db-connection persistent-table ( -- assoc ) ] with-string-writer ; : can-be-null? ( -- ? ) - "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ; + "sql-spec" get modifiers>> [ +not-null+ = ] any? not ; : delete-cascade? ( -- ? ) "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ; diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index 51830ee610..bd88c56431 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -1,9 +1,13 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes help.markup help.syntax io.streams.string kernel -quotations sequences strings multiline math db.types db ; +quotations sequences strings multiline math db.types +db.tuples.private db ; IN: db.tuples +HELP: random-id-generator +{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ; + HELP: create-sql-statement { $values { "class" class } @@ -90,7 +94,7 @@ HELP: ensure-table HELP: ensure-tables { $values - { "classes" null } } + { "classes" "a sequence of classes" } } { $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ; HELP: recreate-table @@ -199,7 +203,7 @@ ARTICLE: "db-tuples-protocol" "Tuple database protocol" { $subsection } ; ARTICLE: "db-tuples-tutorial" "Tuple database tutorial" -"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl +"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl "We're going to store books in this tutorial." { $code "TUPLE: book id title author date-published edition cover-price condition ;" } "The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl @@ -246,7 +250,7 @@ T{ book { $code <" [ book get update-tuple ] with-book-tutorial "> } -"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "." +"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "." { $code <" [ T{ book { title "Factor for Sheeple" } } select-tuples ] with-book-tutorial "> } diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index d2116058d8..219116aefd 100644 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -73,9 +73,10 @@ PRIVATE> ! High level ERROR: no-slots-named class seq ; : check-columns ( class columns -- ) - tuck - [ [ first ] map ] - [ all-slots [ name>> ] map ] bi* diff + [ nip ] [ + [ [ first ] map ] + [ all-slots [ name>> ] map ] bi* diff + ] 2bi [ drop ] [ no-slots-named ] if-empty ; : define-persistent ( class table columns -- ) diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index d5908740c6..60d92717e8 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -4,53 +4,34 @@ USING: classes hashtables help.markup help.syntax io.streams.string kernel sequences strings math ; IN: db.types -HELP: +autoincrement+ -{ $description "" } ; - HELP: +db-assigned-id+ { $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ; HELP: +default+ -{ $description "" } ; - -HELP: +foreign-id+ -{ $description "" } ; - -HELP: +has-many+ -{ $description "" } ; +{ $description "Allows a default value for a column to be provided." } ; HELP: +not-null+ -{ $description "" } ; +{ $description "Ensures that a column is not null." } ; HELP: +null+ -{ $description "" } ; +{ $description "Allows a column to be null." } ; HELP: +primary-key+ -{ $description "" } ; +{ $description "Makes a column a primary key. Only one column may be a primary key." } ; HELP: +random-id+ { $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ; -HELP: +serial+ -{ $description "" } ; - -HELP: +unique+ -{ $description "" } ; - HELP: +user-assigned-id+ { $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ; HELP: { $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } } -{ $description "" } ; +{ $description "An internal constructor for creating objects containing parameters used for binding generated values to a tuple query." } ; HELP: { $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } } -{ $description "" } ; - -HELP: -{ $values { "value" object } { "low-level-binding" low-level-binding } } -{ $description "" } ; +{ $description "An internal constructor for creating objects containing parameters used for binding literal values to a tuple query." } ; HELP: BIG-INTEGER { $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ; @@ -108,87 +89,48 @@ HELP: VARCHAR HELP: user-assigned-id-spec? { $values - { "specs" "a sequence of sql specs" } + { "specs" "a sequence of SQL specs" } { "?" "a boolean" } } -{ $description "Tests if any of the sql specs has the type " { $link +user-assigned-id+ } "." } ; +{ $description "Tests if any of the SQL specs has the type " { $link +user-assigned-id+ } "." } ; HELP: bind# { $values - { "spec" null } { "obj" object } } -{ $description "" } ; + { "spec" "a SQL spec" } { "obj" object } } +{ $description "A generic word that lets a database construct a literal binding." } ; HELP: bind% { $values - { "spec" null } } -{ $description "" } ; - -HELP: compound -{ $values - { "string" string } { "obj" object } - { "hash" hashtable } } -{ $description "" } ; + { "spec" "a SQL spec" } } +{ $description "A generic word that lets a database output a binding." } ; HELP: db-assigned-id-spec? { $values - { "specs" "a sequence of sql specs" } + { "specs" "a sequence of SQL specs" } { "?" "a boolean" } } -{ $description "Tests if any of the sql specs has the type " { $link +db-assigned-id+ } "." } ; +{ $description "Tests if any of the SQL specs has the type " { $link +db-assigned-id+ } "." } ; HELP: find-primary-key { $values - { "specs" "a sequence of sql-specs" } - { "seq" "a sequence of sql-specs" } } -{ $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." } + { "specs" "a sequence of SQL specs" } + { "seq" "a sequence of SQL specs" } } +{ $description "Returns the rows from the SQL specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." } { $notes "This is a low-level word." } ; -HELP: generator-bind -{ $description "" } ; - HELP: get-slot-named { $values { "name" "a slot name" } { "tuple" tuple } { "value" "the value stored in the slot" } } { $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ; -HELP: literal-bind -{ $description "" } ; - -HELP: lookup-create-type -{ $values - { "obj" object } - { "string" string } } -{ $description "" } ; - -HELP: lookup-modifier -{ $values - { "obj" object } - { "string" string } } -{ $description "" } ; - -HELP: lookup-type -{ $values - { "obj" object } - { "string" string } } -{ $description "" } ; - -HELP: low-level-binding -{ $description "" } ; - -HELP: modifiers -{ $values - { "spec" null } - { "string" string } } -{ $description "" } ; - HELP: no-sql-type { $values - { "type" "a sql type" } } -{ $description "Throws an error containing a sql type that is unsupported or the result of a typo." } ; + { "type" "a SQL type" } } +{ $description "Throws an error containing a SQL type that is unsupported or the result of a typo." } ; HELP: normalize-spec { $values - { "spec" null } } -{ $description "" } ; + { "spec" "a SQL spec" } } +{ $description "Normalizes a SQL spec." } ; HELP: offset-of-slot { $values @@ -196,62 +138,21 @@ HELP: offset-of-slot { "n" integer } } { $description "Returns the offset of a tuple slot accessed by name." } ; -HELP: persistent-table -{ $values - - { "hash" hashtable } } -{ $description "" } ; - HELP: primary-key? { $values - { "spec" null } + { "spec" "a SQL spec" } { "?" "a boolean" } } -{ $description "" } ; - -HELP: random-id-generator -{ $description "" } ; +{ $description "Returns true if a SQL spec is a primary key." } ; HELP: relation? { $values - { "spec" null } + { "spec" "a SQL spec" } { "?" "a boolean" } } -{ $description "" } ; - -HELP: remove-db-assigned-id -{ $values - { "specs" null } - { "obj" object } } -{ $description "" } ; - -HELP: remove-id -{ $values - { "specs" null } - { "obj" object } } -{ $description "" } ; - -HELP: remove-relations -{ $values - { "specs" null } - { "newcolumns" null } } -{ $description "" } ; - -HELP: set-slot-named -{ $values - { "value" null } { "name" null } { "obj" object } } -{ $description "" } ; - -HELP: spec>tuple -{ $values - { "class" class } { "spec" null } - { "tuple" null } } -{ $description "" } ; - -HELP: sql-spec -{ $description "" } ; +{ $description "Returns true if a SQL spec is a relation." } ; HELP: unknown-modifier { $values { "modifier" string } } -{ $description "Throws an error containing an unknown sql modifier." } ; +{ $description "Throws an error containing an unknown SQL modifier." } ; ARTICLE: "db.types" "Database types" "The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor old mode 100644 new mode 100755 index 33b8923347..b5a7db987a --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -42,10 +42,10 @@ ERROR: no-slot ; slot-named dup [ no-slot ] unless offset>> ; : get-slot-named ( name tuple -- value ) - tuck offset-of-slot slot ; + [ nip ] [ offset-of-slot ] 2bi slot ; : set-slot-named ( value name obj -- ) - tuck offset-of-slot set-slot ; + [ nip ] [ offset-of-slot ] 2bi set-slot ; ERROR: not-persistent class ; @@ -71,10 +71,10 @@ ERROR: not-persistent class ; primary-key>> +primary-key+? ; : db-assigned-id-spec? ( specs -- ? ) - [ primary-key>> +db-assigned-id+? ] contains? ; + [ primary-key>> +db-assigned-id+? ] any? ; : user-assigned-id-spec? ( specs -- ? ) - [ primary-key>> +user-assigned-id+? ] contains? ; + [ primary-key>> +user-assigned-id+? ] any? ; : normalize-spec ( spec -- ) dup type>> dup +primary-key+? [ @@ -105,7 +105,7 @@ FACTOR-BLOB NULL URL ; dup normalize-spec ; : spec>tuple ( class spec -- tuple ) - 3 f pad-right [ first3 ] keep 3 tail ; + 3 f pad-tail [ first3 ] keep 3 tail ; : number>string* ( n/string -- string ) dup number? [ number>string ] when ; diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor index f4e68c214b..73769cc4d2 100644 --- a/basis/deques/deques.factor +++ b/basis/deques/deques.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math ; +USING: kernel sequences math fry ; IN: deques GENERIC: push-front* ( obj deque -- node ) @@ -34,7 +34,8 @@ GENERIC: deque-empty? ( deque -- ? ) [ peek-back ] [ pop-back* ] bi ; : slurp-deque ( deque quot -- ) - [ drop [ deque-empty? not ] curry ] - [ [ pop-back ] prepose curry ] 2bi [ ] while ; inline + [ drop '[ _ deque-empty? not ] ] + [ '[ _ pop-back @ ] ] + 2bi [ ] while ; inline MIXIN: deque diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor old mode 100644 new mode 100755 index ef6087f852..12e39746c7 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -15,7 +15,7 @@ $nl "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } -{ $subsection dlist-contains? } +{ $subsection dlist-any? } "Deleting a node matching a predicate:" { $subsection delete-node-if* } { $subsection delete-node-if } @@ -40,7 +40,7 @@ HELP: dlist-find "This operation is O(n)." } ; -HELP: dlist-contains? +HELP: dlist-any? { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } { $notes "This operation is O(n)." } ; diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor old mode 100644 new mode 100755 index 084aa0ac89..3689680157 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -46,8 +46,8 @@ IN: dlists.tests [ f f ] [ [ 1 = ] dlist-find ] unit-test [ 1 t ] [ 1 over push-back [ 1 = ] dlist-find ] unit-test [ f f ] [ 1 over push-back [ 2 = ] dlist-find ] unit-test -[ f ] [ 1 over push-back [ 2 = ] dlist-contains? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] dlist-contains? ] unit-test +[ f ] [ 1 over push-back [ 2 = ] dlist-any? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] dlist-any? ] unit-test [ 1 ] [ 1 over push-back [ 1 = ] delete-node-if ] unit-test [ t ] [ 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor old mode 100644 new mode 100755 index dcff476166..3d7224ed16 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman, +! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel math sequences accessors deques -search-deques summary hashtables ; +search-deques summary hashtables fry ; IN: dlists > ; [ front>> ] dip (dlist-find-node) ; inline : dlist-each-node ( dlist quot -- ) - [ f ] compose dlist-find-node 2drop ; inline + '[ @ f ] dlist-find-node 2drop ; inline : unlink-node ( dlist-node -- ) dup prev>> over next>> set-prev-when @@ -115,14 +115,13 @@ M: dlist pop-back* ( dlist -- ) normalize-front ; : dlist-find ( dlist quot -- obj/f ? ) - [ obj>> ] prepose - dlist-find-node [ obj>> t ] [ drop f f ] if ; inline + '[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline -: dlist-contains? ( dlist quot -- ? ) +: dlist-any? ( dlist quot -- ? ) dlist-find nip ; inline M: dlist deque-member? ( value dlist -- ? ) - [ = ] with dlist-contains? ; + [ = ] with dlist-any? ; M: dlist delete-node ( dlist-node dlist -- ) { @@ -143,7 +142,7 @@ M: dlist delete-node ( dlist-node dlist -- ) ] if ; inline : delete-node-if ( dlist quot -- obj/f ) - [ obj>> ] prepose delete-node-if* drop ; inline + '[ obj>> @ ] delete-node-if* drop ; inline M: dlist clear-deque ( dlist -- ) f >>front @@ -151,7 +150,7 @@ M: dlist clear-deque ( dlist -- ) drop ; : dlist-each ( dlist quot -- ) - [ obj>> ] prepose dlist-each-node ; inline + '[ obj>> @ ] dlist-each-node ; inline : dlist>seq ( dlist -- seq ) [ ] accumulator [ dlist-each ] dip ; @@ -159,8 +158,6 @@ M: dlist clear-deque ( dlist -- ) : 1dlist ( obj -- dlist ) [ push-front ] keep ; M: dlist clone - [ - [ push-back ] curry dlist-each - ] keep ; + [ '[ _ push-back ] dlist-each ] keep ; INSTANCE: dlist deque diff --git a/basis/environment/environment-docs.factor b/basis/environment/environment-docs.factor index e539b446f3..b48a7a01ad 100644 --- a/basis/environment/environment-docs.factor +++ b/basis/environment/environment-docs.factor @@ -7,12 +7,14 @@ HELP: (os-envs) { $values { "seq" sequence } } -{ $description "" } ; +{ $description "Returns a sequence of key/value pairs from the operating system." } +{ $notes "In most cases, use " { $link os-envs } " instead." } ; HELP: (set-os-envs) { $values { "seq" sequence } } -{ $description "" } ; +{ $description "Low-level word for replacing the current set of environment variables." } +{ $notes "In most cases, use " { $link set-os-envs } " instead." } ; HELP: os-env ( key -- value ) diff --git a/basis/eval/eval-docs.factor b/basis/eval/eval-docs.factor index 057d291b7f..b53c3bae6b 100644 --- a/basis/eval/eval-docs.factor +++ b/basis/eval/eval-docs.factor @@ -11,7 +11,7 @@ HELP: eval>string { $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ; ARTICLE: "eval" "Evaluating strings at runtime" -"Evaluating strings at runtime:" +"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime." { $subsection eval } { $subsection eval>string } ; diff --git a/basis/eval/eval-tests.factor b/basis/eval/eval-tests.factor new file mode 100644 index 0000000000..675921944a --- /dev/null +++ b/basis/eval/eval-tests.factor @@ -0,0 +1,4 @@ +IN: eval.tests +USING: eval tools.test ; + +[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test diff --git a/basis/eval/eval.factor b/basis/eval/eval.factor index 5b22fec159..dfa9baf418 100644 --- a/basis/eval/eval.factor +++ b/basis/eval/eval.factor @@ -1,14 +1,24 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: splitting parser compiler.units kernel namespaces -debugger io.streams.string ; +debugger io.streams.string fry ; IN: eval +: parse-string ( str -- ) + [ string-lines parse-lines ] with-compilation-unit ; + +: (eval) ( str -- ) + parse-string call ; + : eval ( str -- ) - [ string-lines parse-fresh ] with-compilation-unit call ; + [ (eval) ] with-file-vocabs ; + +: (eval>string) ( str -- output ) + [ + "quiet" on + parser-notes off + '[ _ (eval) ] try + ] with-string-writer ; : eval>string ( str -- output ) - [ - parser-notes off - [ [ eval ] keep ] try drop - ] with-string-writer ; + [ (eval>string) ] with-file-vocabs ; \ No newline at end of file diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor index 8e7270cc01..8c6b07a01c 100644 --- a/basis/farkup/farkup-docs.factor +++ b/basis/farkup/farkup-docs.factor @@ -14,8 +14,8 @@ HELP: parse-farkup ( string -- farkup ) { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ; HELP: (write-farkup) -{ $values { "farkup" "a Farkup syntax tree node" } } -{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ; +{ $values { "farkup" "a Farkup syntax tree node" } { "xml" "an XML chunk" } } +{ $description "Converts a Farkup syntax tree node to XML." } ; ARTICLE: "farkup-ast" "Farkup syntax tree nodes" "The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "." diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index aa9345e1d0..49c4dab0db 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: farkup kernel peg peg.ebnf tools.test namespaces xml -urls.encoding assocs xml.utilities ; +urls.encoding assocs xml.utilities xml.data ; IN: farkup.tests relative-link-prefix off @@ -92,22 +92,22 @@ link-no-follow? off [ "

=

foo

" ] [ "===foo==" convert-farkup ] unit-test [ "

foo

=

" ] [ "=foo==" convert-farkup ] unit-test -[ "
int main()\n
" ] +[ "
int main()
" ] [ "[c{int main()}]" convert-farkup ] unit-test -[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test -[ "

teh lol

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test -[ "

http://lol.com

" ] [ "[[http://lol.com]]" convert-farkup ] unit-test -[ "

haha

" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test -[ "

Bar

" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test +[ "

" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test +[ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test +[ "

http://lol.com

" ] [ "[[http://lol.com]]" convert-farkup ] unit-test +[ "

haha

" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test +[ "

Bar

" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test "/wiki/view/" relative-link-prefix [ - [ "

Bar

" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test + [ "

Bar

" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test ] with-variable [ ] [ "[{}]" convert-farkup drop ] unit-test -[ "
hello\n
" ] [ "[{hello}]" convert-farkup ] unit-test +[ "
hello
" ] [ "[{hello}]" convert-farkup ] unit-test [ "

Feature comparison:\n
aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes

" @@ -118,15 +118,15 @@ link-no-follow? off ] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test [ - "

This wiki is written in Factor and is hosted on a http://linode.com virtual server.

" + "

This wiki is written in Factor and is hosted on a http://linode.com virtual server.

" ] [ "This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server." convert-farkup ] unit-test -[ "

a c

" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test +[ "

a c

" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test -[ "

C++

" ] [ "[[C++]]" convert-farkup ] unit-test +[ "

C++

" ] [ "[[C++]]" convert-farkup ] unit-test [ "

<foo>

" ] [ "" convert-farkup ] unit-test @@ -138,10 +138,10 @@ link-no-follow? off [ "
" ] [ "___" convert-farkup ] unit-test [ "
\n" ] [ "___\n" convert-farkup ] unit-test -[ "

before:\n

{ 1 2 3 } 1 tail\n

" ] +[ "

before:\n

{ 1 2 3 } 1 tail

" ] [ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test -[ "

Factor-rific!

" ] +[ "

Factor-rific!

" ] [ "[[Factor]]-rific!" convert-farkup ] unit-test [ "

[ factor { 1 2 3 }]

" ] @@ -161,9 +161,9 @@ link-no-follow? off : check-link-escaping ( string -- link ) convert-farkup string>xml-chunk - "a" deep-tag-named "href" swap at url-decode ; + "a" deep-tag-named "href" attr url-decode ; -[ "Trader Joe's" ] [ "[[Trader Joe's]]" check-link-escaping ] unit-test +[ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test [ "" ] [ "[[]]" check-link-escaping ] unit-test [ "&blah;" ] [ "[[&blah;]]" check-link-escaping ] unit-test -[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test \ No newline at end of file +[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor old mode 100644 new mode 100755 index 1bfd420dd3..bad41296ee --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators html.elements io +USING: accessors arrays combinators io io.streams.string kernel math namespaces peg peg.ebnf -sequences sequences.deep strings xml.entities -vectors splitting xmode.code2html urls.encoding ; +sequences sequences.deep strings xml.entities xml.literals +vectors splitting xmode.code2html urls.encoding xml.data +xml.writer ; IN: farkup SYMBOL: relative-link-prefix @@ -33,7 +34,7 @@ TUPLE: line ; TUPLE: line-break ; : absolute-url? ( string -- ? ) - { "http://" "https://" "ftp://" } [ head? ] with contains? ; + { "http://" "https://" "ftp://" } [ head? ] with any? ; : simple-link-title ( string -- string' ) dup absolute-url? [ "/" split1-last swap or ] unless ; @@ -74,6 +75,7 @@ inline-code = "%" (!("%" | nl).)+ "%" => [[ second >string inline-code boa ]] link-content = (!("|"|"]").)+ + => [[ >string ]] image-link = "[[image:" link-content "|" link-content "]]" => [[ [ second >string ] [ fourth >string ] bi image boa ]] @@ -146,7 +148,7 @@ named-code simple-code = "[{" (!("}]").)+ "}]" - => [[ second f swap code boa ]] + => [[ second >string f swap code boa ]] code = named-code | simple-code @@ -160,69 +162,81 @@ stand-alone : check-url ( href -- href' ) { { [ dup empty? ] [ drop invalid-url ] } - { [ dup [ 127 > ] contains? ] [ drop invalid-url ] } + { [ dup [ 127 > ] any? ] [ drop invalid-url ] } { [ dup first "/\\" member? ] [ drop invalid-url ] } { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] } - [ relative-link-prefix get prepend ] - } cond ; + [ relative-link-prefix get prepend "" like ] + } cond url-encode ; -: escape-link ( href text -- href-esc text-esc ) - [ check-url ] dip escape-string ; +: write-link ( href text -- xml ) + [ check-url link-no-follow? get "true" and ] dip + [XML nofollow=<->><-> XML] ; -: write-link ( href text -- ) - escape-link - [ ] - [ write ] - bi* ; - -: write-image-link ( href text -- ) +: write-image-link ( href text -- xml ) disable-images? get [ 2drop - "Images are not allowed" write + [XML Images are not allowed XML] ] [ - escape-link - [ ] bi* + [ check-url ] [ f like ] bi* + [XML alt=<->/> XML] ] if ; -: render-code ( string mode -- string' ) - [ string-lines ] dip - [ - 
-            htmlize-lines
-
- ] with-string-writer write ; +: render-code ( string mode -- xml ) + [ string-lines ] dip htmlize-lines + [XML 
<->
XML] ; -GENERIC: (write-farkup) ( farkup -- ) -: ( string -- ) write ; -: ( string -- ) write ; -: in-tag. ( obj quot string -- ) [ call ] keep ; inline -M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ; -M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ; -M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ; -M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ; -M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ; -M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ; -M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ; -M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ; -M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ; -M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ; -M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ; -M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ; -M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ; -M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ; -M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ; -M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ; -M: line (write-farkup) drop
; -M: line-break (write-farkup) drop
nl ; -M: table-row (write-farkup) ( obj -- ) - child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ; -M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ; -M: string (write-farkup) escape-string write ; -M: vector (write-farkup) [ (write-farkup) ] each ; -M: f (write-farkup) drop ; +GENERIC: (write-farkup) ( farkup -- xml ) -: write-farkup ( string -- ) +: farkup-inside ( farkup name -- xml ) + swap T{ attrs } swap + child>> (write-farkup) 1array ; + +M: heading1 (write-farkup) "h1" farkup-inside ; +M: heading2 (write-farkup) "h2" farkup-inside ; +M: heading3 (write-farkup) "h3" farkup-inside ; +M: heading4 (write-farkup) "h4" farkup-inside ; +M: strong (write-farkup) "strong" farkup-inside ; +M: emphasis (write-farkup) "em" farkup-inside ; +M: superscript (write-farkup) "sup" farkup-inside ; +M: subscript (write-farkup) "sub" farkup-inside ; +M: inline-code (write-farkup) "code" farkup-inside ; +M: list-item (write-farkup) "li" farkup-inside ; +M: unordered-list (write-farkup) "ul" farkup-inside ; +M: ordered-list (write-farkup) "ol" farkup-inside ; +M: paragraph (write-farkup) "p" farkup-inside ; +M: table (write-farkup) "table" farkup-inside ; + +M: link (write-farkup) + [ href>> ] [ text>> ] bi write-link ; + +M: image (write-farkup) + [ href>> ] [ text>> ] bi write-image-link ; + +M: code (write-farkup) + [ string>> ] [ mode>> ] bi render-code ; + +M: line (write-farkup) + drop [XML
XML] ; + +M: line-break (write-farkup) + drop [XML
XML] ; + +M: table-row (write-farkup) + child>> + [ (write-farkup) [XML <-> XML] ] map + [XML <-> XML] ; + +M: string (write-farkup) ; + +M: vector (write-farkup) [ (write-farkup) ] map ; + +M: f (write-farkup) ; + +: farkup>xml ( string -- xml ) parse-farkup (write-farkup) ; +: write-farkup ( string -- ) + farkup>xml write-xml ; + : convert-farkup ( string -- string' ) - parse-farkup [ (write-farkup) ] with-string-writer ; + [ write-farkup ] with-string-writer ; diff --git a/basis/formatting/formatting-docs.factor b/basis/formatting/formatting-docs.factor index 8db3567c23..95b24ae351 100644 --- a/basis/formatting/formatting-docs.factor +++ b/basis/formatting/formatting-docs.factor @@ -7,27 +7,29 @@ HELP: printf { $values { "format-string" string } } { $description "Writes the arguments (specified on the stack) formatted according to the format string.\n" - "\n" + $nl "Several format specifications exist for handling arguments of different types, and " "specifying attributes for the result string, including such things as maximum width, " "padding, and decimals.\n" { $table - { "%%" "Single %" "" } - { "%P.Ds" "String format" "string" } - { "%P.DS" "String format uppercase" "string" } - { "%c" "Character format" "char" } - { "%C" "Character format uppercase" "char" } - { "%+Pd" "Integer format" "fixnum" } - { "%+P.De" "Scientific notation" "fixnum, float" } - { "%+P.DE" "Scientific notation" "fixnum, float" } - { "%+P.Df" "Fixed format" "fixnum, float" } - { "%+Px" "Hexadecimal" "hex" } - { "%+PX" "Hexadecimal uppercase" "hex" } + { "%%" "Single %" "" } + { "%P.Ds" "String format" "string" } + { "%P.DS" "String format uppercase" "string" } + { "%c" "Character format" "char" } + { "%C" "Character format uppercase" "char" } + { "%+Pd" "Integer format" "fixnum" } + { "%+P.De" "Scientific notation" "fixnum, float" } + { "%+P.DE" "Scientific notation" "fixnum, float" } + { "%+P.Df" "Fixed format" "fixnum, float" } + { "%+Px" "Hexadecimal" "hex" } + { "%+PX" "Hexadecimal uppercase" "hex" } + { "%[%?, %]" "Sequence format" "sequence" } + { "%[%?: %? %]" "Assocs format" "assocs" } } - "\n" + $nl "A plus sign ('+') is used to optionally specify that the number should be " "formatted with a '+' preceeding it if positive.\n" - "\n" + $nl "Padding ('P') is used to optionally specify the minimum width of the result " "string, the padding character, and the alignment. By default, the padding " "character defaults to a space and the alignment defaults to right-aligned. " @@ -38,12 +40,12 @@ HELP: printf "\"%'#5f\" formats a float padding with '#' up to 3 characters wide." "\"%-10d\" formats an integer to 10 characters wide and left-aligns." } - "\n" + $nl "Digits ('D') is used to optionally specify the maximum digits in the result " "string. For example:\n" { $list "\"%.3s\" formats a string to truncate at 3 characters (from the left)." - "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point." + "\"%.10f\" formats a float to pad-tail with zeros up to 10 digits beyond the decimal point." "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent." } } @@ -72,6 +74,14 @@ HELP: printf "USING: formatting ;" "1234 \"%+d\" printf" "+1234" } + { $example + "USING: formatting ;" + "{ 1 2 3 } \"%[%d, %]\" printf" + "{ 1, 2, 3 }" } + { $example + "USING: formatting ;" + "H{ { 1 2 } { 3 4 } } \"%[%d: %d %]\" printf" + "{ 1:2, 3:4 }" } } ; HELP: sprintf @@ -83,7 +93,7 @@ HELP: strftime { $values { "format-string" string } } { $description "Writes the timestamp (specified on the stack) formatted according to the format string.\n" - "\n" + $nl "Different attributes of the timestamp can be retrieved using format specifications.\n" { $table { "%a" "Abbreviated weekday name." } @@ -118,7 +128,7 @@ HELP: strftime } ; ARTICLE: "formatting" "Formatted printing" -"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing.\n" +"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing." { $subsection printf } { $subsection sprintf } { $subsection strftime } diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index 3f12c36bbd..5a1e3650fe 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 John Benediktsson ! See http://factorcode.org/license.txt for BSD license -USING: accessors arrays ascii calendar combinators fry kernel +USING: accessors arrays ascii assocs calendar combinators fry kernel generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations sequences splitting strings unicode.case vectors ; @@ -29,7 +29,7 @@ IN: formatting [ 0 ] [ string>number ] if-empty ; : pad-digits ( string digits -- string' ) - [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ; + [ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ; : max-digits ( n digits -- n' ) 10 swap ^ [ * round ] keep / ; inline @@ -48,7 +48,7 @@ IN: formatting [ max-digits ] keep -rot [ [ 0 < "-" "+" ? ] - [ abs number>string 2 CHAR: 0 pad-left ] bi + [ abs number>string 2 CHAR: 0 pad-head ] bi "e" -rot 3append ] [ number>string ] bi* @@ -60,7 +60,7 @@ zero = "0" => [[ CHAR: 0 ]] char = "'" (.) => [[ second ]] pad-char = (zero|char)? => [[ CHAR: \s or ]] -pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]] +pad-align = ("-")? => [[ \ pad-tail \ pad-head ? ]] pad-width = ([0-9])* => [[ >digits ]] pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]] @@ -75,8 +75,8 @@ digits = (digits_)? => [[ 6 or ]] fmt-% = "%" => [[ [ "%" ] ]] fmt-c = "c" => [[ [ 1string ] ]] fmt-C = "C" => [[ [ 1string >upper ] ]] -fmt-s = "s" => [[ [ ] ]] -fmt-S = "S" => [[ [ >upper ] ]] +fmt-s = "s" => [[ [ dup number? [ number>string ] when ] ]] +fmt-S = "S" => [[ [ dup number? [ number>string ] when >upper ] ]] fmt-d = "d" => [[ [ >fixnum number>string ] ]] fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]] fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]] @@ -91,7 +91,13 @@ strings = pad width strings_ => [[ reverse compose-all ]] numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]] -formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]] +types = strings|numbers + +lists = "[%" types ", %]" => [[ second '[ _ map ", " join "{ " prepend " }" append ] ]] + +assocs = "[%" types ": %" types " %]" => [[ [ second ] [ fourth ] bi '[ unzip [ _ map ] dip _ map zip [ ":" join ] map ", " join "{ " prepend " }" append ] ]] + +formats = "%" (types|fmt-%|lists|assocs|unknown) => [[ second '[ _ dip ] ]] plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]] @@ -110,9 +116,9 @@ MACRO: printf ( format-string -- ) string 2 CHAR: 0 pad-left ; inline +: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline -: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline +: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-head ; inline : >time ( timestamp -- string ) [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index d91f44aecb..5d750775e5 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -69,18 +69,18 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy" "'[ [ _ key? ] all? ] filter" "[ [ key? ] curry all? ] curry filter" } -"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:" +"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a “let†form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:" { $code "'[ 3 _ + 4 _ / ]" "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]" } ; ARTICLE: "fry" "Fried quotations" -"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack." +"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with “holes†(more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack." $nl "Fried quotations are started by a special parsing word:" { $subsection POSTPONE: '[ } -"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:" +"There are two types of fry specifiers; the first can hold a value, and the second “splices†a quotation, as if it were inserted without surrounding brackets:" { $subsection _ } { $subsection @ } "The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on." diff --git a/basis/ftp/client/listing-parser/listing-parser.factor b/basis/ftp/client/listing-parser/listing-parser.factor index 6183165b3a..6e2f9ebec4 100644 --- a/basis/ftp/client/listing-parser/listing-parser.factor +++ b/basis/ftp/client/listing-parser/listing-parser.factor @@ -39,7 +39,7 @@ name target ; : parse-list-11 ( lines -- seq ) [ - 11 f pad-right + 11 f pad-tail swap { [ 0 swap nth parse-permissions ] [ 1 swap nth string>number >>links ] diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 39923afee7..a5f3042b38 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -34,7 +34,7 @@ WW DEFINES ${W}${W} WHERE -: WW W twice ; inline +: WW ( a -- b ) \ W twice ; inline ;FUNCTOR @@ -45,3 +45,21 @@ WHERE \ sqsq must-infer [ 16 ] [ 2 sqsq ] unit-test + +<< + +FUNCTOR: wrapper-test-2 ( W -- ) + +W DEFINES ${W} + +WHERE + +: W ( a b -- c ) \ + execute ; + +;FUNCTOR + +"blah" wrapper-test-2 + +>> + +[ 4 ] [ 1 3 blah ] unit-test \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 28bedc8360..f4d35b6932 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,17 +1,43 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel quotations classes.tuple make combinators generic words interpolate namespaces sequences io.streams.string fry classes.mixin effects lexer parser classes.tuple.parser effects.parser locals.types locals.parser -locals.rewrite.closures vocabs.parser ; +locals.rewrite.closures vocabs.parser arrays accessors ; IN: functors -: scan-param ( -- obj ) - scan-object dup special? [ literalize ] unless ; +! This is a hack + +fake-quotations ( quot -- fake ) + +M: callable >fake-quotations + >array >fake-quotations fake-quotation boa ; + +M: array >fake-quotations [ >fake-quotations ] { } map-as ; + +M: object >fake-quotations ; + +GENERIC: fake-quotations> ( fake -- quot ) + +M: fake-quotation fake-quotations> + seq>> [ fake-quotations> ] map >quotation ; + +M: array fake-quotations> [ fake-quotations> ] map ; + +M: object fake-quotations> ; + +: parse-definition* ( -- ) + parse-definition >fake-quotations parsed \ fake-quotations> parsed ; + : DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ; : `TUPLE: @@ -32,7 +58,7 @@ IN: functors scan-param parsed scan-param parsed \ create-method parsed - parse-definition parsed + parse-definition* DEFINE* ; parsing : `C: @@ -45,7 +71,7 @@ IN: functors : `: effect off scan-param parsed - parse-definition parsed + parse-definition* DEFINE* ; parsing : `INSTANCE: @@ -64,12 +90,16 @@ IN: functors [ scan interpolate-locals ] dip '[ _ with-string-writer @ ] parsed ; +PRIVATE> + : IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing : DEFINES [ create-in ] (INTERPOLATE) ; parsing DEFER: ;FUNCTOR delimiter + rewrite-closures first ; +PRIVATE> + : FUNCTOR: (FUNCTOR:) define ; parsing diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 72a7b76d23..97cb73c9cb 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -10,7 +10,6 @@ furnace.utilities furnace.redirection furnace.conversations html.forms -html.elements html.components html.components html.templates.chloe diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index 4a03d59581..3f1bcb6085 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -105,9 +105,8 @@ ARTICLE: "furnace.auth.realm-config" "Authentication realm configuration" "Instances of subclasses of " { $link realm } " have the following slots which may be set:" { $table { { $slot "name" } "A string identifying the realm for user interface purposes" } - { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } ". By default, the " { $link users-in-db } " provider is used." } } + { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } "). By default, the " { $link users-in-db } " provider is used." } } { { $slot "checksum" } { "An implementation of the checksum protocol used for verifying passwords (see " { $link "checksums" } "). The " { $link sha-256 } " checksum is used by default." } } - { { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } } } { { $slot "secure" } { "A boolean, that when set to a true value, forces the client to access the authentication realm via HTTPS. An attempt to access the realm via HTTP results in a redirect to the corresponding HTTPS URL. On by default." } } } ; @@ -121,7 +120,7 @@ $nl { $subsection "furnace.auth.providers.db" } ; ARTICLE: "furnace.auth.features" "Optional authentication features" -"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm." +"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm." { $subsection "furnace.auth.features.deactivate-user" } { $subsection "furnace.auth.features.edit-profile" } { $subsection "furnace.auth.features.recover-password" } @@ -148,7 +147,7 @@ ARTICLE: "furnace.auth.users" "User profiles" "User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ; ARTICLE: "furnace.auth.example" "Furnace authentication example" -"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':" +"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message “You must log in to view your todo listâ€:" { $code <" "view your todo list" >>description"> diff --git a/basis/furnace/auth/features/edit-profile/edit-profile.factor b/basis/furnace/auth/features/edit-profile/edit-profile.factor old mode 100644 new mode 100755 index cefb472b22..08c1a1abfe --- a/basis/furnace/auth/features/edit-profile/edit-profile.factor +++ b/basis/furnace/auth/features/edit-profile/edit-profile.factor @@ -31,7 +31,7 @@ IN: furnace.auth.features.edit-profile } validate-params { "password" "new-password" "verify-password" } - [ value empty? not ] contains? [ + [ value empty? not ] any? [ "password" value username check-login [ "incorrect password" validation-error ] unless diff --git a/basis/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor index 77be30a2d1..aeaf9e9471 100644 --- a/basis/furnace/auth/features/recover-password/recover-password.factor +++ b/basis/furnace/auth/features/recover-password/recover-password.factor @@ -27,7 +27,7 @@ SYMBOL: lost-password-from over email>> 1array >>to [ "This e-mail was sent by the application server on " % current-host % "\n" % - "because somebody, maybe you, clicked on a ``recover password'' link in the\n" % + "because somebody, maybe you, clicked on a “recover password†link in the\n" % "login form, and requested a new password for the user named ``" % over username>> % "''.\n" % "\n" % diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index fff301eb2f..0ceafa7f86 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -16,7 +16,7 @@ IN: furnace.auth.login SYMBOL: permit-id : permit-id-key ( realm -- string ) - [ >hex 2 CHAR: 0 pad-left ] { } map-as concat + [ >hex 2 CHAR: 0 pad-head ] { } map-as concat "__p_" prepend ; : client-permit-id ( realm -- id/f ) diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 1c320182bf..dd24d8dcde 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -8,6 +8,7 @@ xml.data xml.entities xml.writer xml.utilities +xml.literals html.components html.elements html.forms @@ -20,7 +21,6 @@ http.server http.server.redirection http.server.responses furnace.utilities ; -QUALIFIED-WITH: assocs a IN: furnace.chloe-tags ! Chloe tags @@ -56,11 +56,11 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ; : compile-link-attrs ( tag -- ) #! Side-effects current namespace. - attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ; + '[ [ [ _ ] dip link-attr ] each-responder ] [code] ; : a-start-tag ( tag -- ) [ > non-chloe-attrs-only compile-attrs ] [ compile-link-attrs ] [ compile-a-url ] tri @@ -116,17 +116,18 @@ CHLOE: form } cleave ] compile-with-scope ; -STRING: button-tag-markup - -
- -; +: button-tag-markup ( -- xml ) + +
+ + XML> ; : add-tag-attrs ( attrs tag -- ) attrs>> swap update ; CHLOE: button - button-tag-markup string>xml body>> + button-tag-markup body>> { [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ] diff --git a/basis/furnace/syndication/syndication-docs.factor b/basis/furnace/syndication/syndication-docs.factor index 94a69ccd0e..1ce1cd7da1 100644 --- a/basis/furnace/syndication/syndication-docs.factor +++ b/basis/furnace/syndication/syndication-docs.factor @@ -29,7 +29,7 @@ HELP: feed-entry-date HELP: feed-entry-description { $values { "object" object } - { "description" null } + { "description" string } } { $contract "Outputs a feed entry description." } ; diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index 1402e9c0ca..d2291786df 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -57,7 +57,7 @@ HELP: modify-redirect-query HELP: nested-responders { $values { "seq" "a sequence of responders" } } -{ $description "" } ; +{ $description "Outputs a sequence of responders which participated in the processing of the current request, with the main responder first and the innermost responder last." } ; HELP: referrer { $values { "referrer/f" { $maybe string } } } @@ -69,11 +69,11 @@ HELP: request-params HELP: resolve-base-path { $values { "string" string } { "string'" string } } -{ $description "" } ; +{ $description "Resolves a responder-relative URL." } ; HELP: resolve-template-path { $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } } -{ $description "" } ; +{ $description "Resolves a responder-relative template path." } ; HELP: same-host? { $values { "url" url } { "?" "a boolean" } } @@ -85,7 +85,7 @@ HELP: user-agent HELP: vocab-path { $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } } -{ $description "" } ; +{ $description "Outputs the full pathname of the vocabulary's source directory." } ; HELP: exit-with { $values { "value" object } } diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor old mode 100644 new mode 100755 index f84519b9c1..e09047b74a --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -29,7 +29,7 @@ ERROR: no-such-word name vocab ; : base-path ( string -- pair ) dup responder-nesting get - [ second class superclasses [ name>> = ] with contains? ] with find nip + [ second class superclasses [ name>> = ] with any? ] with find nip [ first ] [ "No such responder: " swap append throw ] ?if ; : resolve-base-path ( string -- string' ) diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index 14210d6070..ec13e3a750 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.order strings arrays vectors sequences -sequences.private accessors ; +sequences.private accessors fry ; IN: grouping ] dip - [ first2-unsafe ] prepose all? + '[ first2-unsafe @ ] all? ] if ] if ; inline diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index c67a378796..39b5a13e30 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -162,7 +162,8 @@ ARTICLE: "encodings-introduction" "An introduction to encodings" { $code "\"file.txt\" utf16 file-contents" } "Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text." $nl -"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ; +"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." +{ $see-also "stream-elements" } ; ARTICLE: "io" "Input and output" { $heading "Streams" } diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index a699747048..6b77f656c0 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -36,6 +36,7 @@ ARTICLE: "block-elements" "Block elements" "Elements used in " { $link $values } " forms:" { $subsection $instance } { $subsection $maybe } +{ $subsection $or } { $subsection $quotation } "Boilerplate paragraphs:" { $subsection $low-level-note } @@ -88,6 +89,12 @@ $nl { "an array of markup elements," } { "or an array of the form " { $snippet "{ $directive content... }" } ", where " { $snippet "$directive" } " is a markup word whose name starts with " { $snippet "$" } ", and " { $snippet "content..." } " is a series of markup elements" } } +"Here is a more formal schema for the help markup language:" +{ $code +" ::== | | " +" ::== { * }" +" ::== { }" +} { $subsection "element-types" } { $subsection "printing-elements" } "Related words can be cross-referenced:" @@ -119,7 +126,7 @@ ARTICLE: "help" "Help system" "The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words." { $subsection "browsing-help" } { $subsection "writing-help" } -{ $vocab-subsection "Help lint tool" "help.lint" } +{ $subsection "help.lint" } { $subsection "help-impl" } ; IN: help diff --git a/basis/help/html/html-tests.factor b/basis/help/html/html-tests.factor index 475b2114b3..61414cdfa2 100644 --- a/basis/help/html/html-tests.factor +++ b/basis/help/html/html-tests.factor @@ -1,5 +1,4 @@ IN: help.html.tests -USING: html.streams classes.predicate help.topics help.markup -io.streams.string accessors prettyprint kernel tools.test ; +USING: help.html tools.test help.topics kernel ; -[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test +[ ] [ "xml" >link help>html drop ] unit-test diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index ec52264643..26fc4e2637 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary -io.files io.files.temp io.directories html.streams html.elements help kernel +io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs tools.vocabs tools.vocabs.browser namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order -sorting debugger ; +sorting debugger html xml.literals xml.writer ; IN: help.html : escape-char ( ch -- ) @@ -51,17 +51,21 @@ M: f topic>filename* drop \ f topic>filename* ; ] "" make ] [ 2drop f ] if ; -M: topic browser-link-href topic>filename ; +M: topic url-of topic>filename ; -: help-stylesheet ( -- ) - "resource:basis/help/html/stylesheet.css" ascii file-contents write ; +: help-stylesheet ( -- string ) + "resource:basis/help/html/stylesheet.css" ascii file-contents + [XML XML] ; -: help>html ( topic -- ) - dup topic>filename utf8 [ - dup article-title - [ ] - [ [ help ] with-html-writer ] simple-page - ] with-file-writer ; +: help>html ( topic -- xml ) + [ article-title ] + [ drop help-stylesheet ] + [ [ help ] with-html-writer ] + tri simple-page ; + +: generate-help-file ( topic -- ) + dup . + dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; : all-vocabs-really ( -- seq ) #! Hack. @@ -87,7 +91,7 @@ M: topic browser-link-href topic>filename ; all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ; : generate-help-files ( -- ) - all-topics [ '[ _ help>html ] try ] each ; + all-topics [ '[ _ generate-help-file ] try ] each ; : generate-help ( -- ) "docs" temp-file diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor old mode 100644 new mode 100755 index 2f61d05a61..b5f8b78ea3 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2008 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors sequences parser kernel help help.markup help.topics words strings classes tools.vocabs namespaces make @@ -6,21 +6,24 @@ io io.streams.string prettyprint definitions arrays vectors combinators combinators.short-circuit splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate macros math sets eval -vocabs.parser words.symbol values ; +vocabs.parser words.symbol values grouping unicode.categories +sequences.deep ; IN: help.lint -: check-example ( element -- ) - rest [ - but-last "\n" join 1vector - [ - use [ clone ] change - [ eval>string ] with-datastack - ] with-scope peek "\n" ?tail drop - ] keep - peek assert= ; +SYMBOL: vocabs-quot -: check-examples ( word element -- ) - nip \ $example swap elements [ check-example ] each ; +: check-example ( element -- ) + [ + rest [ + but-last "\n" join 1vector + [ (eval>string) ] with-datastack + peek "\n" ?tail drop + ] keep + peek assert= + ] vocabs-quot get call ; + +: check-examples ( element -- ) + \ $example swap elements [ check-example ] each ; : extract-values ( element -- seq ) \ $values swap elements dup empty? [ @@ -40,7 +43,7 @@ IN: help.lint $predicate $class-description $error-description - } swap '[ _ elements empty? not ] contains? ; + } swap '[ _ elements empty? not ] any? ; : don't-check-word? ( word -- ? ) { @@ -64,8 +67,13 @@ IN: help.lint ] } 2|| [ "$values don't match stack effect" throw ] unless ; -: check-see-also ( word element -- ) - nip \ $see-also swap elements [ +: check-nulls ( element -- ) + \ $values swap elements + null swap deep-member? + [ "$values should not contain null" throw ] when ; + +: check-see-also ( element -- ) + \ $see-also swap elements [ rest dup prune [ length ] bi@ assert= ] each ; @@ -79,43 +87,88 @@ IN: help.lint ] each ; : check-rendering ( element -- ) - [ print-topic ] with-string-writer drop ; + [ print-content ] with-string-writer drop ; + +: check-strings ( str -- ) + [ + "\n\t" intersects? + [ "Paragraph text should not contain \\n or \\t" throw ] when + ] [ + " " swap subseq? + [ "Paragraph text should not contain double spaces" throw ] when + ] bi ; + +: check-whitespace ( str1 str2 -- ) + [ " " tail? ] [ " " head? ] bi* or + [ "Missing whitespace between strings" throw ] unless ; + +: check-bogus-nl ( element -- ) + { { $nl } { { $nl } } } [ head? ] with any? + [ "Simple element should not begin with a paragraph break" throw ] when ; + +: check-elements ( element -- ) + { + [ check-bogus-nl ] + [ [ string? ] filter [ check-strings ] each ] + [ [ simple-element? ] filter [ check-elements ] each ] + [ 2 [ [ string? ] all? ] filter [ first2 check-whitespace ] each ] + } cleave ; + +: check-descriptions ( element -- ) + { $description $class-description $var-description } + swap '[ + _ elements [ + rest { { } { "" } } member? + [ "Empty description" throw ] when + ] each + ] each ; + +: check-markup ( element -- ) + { + [ check-elements ] + [ check-rendering ] + [ check-examples ] + [ check-modules ] + [ check-descriptions ] + } cleave ; : all-word-help ( words -- seq ) [ word-help ] filter ; -TUPLE: help-error topic error ; +TUPLE: help-error error topic ; C: help-error M: help-error error. - "In " write dup topic>> pprint nl - error>> error. ; + [ "In " write topic>> pprint nl ] + [ error>> error. ] + bi ; : check-something ( obj quot -- ) - flush [ , ] recover ; inline + flush '[ _ assert-depth ] swap '[ _ , ] recover ; inline : check-word ( word -- ) + [ with-file-vocabs ] vocabs-quot set dup word-help [ - [ - dup word-help '[ - _ _ { - [ check-examples ] - [ check-values ] - [ check-see-also ] - [ [ check-rendering ] [ check-modules ] bi* ] - } 2cleave - ] assert-depth + dup '[ + _ dup word-help + [ check-values ] + [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi ] check-something ] [ drop ] if ; : check-words ( words -- ) [ check-word ] each ; +: check-article-title ( article -- ) + article-title first LETTER? + [ "Article title must begin with a capital letter" throw ] unless ; + : check-article ( article -- ) - [ - dup article-content - '[ _ check-rendering _ check-modules ] - assert-depth + [ with-interactive-vocabs ] vocabs-quot set + dup '[ + _ + [ check-article-title ] + [ article-content check-markup ] bi ] check-something ; : files>vocabs ( -- assoc ) @@ -135,7 +188,7 @@ M: help-error error. ] keep ; : check-about ( vocab -- ) - [ vocab-help [ article drop ] when* ] check-something ; + dup '[ _ vocab-help [ article drop ] when* ] check-something ; : check-vocab ( vocab -- seq ) "Checking " write dup write "..." print diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index b9ec34a831..0d8aa53d44 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -1,5 +1,6 @@ USING: definitions help help.markup kernel sequences tools.test -words parser namespaces assocs generic io.streams.string accessors ; +words parser namespaces assocs generic io.streams.string accessors +strings math ; IN: help.markup.tests TUPLE: blahblah quux ; @@ -15,3 +16,12 @@ TUPLE: blahblah quux ; [ ] [ \ fooey print-topic ] unit-test [ ] [ gensym print-topic ] unit-test + +[ "a string" ] +[ [ { $or string } print-element ] with-string-writer ] unit-test + +[ "a string or an integer" ] +[ [ { $or string integer } print-element ] with-string-writer ] unit-test + +[ "a string, a fixnum, or an integer" ] +[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index bf933cd9f1..2fd8d55d10 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -1,19 +1,12 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions generic io kernel assocs hashtables namespaces make parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots -vocabs help.stylesheet help.topics vocabs.loader quotations ; +vocabs help.stylesheet help.topics vocabs.loader quotations +combinators ; IN: help.markup -! Simple markup language. - -! ::== | | -! ::== { * } -! ::== { } - -! Element types are words whose name begins with $. - PREDICATE: simple-element < array [ t ] [ first word? not ] if-empty ; @@ -250,8 +243,21 @@ M: f ($instance) : $instance ( element -- ) first ($instance) ; +: $or ( element -- ) + dup length { + { 1 [ first ($instance) ] } + { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] } + [ + drop + unclip-last + [ [ ($instance) ", " print-element ] each ] + [ "or " print-element ($instance) ] + bi* + ] + } case ; + : $maybe ( element -- ) - $instance " or " print-element { f } $instance ; + f suffix $or ; : $quotation ( element -- ) { "a " { $link quotation } " with stack effect " } print-element diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index 9ed36ac77c..efb1e0a0f7 100644 --- a/basis/help/tutorial/tutorial.factor +++ b/basis/help/tutorial/tutorial.factor @@ -30,7 +30,7 @@ ARTICLE: "first-program-logic" "Writing some logic in your first program" "! See http://factorcode.org/license.txt for BSD license." "IN: palindrome" } -"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "." +"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "." $nl "Recall that a string is a palindrome if it is spelled the same forwards or backwards; that is, if the string is equal to its reverse. We can express this in Factor as follows:" { $code ": palindrome? ( string -- ? ) dup reverse = ;" } @@ -94,7 +94,7 @@ $nl "For example, we'd like it to identify the following as a palindrome:" { $code "\"A man, a plan, a canal: Panama.\"" } "However, right now, the simplistic algorithm we use says this is not a palindrome:" -{ $example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" } +{ $unchecked-example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" } "We would like it to output " { $link t } " there. We can encode this requirement with a unit test that we add to " { $snippet "palindrome-tests.factor" } ":" { $code "[ t ] [ \"A man, a plan, a canal: Panama.\" palindrome? ] unit-test" } "If you now run unit tests, you will see a unit test failure:" @@ -106,12 +106,12 @@ $nl "Start by pushing a character on the stack; notice that characters are really just integers:" { $code "CHAR: a" } "Now, use the " { $link Letter? } " word to test if it is an alphabetical character, upper or lower case:" -{ $example "Letter? ." "t" } +{ $unchecked-example "Letter? ." "t" } "This gives the expected result." $nl "Now try with a non-alphabetical character:" { $code "CHAR: #" } -{ $example "Letter? ." "f" } +{ $unchecked-example "Letter? ." "f" } "What we want to do is given a string, remove all characters which do not match the " { $link Letter? } " predicate. Let's push a string on the stack:" { $code "\"A man, a plan, a canal: Panama.\"" } "Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:" diff --git a/basis/html/components/authors.txt b/basis/html/components/authors.txt index 1901f27a24..a44f8d7f8d 100644 --- a/basis/html/components/authors.txt +++ b/basis/html/components/authors.txt @@ -1 +1,2 @@ Slava Pestov +Daniel Ehrenberg diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor index d131cc3e03..ce4bddde6a 100644 --- a/basis/html/components/components-docs.factor +++ b/basis/html/components/components-docs.factor @@ -1,4 +1,4 @@ -! 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 kernel strings urls lcs inspector present io ; @@ -70,8 +70,8 @@ HELP: render { $description "Renders an HTML component to the " { $link output-stream } "." } ; HELP: render* -{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } } -{ $contract "Renders an HTML component to the " { $link output-stream } "." } ; +{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } { "xml" "an XML chunk" } } +{ $contract "Renders an HTML component, outputting an XHTML snippet." } ; ARTICLE: "html.components" "HTML components" "The " { $vocab-link "html.components" } " vocabulary provides various HTML form components." @@ -100,6 +100,6 @@ $nl { $subsection farkup } "Creating custom components:" { $subsection render* } -"Custom components can emit HTML using the " { $vocab-link "html.elements" } " vocabulary." ; +"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ; ABOUT: "html.components" diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index b4247e6e30..410c3ce223 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -1,7 +1,8 @@ IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams -html.elements html.components html.forms namespaces ; +html.components html.forms namespaces +xml.writer ; [ ] [ begin-form ] unit-test @@ -31,7 +32,12 @@ TUPLE: color red green blue ; ] with-string-writer ] unit-test -[ "" ] [ +[ "\" name=\"red\" type=\"hidden\"/>" ] [ + [ + "red" hidden render + ] with-string-writer +] unit-test +[ "\" name=\"red\" type=\"hidden\"/>" ] [ [ "red" hidden render ] with-string-writer @@ -39,13 +45,13 @@ TUPLE: color red green blue ; [ ] [ "'jimmy'" "red" set-value ] unit-test -[ "" ] [ +[ "" ] [ [ "red" 5 >>size render ] with-string-writer ] unit-test -[ "" ] [ +[ "" ] [ [ "red" 5 >>size render ] with-string-writer @@ -105,7 +111,7 @@ TUPLE: color red green blue ; [ ] [ t "delivery" set-value ] unit-test -[ "Delivery" ] [ +[ "Delivery" ] [ [ "delivery" @@ -116,7 +122,7 @@ TUPLE: color red green blue ; [ ] [ f "delivery" set-value ] unit-test -[ "Delivery" ] [ +[ "Delivery" ] [ [ "delivery" @@ -133,7 +139,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ ] [ link-test "link" set-value ] unit-test -[ "<Link Title>" ] [ +[ "<Link Title>" ] [ [ "link" link new render ] with-string-writer ] unit-test @@ -149,7 +155,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ ] [ "java" "mode" set-value ] unit-test -[ "int x = 4;\n" ] [ +[ "int x = 4;" ] [ [ "code" "mode" >>mode render ] with-string-writer ] unit-test @@ -163,7 +169,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ t ] [ [ "object" inspector render ] with-string-writer - [ "object" value [ describe ] with-html-writer ] with-string-writer + "object" value [ describe ] with-html-writer xml>string = ] unit-test @@ -183,3 +189,9 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; } } ] [ values ] unit-test + +[ ] [ "error" "blah" "error" set-value ] unit-test + +[ ] [ + "error" hidden render +] unit-test diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index 6f35ba5d97..f811343df2 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -1,56 +1,47 @@ -! Copyright (C) 2008 Slava Pestov +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces io math.parser assocs classes classes.tuple words arrays sequences splitting mirrors hashtables combinators continuations math strings inspector -fry locals calendar calendar.format xml.entities -validators urls present -xmode.code2html lcs.diff2html farkup -html.elements html.streams html.forms ; +fry locals calendar calendar.format xml.entities xml.data +validators urls present xml.writer xml.literals xml +xmode.code2html lcs.diff2html farkup io.streams.string +html html.streams html.forms ; IN: html.components -GENERIC: render* ( value name renderer -- ) +GENERIC: render* ( value name renderer -- xml ) : render ( name renderer -- ) prepare-value [ dup validation-error? - [ [ message>> ] [ value>> ] bi ] + [ [ message>> render-error ] [ value>> ] bi ] [ f swap ] if ] 2dip render* - [ render-error ] when* ; - - ; - -PRIVATE> + swap 2array write-xml ; SINGLETON: label -M: label render* 2drop present escape-string write ; +M: label render* + 2drop present ; SINGLETON: hidden -M: hidden render* drop "hidden" render-input ; +M: hidden render* + drop [XML name=<-> type="hidden"/> XML] ; -: render-field ( value name size type -- ) - ; +: render-field ( value name size type -- xml ) + [XML name=<-> size=<-> type=<->/> XML] ; TUPLE: field size ; : ( -- field ) field new ; -M: field render* size>> "text" render-field ; +M: field render* + size>> "text" render-field ; TUPLE: password size ; @@ -67,14 +58,15 @@ TUPLE: textarea rows cols ; : ; +M:: textarea render* ( value name area -- xml ) + area rows>> :> rows + area cols>> :> cols + [XML + + XML] ; ! Choice TUPLE: choice size multiple choices ; @@ -82,24 +74,23 @@ TUPLE: choice size multiple choices ; : ( -- choice ) choice new ; -: render-option ( text selected? -- ) - ; +: render-option ( text selected? -- xml ) + "selected" and swap + [XML XML] ; -: render-options ( options selected -- ) - '[ dup _ member? render-option ] each ; +: render-options ( value choice -- xml ) + [ choices>> value ] [ multiple>> ] bi + [ swap ] [ swap 1array ] if + '[ dup _ member? render-option ] map ; -M: choice render* - ; +M:: choice render* ( value name choice -- xml ) + choice size>> :> size + choice multiple>> "true" and :> multiple + value choice render-options :> contents + [XML XML] ; ! Checkboxes TUPLE: checkbox label ; @@ -108,13 +99,10 @@ TUPLE: checkbox label ; checkbox new ; M: checkbox render* - - label>> escape-string write - ; + [ "true" and ] [ ] [ label>> ] tri* + [XML name=<->><-> XML] ; ! Link components GENERIC: link-title ( obj -- string ) @@ -129,10 +117,9 @@ M: url link-href ; TUPLE: link target ; M: link render* - nip - > [ =target ] when* dup link-href =href a> - link-title present escape-string write - ; + nip swap + [ target>> ] [ [ link-href ] [ link-title ] bi ] bi* + [XML href=<->><-> XML] ; ! XMode code component TUPLE: code mode ; @@ -161,7 +148,7 @@ M: farkup render* nip [ no-follow>> [ string>boolean link-no-follow? set ] when* ] [ disable-images>> [ string>boolean disable-images? set ] when* ] - [ parsed>> string>boolean [ (write-farkup) ] [ write-farkup ] if ] + [ parsed>> string>boolean [ (write-farkup) ] [ farkup>xml ] if ] tri ] with-scope ; @@ -180,4 +167,4 @@ M: comparison render* ! HTML component SINGLETON: html -M: html render* 2drop write ; +M: html render* 2drop ; diff --git a/basis/html/elements/elements-docs.factor b/basis/html/elements/elements-docs.factor index f6e15e46cd..7f60eca93f 100644 --- a/basis/html/elements/elements-docs.factor +++ b/basis/html/elements/elements-docs.factor @@ -1,5 +1,5 @@ +USING: help.markup help.syntax io present html ; IN: html.elements -USING: help.markup help.syntax io present ; ARTICLE: "html.elements" "HTML elements" "The " { $vocab-link "html.elements" } " vocabulary provides words for writing HTML tags to the " { $link output-stream } " with a familiar look and feel in the code." @@ -14,16 +14,12 @@ $nl { $code " \"Click me\" write " } { $code " \"click\" write " } { $code " \"click\" write " } -"Tags that have no ``closing'' equivalent have a trailing " { $snippet "tag/>" } " form:" +"Tags that have no “closing†equivalent have a trailing " { $snippet "tag/>" } " form:" { $code "" } "For the full list of HTML tags and attributes, consult the word list for the " { $vocab-link "html.elements" } " vocabulary. In addition to HTML tag and attribute words, a few utilities are provided." $nl "Writing unescaped HTML to " { $vocab-link "html.streams" } ":" { $subsection write-html } -{ $subsection print-html } -"Writing some common HTML patterns:" -{ $subsection xhtml-preamble } -{ $subsection simple-page } -{ $subsection render-error } ; +{ $subsection print-html } ; ABOUT: "html.elements" diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index 7bca545df5..e23d929d6d 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -1,12 +1,9 @@ -! cont-html v0.6 -! -! Copyright (C) 2004 Chris Double. +! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. - USING: io io.styles kernel namespaces prettyprint quotations sequences strings words xml.entities compiler.units effects -urls math math.parser combinators present fry ; - +xml.data xml.literals urls math math.parser combinators +present fry io.streams.string xml.writer html ; IN: html.elements SYMBOL: html @@ -129,23 +126,3 @@ SYMBOL: html ] [ define-attribute-word ] each >> - -: xhtml-preamble ( -- ) - "" write-html - "" write-html ; - -: simple-page ( title head-quot body-quot -- ) - #! Call the quotation, with all output going to the - #! body of an html page with the given title. - spin - xhtml-preamble - - - write - call - - call - ; inline - -: render-error ( message -- ) - escape-string write ; diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index f92f8d0764..0a69e2ed70 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors strings namespaces assocs hashtables io -mirrors math fry sequences words continuations html.elements -xml.entities ; +mirrors math fry sequences words continuations +xml.entities xml.writer xml.literals ; IN: html.forms TUPLE: form errors values validation-failed ; @@ -109,7 +109,6 @@ C: validation-error : render-validation-errors ( -- ) form get errors>> [ -
    - [
  • escape-string write
    • ] each -
+ [ [XML
  • <->
    • XML] ] map + [XML
      <->
    XML] write-xml ] unless-empty ; diff --git a/basis/html/html.factor b/basis/html/html.factor new file mode 100644 index 0000000000..5e86add10e --- /dev/null +++ b/basis/html/html.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg, +! Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel xml.data xml.writer xml.literals urls.encoding ; +IN: html + +: simple-page ( title head body -- xml ) + + + + + <-> + <-> + + <-> + + XML> ; inline + +: render-error ( message -- xml ) + [XML <-> XML] ; + +: simple-link ( xml url -- xml' ) + url-encode swap [XML ><-> XML] ; \ No newline at end of file diff --git a/basis/html/streams/streams-docs.factor b/basis/html/streams/streams-docs.factor index f05eeb30fc..c85ab739b8 100644 --- a/basis/html/streams/streams-docs.factor +++ b/basis/html/streams/streams-docs.factor @@ -1,33 +1,33 @@ IN: html.streams USING: help.markup help.syntax kernel strings io io.styles -quotations ; +quotations xml.data ; -HELP: browser-link-href -{ $values { "presented" object } { "href" string } } -{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-stream } " instances." } ; +HELP: url-of +{ $values { "object" object } { "url" string } } +{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-writer } " instances." } ; -HELP: html-stream -{ $class-description "A formatted output stream which emits HTML markup." } ; +HELP: html-writer +{ $class-description "A formatted output stream which accumulates HTML markup as " { $vocab-link "xml.data" } " types. The " { $slot "data" } " slot contains a sequence with all markup so far." } ; -HELP: -{ $values { "stream" "an output stream" } { "html-stream" html-stream } } -{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ; +HELP: +{ $values { "html-writer" html-writer } } +{ $description "Creates a new formatted output stream which accumulates HTML markup in its " { $snippet "data" } " slot." } ; HELP: with-html-writer -{ $values { "quot" quotation } } -{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." } +{ $values { "quot" quotation } { "xml" xml-chunk } } +{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-writer } ". When the quotation returns, outputs the accumulated HTML markup." } { $examples { $example - "USING: io io.styles html.streams ;" - "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer" - "Hello
    " + "USING: io io.styles html.streams xml.writer ;" + "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer write-xml" + "Hello
    " } } ; ARTICLE: "html.streams" "HTML streams" -"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream." -{ $subsection html-stream } -{ $subsection } +"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "io.styles" } " by constructing HTML markup in the form of " { $vocab-link "xml.data" } " types." +{ $subsection html-writer } +{ $subsection } { $subsection with-html-writer } ; ABOUT: "html.streams" diff --git a/basis/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor index 94229b3aea..18ab17218f 100644 --- a/basis/html/streams/streams-tests.factor +++ b/basis/html/streams/streams-tests.factor @@ -1,17 +1,14 @@ USING: html.streams html.streams.private accessors io io.streams.string io.styles kernel namespaces tools.test -xml.writer sbufs sequences inspector colors ; +xml.writer sbufs sequences inspector colors xml.writer +classes.predicate prettyprint ; IN: html.streams.tests -: make-html-string - [ with-html-writer ] with-string-writer ; inline +: make-html-string ( quot -- string ) + [ with-html-writer write-xml ] with-string-writer ; inline [ [ ] make-html-string ] must-infer -[ ] [ - 512 drop -] unit-test - [ "" ] [ [ "" write ] make-html-string ] unit-test @@ -24,22 +21,17 @@ IN: html.streams.tests [ "<" write ] make-html-string ] unit-test -[ "<" ] [ - [ "<" H{ } output-stream get format-html-span ] make-html-string -] unit-test - TUPLE: funky town ; -M: funky browser-link-href - "http://www.funky-town.com/" swap town>> append ; +M: funky url-of "http://www.funky-town.com/" swap town>> append ; -[ "<" ] [ +[ "<" ] [ [ "<" "austin" funky boa write-object ] make-html-string ] unit-test -[ "car" ] +[ "car" ] [ [ "car" @@ -48,7 +40,7 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ "car" ] +[ "car" ] [ [ "car" @@ -57,7 +49,7 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ "
    cdr
    " ] +[ "
    cdr
    " ] [ [ H{ { page-color T{ rgba f 1 0 1 1 } } } @@ -65,10 +57,10 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ - "
    " -] [ +[ "
    " ] [ [ H{ } [ ] with-nesting nl ] make-html-string ] unit-test -[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test +[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test + +[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 709b65761e..0a4b8eddd4 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -1,17 +1,17 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators generic assocs help http io io.styles -io.files continuations io.streams.string kernel math math.order -math.parser namespaces make quotations assocs sequences strings -words html.elements xml.entities sbufs continuations destructors -accessors arrays urls.encoding ; +USING: accessors kernel assocs io io.styles math math.order math.parser +sequences strings make words combinators macros xml.literals html fry +destructors ; IN: html.streams -GENERIC: browser-link-href ( presented -- href ) +GENERIC: url-of ( object -- url ) -M: object browser-link-href drop f ; +M: object url-of drop f ; -TUPLE: html-stream stream last-div ; +TUPLE: html-writer data last-div ; + +>last-div ; inline -: ( stream -- html-stream ) - f html-stream boa ; +: new-html-writer ( class -- html-writer ) + new V{ } clone >>data ; inline - >>stream + new-html-writer swap >>parent swap >>style ; inline : end-sub-stream ( substream -- string style stream ) - [ stream>> >string ] [ style>> ] [ parent>> ] tri ; + [ data>> ] [ style>> ] [ parent>> ] tri ; -: object-link-tag ( style quot -- ) - presented pick at [ - browser-link-href [ - call - ] [ call ] if* - ] [ call ] if* ; inline +: object-link-tag ( xml style -- xml ) + presented swap at [ url-of [ simple-link ] when* ] when* ; -: href-link-tag ( style quot -- ) - href pick at [ - call - ] [ call ] if* ; inline +: href-link-tag ( xml style -- xml ) + href swap at [ simple-link ] when* ; : hex-color, ( color -- ) [ red>> ] [ green>> ] [ blue>> ] tri - [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ; + [ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ; : fg-css, ( color -- ) "color: #" % hex-color, "; " % ; @@ -76,32 +67,29 @@ TUPLE: html-sub-stream < html-stream style parent ; : font-css, ( font -- ) "font-family: " % % "; " % ; -: apply-style ( style key quot -- style gadget ) - [ over at ] dip when* ; inline - -: make-css ( style quot -- str ) - "" make nip ; inline +MACRO: make-css ( pairs -- str ) + [ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map + '[ [ _ cleave ] "" make ] ; : span-css-style ( style -- str ) - [ - foreground [ fg-css, ] apply-style - background [ bg-css, ] apply-style - font [ font-css, ] apply-style - font-style [ style-css, ] apply-style - font-size [ size-css, ] apply-style - ] make-css ; + { + { foreground fg-css, } + { background bg-css, } + { font font-css, } + { font-style style-css, } + { font-size size-css, } + } make-css ; -: span-tag ( style quot -- ) - over span-css-style [ - call - ] [ - call - ] if-empty ; inline +: span-tag ( xml style -- xml ) + span-css-style + [ swap [XML ><-> XML] ] unless-empty ; inline + +: emit-html ( quot stream -- ) + dip data>> push ; inline : format-html-span ( string style stream -- ) - stream>> [ - [ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag - ] with-output-stream* ; + [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ] + emit-html ; TUPLE: html-span-stream < html-sub-stream ; @@ -113,28 +101,26 @@ M: html-span-stream dispose : padding-css, ( padding -- ) "padding: " % # "px; " % ; -: pre-css, ( margin -- ) - [ "white-space: pre; font-family: monospace; " % ] unless ; +CONSTANT: pre-css "white-space: pre; font-family: monospace;" : div-css-style ( style -- str ) [ - page-color [ bg-css, ] apply-style - border-color [ border-css, ] apply-style - border-width [ padding-css, ] apply-style - wrap-margin over at pre-css, - ] make-css ; - -: div-tag ( style quot -- ) - swap div-css-style [ - call + { + { page-color bg-css, } + { border-color border-css, } + { border-width padding-css, } + } make-css ] [ -
    call
    - ] if-empty ; inline + wrap-margin swap at + [ pre-css append ] unless + ] bi ; + +: div-tag ( xml style -- xml' ) + div-css-style + [ swap [XML
    ><->
    XML] ] unless-empty ; : format-html-div ( string style stream -- ) - stream>> [ - [ [ write ] div-tag ] object-link-tag - ] with-output-stream* ; + [ [ div-tag ] [ object-link-tag ] bi ] emit-html ; TUPLE: html-block-stream < html-sub-stream ; @@ -145,57 +131,51 @@ M: html-block-stream dispose ( quot style stream -- ) "padding: " % first2 max 2 /i # "px; " % ; : table-style ( style -- str ) - [ - table-border [ border-css, ] apply-style - table-gap [ border-spacing-css, ] apply-style - ] make-css ; - -: table-attrs ( style -- ) - table-style " border-collapse: collapse;" append =style ; - -: do-escaping ( string style -- string ) - html swap at [ escape-string ] unless ; + { + { table-border border-css, } + { table-gap border-spacing-css, } + } make-css + " border-collapse: collapse;" append ; PRIVATE> ! Stream protocol -M: html-stream stream-flush - stream>> stream-flush ; +M: html-writer stream-flush drop ; -M: html-stream stream-write1 - [ 1string ] dip stream-write ; +M: html-writer stream-write1 + not-a-div [ 1string ] emit-html ; -M: html-stream stream-write - not-a-div [ escape-string ] dip stream>> stream-write ; +M: html-writer stream-write + not-a-div [ ] emit-html ; -M: html-stream stream-format - [ html over at [ [ escape-string ] dip ] unless ] dip +M: html-writer stream-format format-html-span ; -M: html-stream stream-nl - dup last-div? [ drop ] [ [
    ] with-output-stream* ] if ; +M: html-writer stream-nl + dup last-div? [ drop ] [ [ [XML
    XML] ] emit-html ] if ; -M: html-stream make-span-stream +M: html-writer make-span-stream html-span-stream new-html-sub-stream ; -M: html-stream make-block-stream +M: html-writer make-block-stream html-block-stream new-html-sub-stream ; -M: html-stream make-cell-stream +M: html-writer make-cell-stream html-sub-stream new-html-sub-stream ; -M: html-stream stream-write-table - a-div stream>> [ - swap [ - [ - - ] with each - ] with each
    - stream>> >string write -
    - ] with-output-stream* ; +M: html-writer stream-write-table + a-div [ + table-style swap [ + [ data>> [XML ><-> XML] ] with map + [XML <-> XML] + ] with map + [XML <->
    XML] + ] emit-html ; -M: html-stream dispose stream>> dispose ; +M: html-writer dispose drop ; -: with-html-writer ( quot -- ) - output-stream get swap with-output-stream* ; inline +: ( -- html-writer ) + html-writer new-html-writer ; + +: with-html-writer ( quot -- xml ) + [ swap with-output-stream* ] keep data>> ; inline diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 542dfa0e05..19b67f7018 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -159,7 +159,7 @@ TUPLE: person first-name last-name ; "true" "b" set-value ] unit-test -[ "ab" ] [ +[ "ab" ] [ [ "test12" test-template call-template ] run-template diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index c3c1ec2b9e..e5b40fcfaa 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -5,8 +5,9 @@ namespaces make classes.tuple assocs splitting words arrays io io.files io.files.info io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml logging continuations -xml.data +xml.data xml.writer xml.literals strings html.forms +html html.elements html.components html.templates @@ -15,7 +16,6 @@ html.templates.chloe.components html.templates.chloe.syntax ; IN: html.templates.chloe -! Chloe is Ed's favorite web designer TUPLE: chloe path ; C: chloe diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 331b565b98..7180e8cdbc 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -7,16 +7,16 @@ html.templates html.templates.chloe.syntax continuations ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = ] assoc-filter ; + [ drop chloe-name? ] assoc-filter ; : non-chloe-attrs-only ( assoc -- assoc' ) - [ drop url>> chloe-ns = not ] assoc-filter ; + [ drop chloe-name? not ] assoc-filter ; : chloe-tag? ( tag -- ? ) dup xml? [ body>> ] when { { [ dup tag? not ] [ f ] } - { [ dup url>> chloe-ns = not ] [ f ] } + { [ dup chloe-name? not ] [ f ] } [ t ] } cond nip ; @@ -59,7 +59,7 @@ DEFER: compile-element : compile-start-tag ( tag -- ) "<" [write] - [ name>string [write] ] [ compile-attrs ] bi + [ name>string [write] ] [ attrs>> compile-attrs ] bi ">" [write] ; : compile-end-tag ( tag -- ) @@ -73,8 +73,8 @@ DEFER: compile-element [ compile-start-tag ] [ compile-children ] [ compile-end-tag ] - [ drop tag-stack get pop* ] - } cleave ; + } cleave + tag-stack get pop* ; ERROR: unknown-chloe-tag tag ; @@ -90,7 +90,7 @@ ERROR: unknown-chloe-tag tag ; { [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] } { [ dup string? ] [ escape-string [write] ] } { [ dup comment? ] [ drop ] } - [ [ write-xml-chunk ] [code-with] ] + [ [ write-xml ] [code-with] ] } cond ; : with-compiler ( quot -- quot' ) @@ -116,7 +116,7 @@ ERROR: unknown-chloe-tag tag ; [ [ compile-children ] compile-quot ] [ % ] bi* ; inline : compile-children>string ( tag -- ) - [ with-string-writer ] process-children ; + [ with-string-writer ] process-children ; : compile-with-scope ( quot -- ) compile-quot [ with-scope ] [code] ; inline @@ -126,7 +126,7 @@ ERROR: unknown-chloe-tag tag ; : compile-prologue ( xml -- ) [ - [ prolog>> [ write-prolog ] [code-with] ] + [ prolog>> [ write-xml ] [code-with] ] [ before>> compile-chunk ] bi ] compile-quot diff --git a/basis/html/templates/chloe/components/components.factor b/basis/html/templates/chloe/components/components.factor index 3041120d43..19f2019266 100644 --- a/basis/html/templates/chloe/components/components.factor +++ b/basis/html/templates/chloe/components/components.factor @@ -21,7 +21,8 @@ M: singleton-class component-tag ( tag class -- ) bi ; M: tuple-class component-tag ( tag class -- ) - [ drop "name" required-attr compile-attr ] [ compile-component-attrs ] 2bi + [ drop "name" required-attr compile-attr ] + [ compile-component-attrs ] 2bi [ render ] [code] ; : COMPONENT: diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index 90c171917b..c2ecd4506b 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -6,7 +6,6 @@ classes.tuple assocs splitting words arrays memoize parser lexer io io.files io.encodings.utf8 io.streams.string unicode.case mirrors fry math urls multiline xml xml.data xml.writer xml.utilities -html.elements html.components html.templates ; @@ -21,14 +20,14 @@ tags global [ H{ } clone or ] change-at : chloe-ns "http://factorcode.org/chloe/1.0" ; inline -: chloe-name ( string -- name ) - name new - swap >>main - chloe-ns >>url ; +: chloe-name? ( name -- ? ) + url>> chloe-ns = ; + +XML-NS: chloe-name http://factorcode.org/chloe/1.0 : required-attr ( tag name -- value ) - dup chloe-name rot at* - [ nip ] [ drop " attribute is required" append throw ] if ; + tuck chloe-name attr + [ nip ] [ " attribute is required" append throw ] if* ; : optional-attr ( tag name -- value ) - chloe-name swap at ; + chloe-name attr ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index 992b660070..c419c4a197 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -1,12 +1,10 @@ ! Copyright (C) 2005 Alex Chapman -! Copyright (C) 2006, 2008 Slava Pestov +! Copyright (C) 2006, 2009 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 lexer io io.files io.streams.string io.encodings.utf8 -html.elements -html.templates ; +combinators math quotations generic strings splitting accessors +assocs fry vocabs.parser parser lexer io io.files +io.streams.string io.encodings.utf8 html.templates ; IN: html.templates.fhtml ! We use a custom lexer so that %> ends a token even if not @@ -34,13 +32,13 @@ DEFER: <% delimiter [ over line-text>> [ column>> ] 2dip subseq parsed - \ write-html parsed + \ write parsed ] 2keep 2 + >>column drop ; : still-looking ( accum lexer -- accum ) [ [ line-text>> ] [ column>> ] bi tail - parsed \ print-html parsed + parsed \ print parsed ] keep next-line ; : parse-%> ( accum lexer -- accum ) diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index 57418a3e02..efaf8d6a62 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel fry io io.encodings.utf8 io.files debugger prettyprint continuations namespaces boxes sequences -arrays strings html.elements io.streams.string -quotations xml.data xml.writer ; +arrays strings html io.streams.string +quotations xml.data xml.writer xml.literals ; IN: html.templates MIXIN: template @@ -53,9 +53,13 @@ SYMBOL: atom-feeds : write-atom-feeds ( -- ) atom-feeds get [ - + first2 [XML + + href=<->/> + XML] write-xml ] each ; SYMBOL: nested-template? @@ -63,7 +67,7 @@ SYMBOL: nested-template? SYMBOL: next-template : call-next-template ( -- ) - next-template get write-html ; + next-template get write ; M: f call-template* drop call-next-template ; diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 7031f5d16c..9a8aa48738 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -1,6 +1,6 @@ USING: http help.markup help.syntax io.pathnames io.streams.string io.encodings.8-bit io.encodings.binary kernel strings urls -urls.encoding byte-arrays strings assocs sequences ; +urls.encoding byte-arrays strings assocs sequences destructors ; IN: http.client HELP: download-failed @@ -36,7 +36,12 @@ HELP: http-get HELP: http-post { $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } } -{ $description "Submits a form at a URL." } +{ $description "Submits an HTTP POST 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." } { $errors "Throws an error if the HTTP request fails." } ; HELP: with-http-get @@ -67,17 +72,36 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client" { $subsection with-http-get } { $subsection with-http-request } ; -ARTICLE: "http.client.post" "POST requests with the HTTP client" -"As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":" -{ $subsection http-post } -{ $subsection } -"Both words take a post data parameter, which can be one of the following:" +ARTICLE: "http.client.post-data" "HTTP client submission data" +"HTTP POST and PUT request words take a post data parameter, which can be one of the following:" { $list - { "a " { $link byte-array } " or " { $link string } " is sent the server without further encoding" } - { "an " { $link assoc } " is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } } + { "a " { $link byte-array } ": the data is sent the server without further encoding" } + { "a " { $link string } ": the data is encoded and then sent as a series of bytes" } + { "an " { $link assoc } ": the assoc is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } } + { "an input stream: the contents of the input stream are transmitted to the server without being read entirely into memory - this is useful for large requests" } { { $link f } " denotes that there is no post data" } + { "a " { $link post-data } " tuple, for additional control" } +} +"When passing a stream, you must ensure the stream is closed afterwards. The best way is to use " { $link with-disposal } " or " { $link "destructors" } ". For example," +{ $code + "\"my-large-post-request.txt\" ascii " + "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal" } ; +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:" +{ $subsection http-post } +"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" +{ $subsection } +"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:" +{ $subsection http-post } +"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" +{ $subsection } +"Both words take a post data parameter; see " { $link "http.client.post-data" } "." ; + ARTICLE: "http.client.encoding" "Character encodings and the HTTP client" "The " { $link http-request } ", " { $link http-get } " and " { $link http-post } " words output a sequence containing data that was sent by the server." $nl @@ -95,11 +119,14 @@ ARTICLE: "http.client.errors" "HTTP client errors" ARTICLE: "http.client" "HTTP client" "The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "." $nl -"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't load it, HTTPS will not load and images generated by " { $vocab-link "tools.deploy" } " will be smaller as a result." +"For HTTPS support, you must load the " { $vocab-link "urls.secure" } " vocab first. If you don't need HTTPS support, don't load " { $vocab-link "urls.secure" } "; this will reduce the size of images generated by " { $vocab-link "tools.deploy" } "." $nl "There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:" { $subsection "http.client.get" } { $subsection "http.client.post" } +{ $subsection "http.client.put" } +"Submission data for POST and PUT requests:" +{ $subsection "http.client.post-data" } "More esoteric use-cases, for example HTTP methods other than the above, are accomodated by constructing an empty request object with " { $link } " and filling everything in by hand." { $subsection "http.client.encoding" } { $subsection "http.client.errors" } diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index f8106f4c83..cc1c67c31e 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -1,15 +1,21 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math math.parser namespaces make sequences strings splitting calendar continuations accessors vectors math.order hashtables byte-arrays destructors io io.sockets io.streams.string io.files io.timeouts io.pathnames io.encodings io.encodings.string io.encodings.ascii -io.encodings.utf8 io.encodings.8-bit io.encodings.binary +io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf io.streams.duplex fry ascii urls urls.encoding present -http http.parsers ; +http http.parsers http.client.post-data ; IN: http.client +ERROR: too-many-redirects ; + +CONSTANT: max-redirects 10 + +> write bl ] @@ -21,53 +27,19 @@ IN: http.client [ host>> ] [ port>> ] bi dup "http" protocol-port = [ drop ] [ ":" swap number>string 3append ] if ; +: set-host-header ( request header -- request header ) + over url>> url-host "host" pick set-at ; + +: set-cookie-header ( header cookies -- header ) + unparse-cookie "cookie" pick set-at ; + : write-request-header ( request -- request ) dup header>> >hashtable - over url>> host>> [ over url>> url-host "host" pick set-at ] when - over post-data>> [ - [ data>> length "content-length" pick set-at ] - [ content-type>> "content-type" pick set-at ] - bi - ] when* - over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty + over url>> host>> [ set-host-header ] when + over post-data>> [ set-post-data-headers ] when* + over cookies>> [ set-cookie-header ] unless-empty write-header ; -GENERIC: >post-data ( object -- post-data ) - -M: f >post-data ; - -M: post-data >post-data ; - -M: string >post-data - utf8 encode - "application/octet-stream" - swap >>data ; - -M: assoc >post-data - "application/x-www-form-urlencoded" - swap >>params ; - -M: object >post-data - "application/octet-stream" - swap >>data ; - -: normalize-post-data ( request -- request ) - dup post-data>> [ - dup params>> [ - assoc>query ascii encode >>data - ] when* drop - ] when* ; - -: unparse-post-data ( request -- request ) - [ >post-data ] change-post-data - normalize-post-data ; - -: write-post-data ( request -- request ) - dup method>> { "POST" "PUT" } member? [ - dup post-data>> data>> dup sequence? - [ write ] [ output-stream get stream-copy ] if - ] when ; - : write-request ( request -- ) unparse-post-data write-request-line @@ -95,12 +67,6 @@ M: object >post-data read-response-line read-response-header ; -: max-redirects 10 ; - -ERROR: too-many-redirects ; - - [ "Bad chunk size" throw ] unless* ; : read-chunked ( quot: ( chunk -- ) -- ) @@ -130,15 +96,10 @@ SYMBOL: redirects read-crlf B{ } assert= read-chunked ] if ; inline recursive -: read-unchunked ( quot: ( chunk -- ) -- ) - 8192 read-partial dup [ - [ swap call ] [ drop read-unchunked ] 2bi - ] [ 2drop ] if ; inline recursive - : read-response-body ( quot response -- ) binary decode-input "transfer-encoding" header "chunked" = - [ read-chunked ] [ read-unchunked ] if ; inline + [ read-chunked ] [ each-block ] if ; inline : ( -- stream ) request get url>> url-addr ascii drop @@ -166,6 +127,11 @@ SYMBOL: redirects [ do-redirect ] [ nip ] if ] with-variable ; inline recursive +: ( url method -- request ) + + swap >>method + swap >url ensure-port >>url ; inline + PRIVATE> : success? ( code -- ? ) 200 299 between? ; @@ -176,16 +142,14 @@ ERROR: download-failed response ; dup code>> success? [ download-failed ] unless ; : with-http-request ( request quot -- response ) - (with-http-request) check-response ; inline + [ (with-http-request) check-response ] with-destructors ; inline : http-request ( request -- response data ) [ [ % ] with-http-request ] B{ } make over content-charset>> decode ; : ( url -- request ) - - "GET" >>method - swap >url ensure-port >>url ; + "GET" ; : http-get ( url -- response data ) http-request ; @@ -203,14 +167,19 @@ ERROR: download-failed response ; dup download-name download-to ; : ( post-data url -- request ) - - "POST" >>method - swap >url ensure-port >>url + "POST" swap >>post-data ; : http-post ( post-data url -- response data ) http-request ; +: ( post-data url -- request ) + "PUT" + swap >>post-data ; + +: http-put ( post-data url -- response data ) + http-request ; + USING: vocabs vocabs.loader ; "debugger" vocab [ "http.client.debugger" require ] when diff --git a/basis/http/client/post-data/authors.txt b/basis/http/client/post-data/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/http/client/post-data/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/http/client/post-data/post-data-tests.factor b/basis/http/client/post-data/post-data-tests.factor new file mode 100644 index 0000000000..2704ce169f --- /dev/null +++ b/basis/http/client/post-data/post-data-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test http.client.post-data ; +IN: http.client.post-data.tests diff --git a/basis/http/client/post-data/post-data.factor b/basis/http/client/post-data/post-data.factor new file mode 100644 index 0000000000..b7551d86b9 --- /dev/null +++ b/basis/http/client/post-data/post-data.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs destructors http io io.encodings.ascii +io.encodings.binary io.encodings.string io.encodings.utf8 +io.files io.files.info io.pathnames kernel math.parser +namespaces sequences strings urls.encoding ; +IN: http.client.post-data + +TUPLE: measured-stream stream size ; + +C: measured-stream + +> "content-length" pick set-at ; + +M: object (set-post-data-headers) + drop "chunked" "transfer-encoding" pick set-at ; + +PRIVATE> + +: set-post-data-headers ( header post-data -- header ) + [ data>> (set-post-data-headers) ] + [ content-type>> "content-type" pick set-at ] bi ; + +> [ [ write ] each-block ] with-input-stream ; + +: write-chunk ( chunk -- ) + [ length >hex ";\r\n" append ascii encode write ] [ write ] bi ; + +M: object (write-post-data) + [ [ write-chunk ] each-block ] with-input-stream + "0;\r\n" ascii encode write ; + +GENERIC: >post-data ( object -- post-data ) + +M: f >post-data ; + +M: post-data >post-data ; + +M: string >post-data + utf8 encode + "application/octet-stream" + swap >>data ; + +M: assoc >post-data + "application/x-www-form-urlencoded" + swap >>params ; + +M: object >post-data + "application/octet-stream" + swap >>data ; + +: pathname>measured-stream ( pathname -- stream ) + string>> + [ binary &dispose ] + [ file-info size>> ] bi + ; + +: normalize-post-data ( request -- request ) + dup post-data>> [ + dup params>> [ + assoc>query ascii encode >>data + ] when* + dup data>> pathname? [ + [ pathname>measured-stream ] change-data + ] when + drop + ] when* ; + +PRIVATE> + +: unparse-post-data ( request -- request ) + [ >post-data ] change-post-data + normalize-post-data ; + +: write-post-data ( request -- request ) + dup post-data>> [ data>> (write-post-data) ] when* ; diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor index 6fb5b73fad..fc3f65fa56 100644 --- a/basis/http/http-docs.factor +++ b/basis/http/http-docs.factor @@ -30,7 +30,7 @@ $nl { $table { { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } } { { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } } - { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } } + { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be “Successâ€, for example." } } { { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } } { { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } } { { $slot "content-type" } { "an HTTP content type" } } @@ -49,7 +49,7 @@ $nl { $table { { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } } { { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } } - { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } } + { { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be “Successâ€, for example." } } { { $slot "body" } { "an HTTP response body" } } } } ; @@ -90,7 +90,7 @@ HELP: put-cookie { $side-effects "request/response" } ; HELP: -{ $values { "raw" byte-array } { "content-type" "a MIME type string" } { "post-data" post-data } } +{ $values { "content-type" "a MIME type string" } { "post-data" post-data } } { $description "Creates a new " { $link post-data } "." } ; HELP: header @@ -110,7 +110,7 @@ $nl HELP: set-header { $values { "request/response" "a " { $link request } " or a " { $link response } } { "value" object } { "key" string } } { $description "Stores a value into the HTTP header of a request or response. The value can be any object supported by " { $link present } "." } -{ $notes "This word always returns the same object that was input. This allows for a ``pipeline'' coding style, where several header parameters are set in a row." } +{ $notes "This word always returns the same object that was input. This allows for a “pipeline†coding style, where several header parameters are set in a row." } { $side-effects "request/response" } ; ARTICLE: "http.cookies" "HTTP cookies" diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 6fa23b4b1f..f593980467 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -1,8 +1,8 @@ -USING: http http.server http.client tools.test multiline +USING: http http.server http.client http.client.private tools.test multiline io.streams.string io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.encodings.string kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls -hashtables accessors namespaces ; +hashtables accessors namespaces xml.data ; IN: http.tests [ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test @@ -298,7 +298,7 @@ test-db [ [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test -USING: html.components html.elements html.forms +USING: html.components html.forms xml xml.utilities validators furnace furnace.conversations ; @@ -308,7 +308,7 @@ SYMBOL: a [ a get-global "a" set-value ] >>init - [ [ "a" render ] "text/html" ] >>display + [ [ "" write "a" render "" write ] "text/html" ] >>display [ { { "a" [ v-integer ] } } validate-params ] >>validate [ "a" value a set-global URL" " ] >>submit @@ -322,7 +322,8 @@ SYMBOL: a 3 a set-global -: test-a string>xml "input" tag-named "value" swap at ; +: test-a ( xml -- value ) + string>xml body>> "input" deep-tag-named "value" attr ; [ "3" ] [ "http://localhost/" add-port http-get diff --git a/basis/http/http.factor b/basis/http/http.factor index c85cfc9c41..cda3460c71 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -6,7 +6,7 @@ quotations arrays byte-arrays math.parser calendar calendar.format present urls io io.encodings io.encodings.iana io.encodings.binary -io.encodings.8-bit +io.encodings.8-bit io.crlf unicode.case unicode.categories @@ -16,12 +16,6 @@ EXCLUDE: fry => , ; IN: http -: crlf ( -- ) "\r\n" write ; - -: read-crlf ( -- bytes ) - "\r" read-until - [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; - : (read-header) ( -- alist ) [ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ; diff --git a/basis/http/server/cgi/cgi.factor b/basis/http/server/cgi/cgi.factor index 959642b706..a64fe9af3c 100644 --- a/basis/http/server/cgi/cgi.factor +++ b/basis/http/server/cgi/cgi.factor @@ -55,7 +55,7 @@ IN: http.server.cgi binary encode-output _ output-stream get swap binary [ post-request? [ request get post-data>> data>> write flush ] when - input-stream get swap (stream-copy) + '[ _ write ] each-block ] with-stream ] >>body ; diff --git a/basis/http/server/dispatchers/dispatchers-docs.factor b/basis/http/server/dispatchers/dispatchers-docs.factor index 71842f6491..e0f7f20e69 100644 --- a/basis/http/server/dispatchers/dispatchers-docs.factor +++ b/basis/http/server/dispatchers/dispatchers-docs.factor @@ -41,7 +41,7 @@ main-responder set-global"> } "In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error." { $heading "Another pathname dispatcher" } -"On the other hand, suppose we wanted to route all unrecognized paths to a ``view'' action:" +"On the other hand, suppose we wanted to route all unrecognized paths to a “view†action:" { $code <" "new" add-responder diff --git a/basis/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor index 5b5b30adde..2c8db27259 100644 --- a/basis/http/server/dispatchers/dispatchers-tests.factor +++ b/basis/http/server/dispatchers/dispatchers-tests.factor @@ -4,7 +4,6 @@ assocs arrays classes words urls ; IN: http.server.dispatchers.tests \ find-responder must-infer -\ http-error. must-infer TUPLE: mock-responder path ; diff --git a/basis/http/server/responses/responses.factor b/basis/http/server/responses/responses.factor index 4056f0c7f0..c9b4600ac8 100644 --- a/basis/http/server/responses/responses.factor +++ b/basis/http/server/responses/responses.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: html.elements math.parser http accessors kernel +USING: math.parser http accessors kernel xml.literals xml.writer io io.streams.string io.encodings.utf8 ; IN: http.server.responses @@ -13,11 +13,13 @@ IN: http.server.responses swap >>body ; : trivial-response-body ( code message -- ) - - -

    [ number>string write bl ] [ write ] bi*

    - - ; + + +

    <-> <->

    + + + XML> write-xml ; : ( code message -- response ) 2dup [ trivial-response-body ] with-string-writer diff --git a/basis/http/server/server-tests.factor b/basis/http/server/server-tests.factor index c29912b8c7..fdba9a63ef 100644 --- a/basis/http/server/server-tests.factor +++ b/basis/http/server/server-tests.factor @@ -2,3 +2,5 @@ USING: http http.server math sequences continuations tools.test ; IN: http.server.tests [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test + +\ make-http-error must-infer diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index c328e1d6a3..97c14a6457 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -12,8 +12,10 @@ io.encodings.utf8 io.encodings.ascii io.encodings.binary io.streams.limited +io.streams.string io.servers.connection io.timeouts +io.crlf fry logging logging.insomniac calendar urls urls.encoding mime.multipart unicode.categories @@ -22,12 +24,11 @@ http.parsers http.server.responses http.server.remapping html.templates -html.elements -html.streams ; +html.streams +html +xml.writer ; IN: http.server -\ parse-cookie DEBUG add-input-logging - : check-absolute ( url -- url ) dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline @@ -44,7 +45,7 @@ ERROR: no-boundary ; ";" split1 nip "=" split1 nip [ no-boundary ] unless* ; -: read-multipart-data ( request -- form-variables uploaded-files ) +: read-multipart-data ( request -- mime-parts ) [ "content-type" header ] [ "content-length" header string>number ] bi unlimit-input @@ -57,7 +58,7 @@ ERROR: no-boundary ; : parse-content ( request content-type -- post-data ) [ swap ] keep { - { "multipart/form-data" [ read-multipart-data assoc-union >>params ] } + { "multipart/form-data" [ read-multipart-data >>params ] } { "application/x-www-form-urlencoded" [ read-content query>assoc >>params ] } [ drop read-content >>data ] } case ; @@ -173,14 +174,14 @@ main-responder global [ <404> or ] change-at : call-responder ( path responder -- response ) [ add-responder-nesting ] [ call-responder* ] 2bi ; -: http-error. ( error -- ) - "Internal server error" [ ] [ - [ print-error nl :c ] with-html-writer - ] simple-page ; +: make-http-error ( error -- xml ) + [ "Internal server error" f ] dip + [ print-error nl :c ] with-html-writer + simple-page ; : <500> ( error -- response ) 500 "Internal server error" - swap development? get [ '[ _ http-error. ] >>body ] [ drop ] if ; + swap development? get [ make-http-error >>body ] [ drop ] if ; : do-response ( response -- ) [ request get swap write-full-response ] @@ -189,7 +190,8 @@ main-responder global [ <404> or ] change-at [ utf8 [ development? get - [ http-error. ] [ drop "Response error" write ] if + [ make-http-error ] [ drop "Response error" ] if + write-xml ] with-encoded-output ] bi ] recover ; @@ -198,8 +200,8 @@ LOG: httpd-hit NOTICE LOG: httpd-header NOTICE -: log-header ( headers name -- ) - tuck header 2array httpd-header ; +: log-header ( request name -- ) + [ nip ] [ header ] 2bi 2array httpd-header ; : log-request ( request -- ) [ [ method>> ] [ url>> ] bi 2array httpd-hit ] diff --git a/basis/http/server/static/static-tests.factor b/basis/http/server/static/static-tests.factor new file mode 100644 index 0000000000..d54be03698 --- /dev/null +++ b/basis/http/server/static/static-tests.factor @@ -0,0 +1,4 @@ +IN: http.server.static.tests +USING: http.server.static tools.test xml.writer ; + +[ ] [ "resource:basis" directory>html write-xml ] unit-test \ No newline at end of file diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index b19bf2ae55..2df8838061 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -4,9 +4,9 @@ USING: calendar kernel math math.order math.parser namespaces parser sequences strings assocs hashtables debugger mime.types sorting logging calendar.format accessors splitting io io.files io.files.info io.directories io.pathnames io.encodings.binary -fry xml.entities destructors urls html.elements +fry xml.entities destructors urls html xml.literals html.templates.fhtml http http.server http.server.responses -http.server.redirection ; +http.server.redirection xml.writer ; IN: http.server.static TUPLE: file-responder root hook special allow-listings ; @@ -45,9 +45,9 @@ TUPLE: file-responder root hook special allow-listings ; [ file-responder get hook>> call ] [ 2drop <304> ] if ; : serving-path ( filename -- filename ) - file-responder get root>> trim-right-separators + file-responder get root>> trim-tail-separators "/" - rot "" or trim-left-separators 3append ; + rot "" or trim-head-separators 3append ; : serve-file ( filename -- response ) dup mime-type @@ -56,23 +56,22 @@ TUPLE: file-responder root hook special allow-listings ; \ serve-file NOTICE add-input-logging -: file. ( name -- ) +: file>html ( name -- xml ) dup link-info directory? [ "/" append ] when - dup escape-string write ; + dup [XML
  • ><->
    • XML] ; -: directory. ( path -- ) - dup file-name [ ] [ - [

    file-name escape-string write

    ] - [ -
      - directory-files [
    • file.
      • ] each -
    - ] bi - ] simple-page ; +: directory>html ( path -- xml ) + [ file-name ] + [ drop f ] + [ + [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi + [XML

    <->

      <->
    XML] + ] tri + simple-page ; : list-directory ( directory -- response ) file-responder get allow-listings>> [ - '[ _ directory. ] "text/html" + directory>html "text/html" ] [ drop <403> ] if ; diff --git a/basis/interpolate/interpolate.factor b/basis/interpolate/interpolate.factor index 5e4805a8ac..5c859f8947 100644 --- a/basis/interpolate/interpolate.factor +++ b/basis/interpolate/interpolate.factor @@ -1,9 +1,11 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel macros make multiline namespaces parser present sequences strings splitting fry accessors ; IN: interpolate +> '[ _ get present write ] ] + [ name>> @ '[ _ @ present write ] ] [ '[ _ write ] ] if - ] map [ ] join ; + ] map [ ] join ; inline + +PRIVATE> + +MACRO: interpolate ( string -- ) + [ [ get ] ] (interpolate) ; : interpolate-locals ( string -- quot ) - parse-interpolate [ - dup interpolate-var? - [ name>> search '[ _ present write ] ] - [ '[ _ write ] ] - if - ] map [ ] join ; + [ search [ ] ] (interpolate) ; -: I[ "]I" parse-multiline-string - interpolate-locals parsed \ call parsed ; parsing +: I[ + "]I" parse-multiline-string + interpolate-locals over push-all ; parsing diff --git a/basis/interval-maps/interval-maps-docs.factor b/basis/interval-maps/interval-maps-docs.factor index 1a862fbe2d..de18458546 100644 --- a/basis/interval-maps/interval-maps-docs.factor +++ b/basis/interval-maps/interval-maps-docs.factor @@ -18,7 +18,8 @@ HELP: { $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ; ARTICLE: "interval-maps" "Interval maps" -"Interval maps are a mechanism, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between." +"The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between." +$nl "The following operations are used to query interval maps:" { $subsection interval-at* } { $subsection interval-at } diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index 34e43ddc75..4fd4592ee1 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -31,7 +31,8 @@ PRIVATE> : interval-at* ( key map -- value ? ) [ drop ] [ array>> find-interval ] 2bi - tuck interval-contains? [ third t ] [ drop f f ] if ; + [ nip ] [ interval-contains? ] 2bi + [ third t ] [ drop f f ] if ; : interval-at ( key map -- value ) interval-at* drop ; diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index e25550590f..4bc8868a3c 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -164,10 +164,10 @@ M: stdin refill size-read-fd init-fd >>size data-read-fd >>data ; -M: unix (init-stdio) ( -- ) +M: unix (init-stdio) 1 - 2 ; + 2 t ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index 493a735f7f..c6b24a0a11 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -120,6 +120,9 @@ M: winnt (wait-to-read) ( port -- ) tri ] with-destructors ; -M: winnt (init-stdio) init-c-stdio ; +: console-app? ( -- ? ) GetConsoleWindow >boolean ; + +M: winnt (init-stdio) + console-app? [ init-c-stdio t ] [ f f f f ] if ; winnt set-io-backend diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index e7c72edfd0..6ecbc49f2a 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -51,4 +51,4 @@ HOOK: add-completion io-backend ( port -- ) : default-security-attributes ( -- obj ) "SECURITY_ATTRIBUTES" "SECURITY_ATTRIBUTES" heap-size - over set-SECURITY_ATTRIBUTES-nLength ; + over set-SECURITY_ATTRIBUTES-nLength ; \ No newline at end of file diff --git a/basis/io/crlf/authors.txt b/basis/io/crlf/authors.txt new file mode 100644 index 0000000000..33616a2d6a --- /dev/null +++ b/basis/io/crlf/authors.txt @@ -0,0 +1,2 @@ +Daniel Ehrenberg +Slava Pestov diff --git a/basis/io/crlf/crlf-docs.factor b/basis/io/crlf/crlf-docs.factor new file mode 100644 index 0000000000..ac7c8c324e --- /dev/null +++ b/basis/io/crlf/crlf-docs.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup sequences ; +IN: io.crlf + +HELP: crlf +{ $values } +{ $description "Prints a carriage return and line feed to the current output stream, used to indicate a newline for certain network protocols." } ; + +HELP: read-crlf +{ $values { "seq" sequence } } +{ $description "Reads until the next CRLF (carriage return followed by line feed) from the current input stream, throwing an error if there is not a CRLF remaining, or if CR is present without immediately being followed by LF." } ; diff --git a/basis/io/crlf/crlf.factor b/basis/io/crlf/crlf.factor new file mode 100644 index 0000000000..53dddce199 --- /dev/null +++ b/basis/io/crlf/crlf.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: io kernel ; +IN: io.crlf + +: crlf ( -- ) + "\r\n" write ; + +: read-crlf ( -- seq ) + "\r" read-until + [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; diff --git a/basis/io/crlf/summary.txt b/basis/io/crlf/summary.txt new file mode 100644 index 0000000000..2fa6a6e2c1 --- /dev/null +++ b/basis/io/crlf/summary.txt @@ -0,0 +1 @@ +Writing and reading until \r\n diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor index 427472db0f..7318df9cac 100644 --- a/basis/io/directories/directories-docs.factor +++ b/basis/io/directories/directories-docs.factor @@ -5,13 +5,13 @@ IN: io.directories HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } +{ $errors "Windows CE has no concept of “current directoryâ€, so this word throws an error there." } { $notes "User code should use the value of the " { $link current-directory } " variable instead." } ; HELP: cd { $values { "path" "a pathname string" } } { $description "Changes the current working directory of the Factor process." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } +{ $errors "Windows CE has no concept of “current directoryâ€, so this word throws an error there." } { $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ; { cd cwd current-directory set-current-directory with-directory } related-words @@ -116,7 +116,7 @@ ARTICLE: "current-directory" "Current working directory" "This variable can be changed with a pair of words:" { $subsection set-current-directory } { $subsection with-directory } -"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:" +"This variable is independent of the operating system notion of “current working directoryâ€. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:" { $subsection (normalize-path) } "The second is to change the working directory of the current process:" { $subsection cd } @@ -166,6 +166,7 @@ ARTICLE: "io.directories" "Directory manipulation" { $subsection "current-directory" } { $subsection "io.directories.listing" } { $subsection "io.directories.create" } -{ $subsection "delete-move-copy" } ; +{ $subsection "delete-move-copy" } +{ $subsection "io.directories.hierarchy" } ; ABOUT: "io.directories" diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor index 6ae55b7f7b..30f4cebf8d 100755 --- a/basis/io/directories/directories.factor +++ b/basis/io/directories/directories.factor @@ -15,7 +15,7 @@ IN: io.directories HOOK: make-directory io-backend ( path -- ) : make-directories ( path -- ) - normalize-path trim-right-separators { + normalize-path trim-tail-separators { { [ dup "." = ] [ ] } { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } @@ -87,4 +87,4 @@ M: object copy-file { { [ os unix? ] [ "io.directories.unix" require ] } { [ os windows? ] [ "io.directories.windows" require ] } -} cond \ No newline at end of file +} cond diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index 8944f17dff..99135b7953 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -52,7 +52,7 @@ HELP: find-all-in-directories { find-file find-all-files find-in-directories find-all-in-directories } related-words -ARTICLE: "io.directories.search" "io.directories.search" +ARTICLE: "io.directories.search" "Searching directories" "The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl "Traversing directories:" { $subsection recursive-directory } diff --git a/basis/io/directories/search/search-tests.factor b/basis/io/directories/search/search-tests.factor index 63c9483331..a8b8bf9215 100644 --- a/basis/io/directories/search/search-tests.factor +++ b/basis/io/directories/search/search-tests.factor @@ -4,8 +4,7 @@ IN: io.directories.search.tests [ t ] [ [ - 10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate - current-directory get t [ ] find-all-files - ] with-unique-directory - [ natural-sort ] bi@ = + 10 [ "io.paths.test" "gogogo" make-unique-file ] replicate + current-temporary-directory get t [ ] find-all-files + ] with-unique-directory drop [ natural-sort ] bi@ = ] unit-test diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor index c2955d3977..a6dacc1841 100755 --- a/basis/io/directories/windows/windows.factor +++ b/basis/io/directories/windows/windows.factor @@ -33,13 +33,13 @@ M: windows delete-directory ( path -- ) RemoveDirectory win32-error=0/f ; : find-first-file ( path -- WIN32_FIND_DATA handle ) - "WIN32_FIND_DATA" tuck - FindFirstFile + "WIN32_FIND_DATA" + [ nip ] [ FindFirstFile ] 2bi [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ; : find-next-file ( path -- WIN32_FIND_DATA/f ) - "WIN32_FIND_DATA" tuck - FindNextFile 0 = [ + "WIN32_FIND_DATA" + [ nip ] [ FindNextFile ] 2bi 0 = [ GetLastError ERROR_NO_MORE_FILES = [ win32-error ] unless drop f diff --git a/basis/io/encodings/8-bit/8-bit-docs.factor b/basis/io/encodings/8-bit/8-bit-docs.factor index 8f5e955998..9ba4fcf44d 100644 --- a/basis/io/encodings/8-bit/8-bit-docs.factor +++ b/basis/io/encodings/8-bit/8-bit-docs.factor @@ -4,7 +4,7 @@ USING: help.syntax help.markup io.encodings.8-bit.private strings ; IN: io.encodings.8-bit -ARTICLE: "io.encodings.8-bit" "8-bit encodings" +ARTICLE: "io.encodings.8-bit" "Legacy 8-bit encodings" "Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are already defined:" { $subsection latin1 } { $subsection latin2 } diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor index 0803ba3871..d971cf2e60 100644 --- a/basis/io/encodings/ascii/ascii.factor +++ b/basis/io/encodings/ascii/ascii.factor @@ -9,7 +9,8 @@ IN: io.encodings.ascii : decode-if< ( stream encoding max -- character ) nip swap stream-read1 dup - [ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline + [ [ nip ] [ > ] 2bi [ >fixnum ] [ drop replacement-char ] if ] + [ 2drop f ] if ; inline PRIVATE> SINGLETON: ascii diff --git a/basis/io/files/info/unix/freebsd/freebsd.factor b/basis/io/files/info/unix/freebsd/freebsd.factor index 11025e14e6..61d7a1d921 100644 --- a/basis/io/files/info/unix/freebsd/freebsd.factor +++ b/basis/io/files/info/unix/freebsd/freebsd.factor @@ -13,7 +13,7 @@ version io-size owner syncreads syncwrites asyncreads asyncwrites ; M: freebsd new-file-system-info freebsd-file-system-info new ; M: freebsd file-system-statfs ( path -- byte-array ) - "statfs" tuck statfs io-error ; + "statfs" [ statfs io-error ] keep ; M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info ) { @@ -40,7 +40,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf } cleave ; M: freebsd file-system-statvfs ( path -- byte-array ) - "statvfs" tuck statvfs io-error ; + "statvfs" [ statvfs io-error ] keep ; M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info ) { diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index b447b6e54f..5dddca4f9d 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -14,7 +14,7 @@ namelen ; M: linux new-file-system-info linux-file-system-info new ; M: linux file-system-statfs ( path -- byte-array ) - "statfs64" tuck statfs64 io-error ; + "statfs64" [ statfs64 io-error ] keep ; M: linux statfs>file-system-info ( struct -- statfs ) { @@ -32,7 +32,7 @@ M: linux statfs>file-system-info ( struct -- statfs ) } cleave ; M: linux file-system-statvfs ( path -- byte-array ) - "statvfs64" tuck statvfs64 io-error ; + "statvfs64" [ statvfs64 io-error ] keep ; M: linux statvfs>file-system-info ( struct -- statfs ) { diff --git a/basis/io/files/info/unix/macosx/macosx.factor b/basis/io/files/info/unix/macosx/macosx.factor index 53992bcb95..cfc13ba015 100644 --- a/basis/io/files/info/unix/macosx/macosx.factor +++ b/basis/io/files/info/unix/macosx/macosx.factor @@ -20,10 +20,10 @@ M: macosx file-systems ( -- array ) M: macosx new-file-system-info macosx-file-system-info new ; M: macosx file-system-statfs ( normalized-path -- statfs ) - "statfs64" tuck statfs64 io-error ; + "statfs64" [ statfs64 io-error ] keep ; M: macosx file-system-statvfs ( normalized-path -- statvfs ) - "statvfs" tuck statvfs io-error ; + "statvfs" [ statvfs io-error ] keep ; M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' ) { diff --git a/basis/io/files/info/unix/netbsd/netbsd.factor b/basis/io/files/info/unix/netbsd/netbsd.factor index 6dc0bb3f87..4f284b5f44 100644 --- a/basis/io/files/info/unix/netbsd/netbsd.factor +++ b/basis/io/files/info/unix/netbsd/netbsd.factor @@ -16,7 +16,7 @@ idx mount-from ; M: netbsd new-file-system-info netbsd-file-system-info new ; M: netbsd file-system-statvfs - "statvfs" tuck statvfs io-error ; + "statvfs" [ statvfs io-error ] keep ; M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' ) { diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor index 62783a968b..0fe4c4bec0 100644 --- a/basis/io/files/info/unix/openbsd/openbsd.factor +++ b/basis/io/files/info/unix/openbsd/openbsd.factor @@ -14,7 +14,7 @@ owner ; M: openbsd new-file-system-info freebsd-file-system-info new ; M: openbsd file-system-statfs - "statfs" tuck statfs io-error ; + "statfs" [ statfs io-error ] keep ; M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' ) { @@ -41,7 +41,7 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info } cleave ; M: openbsd file-system-statvfs ( normalized-path -- statvfs ) - "statvfs" tuck statvfs io-error ; + "statvfs" [ statvfs io-error ] keep ; M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' ) { diff --git a/basis/io/files/links/unix/unix-tests.factor b/basis/io/files/links/unix/unix-tests.factor index b1d2c5b8fa..dd5eb5c8d9 100644 --- a/basis/io/files/links/unix/unix-tests.factor +++ b/basis/io/files/links/unix/unix-tests.factor @@ -9,24 +9,30 @@ IN: io.files.links.unix.tests [ t ] [ [ - 5 "lol" make-test-links - "lol1" follow-links - current-directory get "lol5" append-path = - ] with-unique-directory + current-temporary-directory get [ + 5 "lol" make-test-links + "lol1" follow-links + current-temporary-directory get "lol5" append-path = + ] with-directory + ] cleanup-unique-directory ] unit-test [ [ - 100 "laf" make-test-links "laf1" follow-links + current-temporary-directory get [ + 100 "laf" make-test-links "laf1" follow-links + ] with-directory ] with-unique-directory ] [ too-many-symlinks? ] must-fail-with [ t ] [ 110 symlink-depth [ [ - 100 "laf" make-test-links - "laf1" follow-links - current-directory get "laf100" append-path = - ] with-unique-directory + current-temporary-directory get [ + 100 "laf" make-test-links + "laf1" follow-links + current-temporary-directory get "laf100" append-path = + ] with-directory + ] cleanup-unique-directory ] with-variable ] unit-test diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index 08836cf497..b8a4431a73 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -1,8 +1,9 @@ USING: help.markup help.syntax io io.ports kernel math -io.pathnames io.directories math.parser io.files strings ; +io.pathnames io.directories math.parser io.files strings +quotations io.files.unique.private ; IN: io.files.unique -HELP: temporary-path +HELP: default-temporary-directory { $values { "path" "a pathname string" } } @@ -25,42 +26,66 @@ HELP: unique-retries HELP: make-unique-file ( prefix suffix -- path ) { $values { "prefix" "a string" } { "suffix" "a string" } { "path" "a pathname string" } } -{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } +{ $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." } ; -HELP: make-unique-file* -{ $values - { "prefix" string } { "suffix" string } - { "path" "a pathname string" } -} -{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ; +{ unique-file make-unique-file cleanup-unique-file } related-words -{ make-unique-file make-unique-file* with-unique-file } related-words - -HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- ) +HELP: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- ) { $values { "prefix" "a string" } { "suffix" "a string" } { "quot" "a 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." } ; -HELP: make-unique-directory ( -- path ) +HELP: unique-directory ( -- path ) { $values { "path" "a pathname string" } } -{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." } +{ $description "Creates a directory in the value in " { $link current-temporary-directory } " that is guaranteed not to exist in and returns the full pathname." } { $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: with-unique-directory ( quot -- ) +HELP: cleanup-unique-directory ( quot -- ) { $values { "quot" "a quotation" } } -{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-directory } " combinator. The quotation can access the " { $link current-directory } " symbol for the name of the temporary directory." } -{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the 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." } ; -ARTICLE: "io.files.unique" "Temporary files" -"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl -"Creating temporary files:" +HELP: with-unique-directory +{ $values + { "quot" quotation } + { "path" "a pathname string" } +} +{ $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." } ; + +HELP: current-temporary-directory +{ $values + { "value" "a path" } +} +{ $description "The temporary directory used for creating unique files and directories." } ; + +HELP: unique-file +{ $values + { "path" "a pathname string" } + { "path'" "a pathname string" } +} +{ $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ; + +HELP: with-temporary-directory +{ $values + { "path" "a pathname string" } { "quot" quotation } +} +{ $description "Sets " { $link current-temporary-directory } " to " { $snippet "path" } " and calls the quotation, restoring the previous temporary path after execution completes." } ; + +ARTICLE: "io.files.unique" "Unique files" +"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform unique file creation in temporary directories in a high-level and secure way." $nl +"Changing the temporary path:" +{ $subsection current-temporary-directory } +"Creating unique files:" +{ $subsection unique-file } +{ $subsection cleanup-unique-file } { $subsection make-unique-file } -{ $subsection make-unique-file* } -{ $subsection with-unique-file } -"Creating temporary directories:" -{ $subsection make-unique-directory } -{ $subsection with-unique-directory } ; +"Creating unique directories:" +{ $subsection unique-directory } +{ $subsection with-unique-directory } +{ $subsection cleanup-unique-directory } +"Default temporary directory:" +{ $subsection default-temporary-directory } ; ABOUT: "io.files.unique" diff --git a/basis/io/files/unique/unique-tests.factor b/basis/io/files/unique/unique-tests.factor index 8f2e32cea2..fd8cf2c69f 100644 --- a/basis/io/files/unique/unique-tests.factor +++ b/basis/io/files/unique/unique-tests.factor @@ -1,21 +1,41 @@ USING: io.encodings.ascii sequences strings io io.files accessors tools.test kernel io.files.unique namespaces continuations -io.files.info io.pathnames ; +io.files.info io.pathnames io.directories ; IN: io.files.unique.tests [ 123 ] [ "core" ".test" [ [ [ 123 CHAR: a ] dip ascii set-file-contents ] [ file-info size>> ] bi - ] with-unique-file + ] cleanup-unique-file ] unit-test [ t ] [ - [ current-directory get file-info directory? ] with-unique-directory + [ current-directory get file-info directory? ] cleanup-unique-directory ] unit-test [ t ] [ current-directory get - [ [ "FAILDOG" throw ] with-unique-directory ] [ drop ] recover + [ [ "FAILDOG" throw ] cleanup-unique-directory ] [ drop ] recover current-directory get = ] unit-test + +[ t ] [ + [ + "asdf" unique-file drop + "asdf2" unique-file drop + current-temporary-directory get directory-files length 2 = + ] cleanup-unique-directory +] unit-test + +[ t ] [ + [ ] with-unique-directory >boolean +] unit-test + +[ t ] [ + [ + "asdf" unique-file drop + "asdf" unique-file drop + current-temporary-directory get directory-files length 2 = + ] with-unique-directory drop +] unit-test diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 02f4d6080c..7bd96aa63b 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -6,8 +6,13 @@ kernel math math.bitwise math.parser namespaces random sequences system vocabs.loader ; IN: io.files.unique -HOOK: touch-unique-file io-backend ( path -- ) -HOOK: temporary-path io-backend ( -- path ) +HOOK: (touch-unique-file) io-backend ( path -- ) +: touch-unique-file ( path -- ) + normalize-path (touch-unique-file) ; + +HOOK: default-temporary-directory io-backend ( -- path ) + +SYMBOL: current-temporary-directory SYMBOL: unique-length SYMBOL: unique-retries @@ -15,6 +20,9 @@ SYMBOL: unique-retries 10 unique-length set-global 10 unique-retries set-global +: with-temporary-directory ( path quot -- ) + [ current-temporary-directory ] dip with-variable ; inline + +: random-name ( -- string ) + unique-length get [ random-ch ] "" replicate-as ; : (make-unique-file) ( path prefix suffix -- path ) '[ - _ _ _ unique-length get random-name glue append-path + _ _ _ random-name glue append-path dup touch-unique-file ] unique-retries get retry ; +PRIVATE> + : make-unique-file ( prefix suffix -- path ) - [ temporary-path ] 2dip (make-unique-file) ; + [ current-temporary-directory get ] 2dip (make-unique-file) ; -: make-unique-file* ( prefix suffix -- path ) - [ current-directory get ] 2dip (make-unique-file) ; - -: with-unique-file ( prefix suffix quot: ( path -- ) -- ) +: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- ) [ make-unique-file ] dip [ delete-file ] bi ; inline -: make-unique-directory ( -- path ) +: unique-directory ( -- path ) [ - temporary-path unique-length get random-name append-path + current-temporary-directory get + random-name append-path dup make-directory ] unique-retries get retry ; -: with-unique-directory ( quot: ( -- ) -- ) - [ make-unique-directory ] dip - '[ _ with-directory ] [ delete-tree ] bi ; inline +: with-unique-directory ( quot -- path ) + [ unique-directory ] dip + [ with-temporary-directory ] [ drop ] 2bi ; inline + +: cleanup-unique-directory ( quot: ( -- ) -- ) + [ unique-directory ] dip + '[ _ with-temporary-directory ] [ delete-tree ] bi ; inline + +: unique-file ( path -- path' ) + "" make-unique-file ; { { [ os unix? ] [ "io.files.unique.unix" ] } { [ os windows? ] [ "io.files.unique.windows" ] } } cond require + +default-temporary-directory current-temporary-directory set-global diff --git a/basis/io/files/unique/unix/unix.factor b/basis/io/files/unique/unix/unix.factor index ed4e120b79..9f35f440c7 100644 --- a/basis/io/files/unique/unix/unix.factor +++ b/basis/io/files/unique/unix/unix.factor @@ -7,7 +7,7 @@ IN: io.files.unique.unix : open-unique-flags ( -- flags ) { O_RDWR O_CREAT O_EXCL } flags ; -M: unix touch-unique-file ( path -- ) +M: unix (touch-unique-file) ( path -- ) open-unique-flags file-mode open-file close-file ; -M: unix temporary-path ( -- path ) "/tmp" ; +M: unix default-temporary-directory ( -- path ) "/tmp" ; diff --git a/basis/io/files/unique/windows/windows.factor b/basis/io/files/unique/windows/windows.factor index 47f30999c3..2c722426dc 100644 --- a/basis/io/files/unique/windows/windows.factor +++ b/basis/io/files/unique/windows/windows.factor @@ -3,8 +3,8 @@ io.files.windows io.ports windows destructors environment io.files.unique ; IN: io.files.unique.windows -M: windows touch-unique-file ( path -- ) +M: windows (touch-unique-file) ( path -- ) GENERIC_WRITE CREATE_NEW 0 open-file dispose ; -M: windows temporary-path ( -- path ) +M: windows default-temporary-directory ( -- path ) "TEMP" os-env ; diff --git a/basis/io/files/windows/nt/nt-tests.factor b/basis/io/files/windows/nt/nt-tests.factor index e934dc8cd2..b3bfecaafc 100644 --- a/basis/io/files/windows/nt/nt-tests.factor +++ b/basis/io/files/windows/nt/nt-tests.factor @@ -25,8 +25,8 @@ IN: io.files.windows.nt.tests [ t ] [ "\\\\" root-directory? ] unit-test [ t ] [ "/" root-directory? ] unit-test [ t ] [ "//" root-directory? ] unit-test -[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test -[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test +[ t ] [ "c:\\" trim-tail-separators root-directory? ] unit-test +[ t ] [ "Z:\\" trim-tail-separators root-directory? ] unit-test [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor index 3241d19efa..9e449982fb 100755 --- a/basis/io/files/windows/nt/nt.factor +++ b/basis/io/files/windows/nt/nt.factor @@ -22,10 +22,10 @@ M: winnt root-directory? ( path -- ? ) { { [ dup empty? ] [ drop f ] } { [ dup [ path-separator? ] all? ] [ drop t ] } - { [ dup trim-right-separators { [ length 2 = ] + { [ dup trim-tail-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ drop t ] } { [ dup unicode-prefix head? ] - [ trim-right-separators length unicode-prefix length 2 + = ] } + [ trim-tail-separators length unicode-prefix length 2 + = ] } [ drop f ] } cond ; diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor index 4587a75fd9..954d8b43c7 100644 --- a/basis/io/mmap/functor/functor.factor +++ b/basis/io/mmap/functor/functor.factor @@ -20,9 +20,9 @@ with-mapped-A-file DEFINES with-mapped-${T}-file WHERE : ( mapped-file -- direct-array ) - T mapped-file>direct execute ; inline + T mapped-file>direct ; inline : with-mapped-A-file ( path length quot -- ) - '[ execute @ ] with-mapped-file ; inline + '[ @ ] with-mapped-file ; inline ;FUNCTOR diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index bd971656d4..5ef3400a6d 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -19,6 +19,7 @@ HELP: HELP: with-mapped-file { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } { $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $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: close-mapped-file diff --git a/basis/io/monitors/linux/linux-tests.factor b/basis/io/monitors/linux/linux-tests.factor index 67558942f8..2170bd73a4 100644 --- a/basis/io/monitors/linux/linux-tests.factor +++ b/basis/io/monitors/linux/linux-tests.factor @@ -2,7 +2,7 @@ IN: io.monitors.linux.tests USING: io.monitors tools.test io.files io.files.temp io.directories system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint -destructors io.timeouts ; +destructors io.timeouts accessors ; ! On Linux, a notification on the directory itself would report an invalid ! path name @@ -16,7 +16,7 @@ destructors io.timeouts ; [ ] [ "monitor-test-self" temp-file touch-file ] unit-test [ t ] [ - "m" get next-change drop + "m" get next-change path>> [ "" = ] [ "monitor-test-self" temp-file = ] bi or ] unit-test @@ -29,7 +29,7 @@ destructors io.timeouts ; [ ] [ "monitor-test-self" temp-file touch-file ] unit-test [ t ] [ - "m" get next-change drop + "m" get next-change path>> [ "" = ] [ "monitor-test-self" temp-file = ] bi or ] unit-test diff --git a/basis/io/monitors/monitors-docs.factor b/basis/io/monitors/monitors-docs.factor index 3242b276e6..f0278e300e 100644 --- a/basis/io/monitors/monitors-docs.factor +++ b/basis/io/monitors/monitors-docs.factor @@ -17,9 +17,12 @@ HELP: (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." } ; +HELP: file-change +{ $class-description "A change notification output by " { $link next-change } ". The " { $snippet "path" } " slot holds a pathname string. The " { $snippet "changed" } " slots holds a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; + HELP: next-change -{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } } -{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } +{ $values { "monitor" "a monitor" } { "change" file-change } } +{ $contract "Waits for file system changes and outputs a change descriptor for the first changed file." } { $errors "Throws an error if the monitor is closed from another thread." } ; HELP: with-monitor @@ -46,7 +49,9 @@ HELP: +rename-file+ { $description "Indicates that a file has been renamed." } ; ARTICLE: "io.monitors.descriptors" "File system change descriptors" -"Change descriptors output by " { $link next-change } ":" +"The " { $link next-change } " word outputs instances of a class:" +{ $subsection file-change } +"The " { $slot "changed" } " slot holds a sequence which may contain any of the following symbols:" { $subsection +add-file+ } { $subsection +remove-file+ } { $subsection +modify-file+ } @@ -55,7 +60,7 @@ ARTICLE: "io.monitors.descriptors" "File system change descriptors" { $subsection +rename-file+ } ; ARTICLE: "io.monitors.platforms" "Monitors on different platforms" -"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link } " is unspecified, and may even vary on the same platform. User code should not assume either case." +"Whether the " { $slot "path" } " slot of a " { $link file-change } " contains an absolute path or a path relative to the path given to " { $link } " is unspecified, and may even vary on the same platform. User code should not assume either case." $nl "If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below." { $heading "Mac OS X" } @@ -63,7 +68,7 @@ $nl $nl { $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link } " has no effect." $nl -"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available." +"The " { $snippet "changed" } " slot of the " { $link file-change } " word tuple always contains " { $link +modify-file+ } " and the " { $snippet "path" } " slot is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available." $nl "Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported." { $heading "Windows" } @@ -107,7 +112,7 @@ $nl { $code "USE: io.monitors" ": watch-loop ( monitor -- )" - " dup next-change . . nl nl flush watch-loop ;" + " dup next-change . nl nl flush watch-loop ;" "" ": watch-directory ( path -- )" " [ t [ watch-loop ] with-monitor ] with-monitors" diff --git a/basis/io/monitors/monitors-tests.factor b/basis/io/monitors/monitors-tests.factor index 9efa785061..8252b6ef72 100644 --- a/basis/io/monitors/monitors-tests.factor +++ b/basis/io/monitors/monitors-tests.factor @@ -3,7 +3,7 @@ USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint destructors io.timeouts io.files.temp io.directories io.directories.hierarchy -io.pathnames ; +io.pathnames accessors ; os { winnt linux macosx } member? [ [ @@ -53,19 +53,19 @@ os { winnt linux macosx } member? [ "b" get count-down [ - "m" get next-change drop + "m" get next-change path>> dup print flush dup parent-directory - [ trim-right-separators "xyz" tail? ] either? not + [ trim-tail-separators "xyz" tail? ] either? not ] loop "c1" get count-down [ - "m" get next-change drop + "m" get next-change path>> dup print flush dup parent-directory - [ trim-right-separators "yxy" tail? ] either? not + [ trim-tail-separators "yxy" tail? ] either? not ] loop "c2" get count-down @@ -101,13 +101,13 @@ os { winnt linux macosx } member? [ ! Non-recursive [ ] [ "monitor-timeout-test" temp-file f "m" set ] unit-test [ ] [ 3 seconds "m" get set-timeout ] unit-test - [ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail + [ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail [ ] [ "m" get dispose ] unit-test ! Recursive [ ] [ "monitor-timeout-test" temp-file t "m" set ] unit-test [ ] [ 3 seconds "m" get set-timeout ] unit-test - [ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail + [ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail [ ] [ "m" get dispose ] unit-test ] with-monitors ] when diff --git a/basis/io/monitors/monitors.factor b/basis/io/monitors/monitors.factor index e225e45430..7d40a1563a 100644 --- a/basis/io/monitors/monitors.factor +++ b/basis/io/monitors/monitors.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations destructors namespaces sequences assocs hashtables sorting arrays threads boxes -io.timeouts accessors concurrency.mailboxes +io.timeouts accessors concurrency.mailboxes fry system vocabs.loader combinators ; IN: io.monitors @@ -33,17 +33,19 @@ M: monitor set-timeout (>>timeout) ; swap >>queue swap >>path ; inline +TUPLE: file-change path changed monitor ; + : queue-change ( path changes monitor -- ) 3dup and and - [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; + [ [ file-change boa ] keep queue>> mailbox-put ] [ 3drop ] if ; HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor ) : ( path recursive? -- monitor ) (monitor) ; -: next-change ( monitor -- path changed ) - [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ; +: next-change ( monitor -- change ) + [ queue>> ] [ timeout ] bi mailbox-get-timeout ; SYMBOL: +add-file+ SYMBOL: +remove-file+ @@ -55,9 +57,15 @@ SYMBOL: +rename-file+ : with-monitor ( path recursive? quot -- ) [ ] dip with-disposal ; inline +: run-monitor ( path recursive? quot -- ) + '[ [ @ t ] loop ] with-monitor ; inline + +: spawn-monitor ( path recursive? quot -- ) + [ '[ _ _ _ run-monitor ] ] [ 2drop "Monitoring " prepend ] 3bi + spawn drop ; { { [ os macosx? ] [ "io.monitors.macosx" require ] } { [ os linux? ] [ "io.monitors.linux" require ] } { [ os winnt? ] [ "io.monitors.windows.nt" require ] } - [ ] + { [ os bsd? ] [ ] } } cond diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index 18fa62f6d6..943345bf18 100644 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors sequences assocs arrays continuations destructors combinators kernel threads concurrency.messaging @@ -45,12 +45,11 @@ M: recursive-monitor dispose* bi ; : stop-pump ( -- ) - monitor tget children>> [ nip dispose ] assoc-each ; + monitor tget children>> values dispose-each ; : pump-step ( msg -- ) - first3 path>> swap [ prepend-path ] dip monitor tget 3array - monitor tget queue>> - mailbox-put ; + [ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi + monitor tget queue-change ; : child-added ( path monitor -- ) path>> prepend-path add-child-monitor ; @@ -59,7 +58,7 @@ M: recursive-monitor dispose* path>> prepend-path remove-child-monitor ; : update-hierarchy ( msg -- ) - first3 swap [ + [ path>> ] [ monitor>> ] [ changed>> ] tri [ { { +add-file+ [ child-added ] } { +remove-file+ [ child-removed ] } diff --git a/basis/io/pipes/pipes-docs.factor b/basis/io/pipes/pipes-docs.factor index 221cce1dbe..1ba3c05a6a 100644 --- a/basis/io/pipes/pipes-docs.factor +++ b/basis/io/pipes/pipes-docs.factor @@ -29,7 +29,7 @@ HELP: run-pipeline } } { $examples - "Print the lines of a log file which contain the string ``error'', sort them and filter out duplicates, using Unix shell commands only:" + "Print the lines of a log file which contain the string “errorâ€, sort them and filter out duplicates, using Unix shell commands only:" { $code "{ \"cat log.txt\" \"grep error\" \"sort\" \"uniq\" } run-pipeline" } } ; diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 6eb61a24a7..1fe717d5ee 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -99,7 +99,7 @@ TUPLE: output-port < buffered-port ; output-port ; : wait-to-write ( len port -- ) - tuck buffer>> buffer-capacity <= + [ nip ] [ buffer>> buffer-capacity <= ] 2bi [ drop ] [ stream-flush ] if ; inline M: output-port stream-write1 diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor index f6a1bcfcb0..49a1b2ae63 100644 --- a/basis/io/sockets/windows/nt/nt.factor +++ b/basis/io/sockets/windows/nt/nt.factor @@ -6,7 +6,7 @@ libc math sequences threads system combinators accessors ; IN: io.sockets.windows.nt : malloc-int ( object -- object ) - "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline + "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline M: winnt WSASocket-flags ( -- DWORD ) WSA_FLAG_OVERLAPPED ; diff --git a/basis/io/streams/limited/limited-docs.factor b/basis/io/streams/limited/limited-docs.factor index 90f7860672..fac1232cc0 100755 --- a/basis/io/streams/limited/limited-docs.factor +++ b/basis/io/streams/limited/limited-docs.factor @@ -81,7 +81,7 @@ ARTICLE: "io.streams.limited" "Limited input streams" "Unlimits a limited stream:" { $subsection unlimit } "Unlimits the current " { $link input-stream } ":" -{ $subsection limit-input } +{ $subsection unlimit-input } "Make a limited stream throw an exception on exhaustion:" { $subsection stream-throws } "Make a limited stream return " { $link f } " on exhaustion:" diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index c88d52be81..feddc130e9 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -1,6 +1,7 @@ USING: io io.streams.limited io.encodings io.encodings.string io.encodings.ascii io.encodings.binary io.streams.byte-array -namespaces tools.test strings kernel io.streams.string accessors ; +namespaces tools.test strings kernel io.streams.string accessors +io.encodings.utf8 io.files destructors ; IN: io.streams.limited.tests [ ] [ @@ -59,3 +60,19 @@ IN: io.streams.limited.tests "abc" 3 stream-eofs limit unlimit "abc" = ] unit-test + +[ t ] +[ + "abc" 3 stream-eofs limit unlimit + "abc" = +] unit-test + +[ t ] +[ + [ + "resource:license.txt" utf8 &dispose + 3 stream-eofs limit unlimit + "resource:license.txt" utf8 &dispose + [ decoder? ] both? + ] with-destructors +] unit-test diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index 71c6eb67d4..1237b3aba2 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -5,7 +5,7 @@ USING: kernel math io io.encodings destructors accessors sequences namespaces byte-vectors fry combinators ; IN: io.streams.limited -TUPLE: limited-stream stream count limit mode ; +TUPLE: limited-stream stream count limit mode stack ; SINGLETONS: stream-throws stream-eofs ; @@ -24,13 +24,24 @@ M: decoder limit ( stream limit mode -- stream' ) M: object limit ( stream limit mode -- stream' ) ; -: unlimit ( stream -- stream' ) +GENERIC: unlimit ( stream -- stream' ) + +M: decoder unlimit ( stream -- stream' ) [ stream>> ] change-stream ; +M: object unlimit ( stream -- stream' ) + stream>> stream>> ; + : limit-input ( limit mode -- ) input-stream [ -rot limit ] change ; : unlimit-input ( -- ) input-stream [ unlimit ] change ; +: with-unlimited-stream ( stream quot -- ) + [ clone unlimit ] dip call ; inline + +: with-limited-stream ( stream limit mode quot -- ) + [ limit ] dip call ; inline + ERROR: limit-exceeded ; ERROR: bad-stream-mode mode ; diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index 0e07c8bda9..64a28aabee 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -118,7 +118,7 @@ M: plain-writer make-block-stream : format-column ( seq ? -- seq ) [ [ 0 [ length max ] reduce ] keep - swap [ CHAR: \s pad-right ] curry map + swap [ CHAR: \s pad-tail ] curry map ] unless ; : map-last ( seq quot -- seq ) diff --git a/basis/io/timeouts/timeouts.factor b/basis/io/timeouts/timeouts.factor old mode 100644 new mode 100755 index fd1b14de19..8e69983e9c --- a/basis/io/timeouts/timeouts.factor +++ b/basis/io/timeouts/timeouts.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: kernel calendar alarms io io.encodings accessors -namespaces fry ; +namespaces fry io.streams.null ; IN: io.timeouts GENERIC: timeout ( obj -- dt/f ) @@ -27,3 +27,5 @@ GENERIC: cancel-operation ( obj -- ) : timeouts ( dt -- ) [ input-stream get set-timeout ] [ output-stream get set-timeout ] bi ; + +M: null-stream set-timeout 2drop ; diff --git a/basis/lcs/diff2html/diff2html-tests.factor b/basis/lcs/diff2html/diff2html-tests.factor new file mode 100644 index 0000000000..0c2ed34f45 --- /dev/null +++ b/basis/lcs/diff2html/diff2html-tests.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ; +IN: lcs.diff2html.tests + +[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml>string drop ] unit-test diff --git a/basis/lcs/diff2html/diff2html.factor b/basis/lcs/diff2html/diff2html.factor index ebbb0f3786..16e6cc8d97 100644 --- a/basis/lcs/diff2html/diff2html.factor +++ b/basis/lcs/diff2html/diff2html.factor @@ -1,44 +1,42 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: lcs html.elements kernel ; +USING: lcs xml.literals xml.writer kernel strings ; FROM: accessors => item>> ; FROM: io => write ; -FROM: sequences => each if-empty ; -FROM: xml.entities => escape-string ; +FROM: sequences => each if-empty when-empty map ; IN: lcs.diff2html -GENERIC: diff-line ( obj -- ) +GENERIC: diff-line ( obj -- xml ) -: write-item ( item -- ) - item>> [ " " ] [ escape-string ] if-empty write ; +: item-string ( item -- string ) + item>> [ CHAR: no-break-space 1string ] when-empty ; M: retain diff-line - - dup [ - - write-item - - ] bi@ - ; + item-string + [XML <-> XML] + dup [XML <-><-> XML] ; M: insert diff-line - - - - write-item - - ; + item-string [XML + + + <-> + + XML] ; M: delete diff-line - - - write-item - - - ; + item-string [XML + + <-> + + + XML] ; -: htmlize-diff ( diff -- ) - - - [ diff-line ] each -
    "Old" write "New" write
    ; +: htmlize-diff ( diff -- xml ) + [ diff-line ] map + [XML + + + <-> +
    OldNew
    + XML] ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 77b87d1b49..a4a9ca448b 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -113,7 +113,7 @@ HELP: MEMO:: { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words -ARTICLE: "locals-literals" "Locals in array and hashtable literals" +ARTICLE: "locals-literals" "Locals in literals" "Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables." $nl "The data types which receive this special handling are the following:" @@ -122,7 +122,9 @@ $nl { $link "hashtables" } { $link "vectors" } { $link "tuples" } + { $link "wrappers" } } +{ $heading "Object identity" } "This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:" { $example "IN: scratchpad" @@ -134,6 +136,7 @@ $nl } "In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:" { $example + "USE: locals" "IN: scratchpad" "TUPLE: person first-name last-name ;" ":: ordinary-word-test ( -- tuple )" @@ -142,7 +145,7 @@ $nl "f" } "One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time." -$nl +{ $heading "Example" } "For example, here is an implementation of the " { $link 3array } " word which uses this feature:" { $code ":: 3array ( x y z -- array ) { x y z } ;" } ; @@ -166,7 +169,7 @@ $nl "Recall that the following two code snippets are equivalent:" { $code "'[ sq _ + ]" } { $code "[ [ sq ] dip + ] curry" } -"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as ``inserted'' in the ``hole'' in the quotation's second element." +"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as “inserted†in the “hole†in the quotation's second element." $nl "Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:" { $code "3 [ - ] curry" } @@ -179,7 +182,7 @@ $nl { $code "'[ [| a | a - ] curry ] call" } "Instead, the first line above expands into something like the following:" { $code "[ [ swap [| a | a - ] ] curry call ]" } -"This ensures that the fried value appears ``underneath'' the local variable " { $snippet "a" } " when the quotation calls." +"This ensures that the fried value appears “underneath†the local variable " { $snippet "a" } " when the quotation calls." $nl "The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ; diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index e7f0b74194..bd9e7cf103 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -490,4 +490,14 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ 10 ] [ [| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call -] unit-test \ No newline at end of file +] unit-test + +! Discovered by littledan +[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test +[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test + +[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test + +[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test + +[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test \ No newline at end of file diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index c5b34556bc..f6baaf9ba7 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators effects.parser -generic.parser kernel lexer locals.errors +generic.parser kernel lexer locals.errors fry locals.rewrite.closures locals.types make namespaces parser quotations sequences splitting words vocabs.parser ; IN: locals.parser @@ -56,19 +56,21 @@ SYMBOL: in-lambda? (parse-bindings) ] [ 2drop ] if ; +: with-bindings ( quot -- words assoc ) + '[ + in-lambda? on + _ H{ } make-assoc + ] { } make swap ; inline + : parse-bindings ( end -- bindings vars ) - [ - [ (parse-bindings) ] H{ } make-assoc - ] { } make swap ; + [ (parse-bindings) ] with-bindings ; : parse-bindings* ( end -- words assoc ) [ - [ - namespace push-locals - (parse-bindings) - namespace pop-locals - ] { } make-assoc - ] { } make swap ; + namespace push-locals + (parse-bindings) + namespace pop-locals + ] with-bindings ; : (parse-wbindings) ( end -- ) dup parse-binding dup [ @@ -77,9 +79,7 @@ SYMBOL: in-lambda? ] [ 2drop ] if ; : parse-wbindings ( end -- bindings vars ) - [ - [ (parse-wbindings) ] H{ } make-assoc - ] { } make swap ; + [ (parse-wbindings) ] with-bindings ; : parse-locals ( -- vars assoc ) "(" expect ")" parse-effect @@ -88,8 +88,8 @@ SYMBOL: in-lambda? : parse-locals-definition ( word -- word quot ) parse-locals \ ; (parse-lambda) - 2dup "lambda" set-word-prop - rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ; + [ "lambda" set-word-prop ] + [ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ] 2bi ; : (::) ( -- word def ) CREATE-WORD parse-locals-definition ; diff --git a/basis/locals/rewrite/point-free/point-free.factor b/basis/locals/rewrite/point-free/point-free.factor old mode 100644 new mode 100755 index 33e0f4d3b3..4e91e3d87b --- a/basis/locals/rewrite/point-free/point-free.factor +++ b/basis/locals/rewrite/point-free/point-free.factor @@ -40,7 +40,7 @@ M: object localize 1quotation ; ! We special-case all the :> at the start of a quotation : load-locals-quot ( args -- quot ) [ [ ] ] [ - dup [ local-reader? ] contains? [ + dup [ local-reader? ] any? [ dup [ local-reader? [ 1array ] [ ] ? ] map spread>quot ] [ [ ] ] if swap length [ load-locals ] curry append diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor old mode 100644 new mode 100755 index 835fa6e421..f0b8ac7240 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -33,11 +33,11 @@ GENERIC: rewrite-literal? ( obj -- ? ) M: special rewrite-literal? drop t ; -M: array rewrite-literal? [ rewrite-literal? ] contains? ; +M: array rewrite-literal? [ rewrite-literal? ] any? ; -M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; +M: quotation rewrite-literal? [ rewrite-literal? ] any? ; -M: wrapper rewrite-literal? drop t ; +M: wrapper rewrite-literal? wrapped>> rewrite-literal? ; M: hashtable rewrite-literal? drop t ; @@ -53,7 +53,7 @@ GENERIC: rewrite-element ( obj -- ) [ rewrite-element ] each ; : rewrite-sequence ( seq -- ) - [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ; + [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ; M: array rewrite-element dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; @@ -63,7 +63,7 @@ M: vector rewrite-element rewrite-sequence ; M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; M: tuple rewrite-element - [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ; + [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ; M: quotation rewrite-element rewrite-sugar* ; @@ -81,10 +81,14 @@ M: local-writer rewrite-element M: local-word rewrite-element local-word-in-literal-error ; -M: word rewrite-element literalize , ; +M: word rewrite-element , ; + +: rewrite-wrapper ( wrapper -- ) + dup rewrite-literal? + [ wrapped>> rewrite-element ] [ , ] if ; M: wrapper rewrite-element - dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; + rewrite-wrapper \ , ; M: object rewrite-element , ; @@ -98,7 +102,8 @@ M: def rewrite-sugar* , ; M: hashtable rewrite-sugar* rewrite-element ; -M: wrapper rewrite-sugar* rewrite-element ; +M: wrapper rewrite-sugar* + rewrite-wrapper ; M: word rewrite-sugar* dup { load-locals get-local drop-locals } memq? diff --git a/basis/locals/types/types.factor b/basis/locals/types/types.factor index 7a8dac1947..3ed753e094 100644 --- a/basis/locals/types/types.factor +++ b/basis/locals/types/types.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators kernel sequences words ; +USING: accessors combinators kernel sequences words +quotations ; IN: locals.types TUPLE: lambda vars body ; @@ -38,6 +39,8 @@ PREDICATE: local < word "local?" word-prop ; f dup t "local?" set-word-prop ; +M: local literalize ; + PREDICATE: local-word < word "local-word?" word-prop ; : ( name -- word ) @@ -49,6 +52,8 @@ PREDICATE: local-reader < word "local-reader?" word-prop ; f dup t "local-reader?" set-word-prop ; +M: local-reader literalize ; + PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) diff --git a/basis/match/match.factor b/basis/match/match.factor index fee06686b8..3846dea3be 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -80,7 +80,7 @@ MACRO: match-cond ( assoc -- ) (match-first) drop ; : (match-all) ( seq pattern-seq -- ) - tuck (match-first) swap + [ nip ] [ (match-first) swap ] 2bi [ , [ swap (match-all) ] [ drop ] if* ] [ 2drop ] if* ; diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index 18ae8e1497..358c984276 100644 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -242,7 +242,7 @@ HELP: shift-mod { "n" integer } { "s" integer } { "w" integer } { "n" integer } } -{ $description "" } ; +{ $description "Calls " { $link shift } " on " { $snippet "n" } " and " { $snippet "s" } ", wrapping the result to " { $snippet "w" } " bits." } ; HELP: unmask { $values diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor index 4c0a88f929..2a2e9e3a72 100644 --- a/basis/math/blas/cblas/cblas.factor +++ b/basis/math/blas/cblas/cblas.factor @@ -1,36 +1,51 @@ -USING: alien alien.c-types alien.syntax kernel system combinators ; +USING: alien alien.c-types alien.syntax kernel system +combinators ; IN: math.blas.cblas -<< "cblas" { +<< +: load-atlas ( -- ) + "atlas" "libatlas.so" "cdecl" add-library ; +: load-fortran ( -- ) + "I77" "libI77.so" "cdecl" add-library + "F77" "libF77.so" "cdecl" add-library ; +: load-blas ( -- ) + "blas" "libblas.so" "cdecl" add-library ; + +"cblas" { { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } - { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] } - { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library ] } + { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] } + { [ os netbsd? ] [ + load-fortran load-blas + "/usr/local/lib/libcblas.so" "cdecl" add-library + ] } + { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] } [ "libblas.so" "cdecl" add-library ] -} cond >> +} cond +>> LIBRARY: cblas TYPEDEF: int CBLAS_ORDER -: CblasRowMajor 101 ; inline -: CblasColMajor 102 ; inline +CONSTANT: CblasRowMajor 101 +CONSTANT: CblasColMajor 102 TYPEDEF: int CBLAS_TRANSPOSE -: CblasNoTrans 111 ; inline -: CblasTrans 112 ; inline -: CblasConjTrans 113 ; inline +CONSTANT: CblasNoTrans 111 +CONSTANT: CblasTrans 112 +CONSTANT: CblasConjTrans 113 TYPEDEF: int CBLAS_UPLO -: CblasUpper 121 ; inline -: CblasLower 122 ; inline +CONSTANT: CblasUpper 121 +CONSTANT: CblasLower 122 TYPEDEF: int CBLAS_DIAG -: CblasNonUnit 131 ; inline -: CblasUnit 132 ; inline +CONSTANT: CblasNonUnit 131 +CONSTANT: CblasUnit 132 TYPEDEF: int CBLAS_SIDE -: CblasLeft 141 ; inline -: CblasRight 142 ; inline +CONSTANT: CblasLeft 141 +CONSTANT: CblasRight 142 TYPEDEF: int CBLAS_INDEX diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/cblas/tags.txt +++ b/basis/math/blas/cblas/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index 01e0997405..f20a565e1f 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -1,4 +1,4 @@ -USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ; +USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings multiline ; IN: math.blas.matrices ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" @@ -21,8 +21,6 @@ ARTICLE: "math.blas-types" "BLAS interface types" { $subsection double-blas-matrix } { $subsection float-complex-blas-matrix } { $subsection double-complex-blas-matrix } -"Syntax words are provided for constructing literal vectors and matrices in the " { $vocab-link "math.blas.syntax" } " vocabulary:" -{ $subsection "math.blas.syntax" } "There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:" { $subsection } { $subsection } @@ -74,7 +72,13 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" { $subsection n*M! } { $subsection n*M } { $subsection M*n } -{ $subsection M/n } ; +{ $subsection M/n } +"Literal syntax:" +{ $subsection POSTPONE: smatrix{ } +{ $subsection POSTPONE: dmatrix{ } +{ $subsection POSTPONE: cmatrix{ } +{ $subsection POSTPONE: zmatrix{ } ; + ABOUT: "math.blas.matrices" @@ -243,3 +247,43 @@ HELP: { $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } } { $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ; +HELP: smatrix{ +{ $syntax <" smatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 1.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + { 0.0 0.0 0.0 1.0 } +} "> } +{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +HELP: dmatrix{ +{ $syntax <" dmatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 1.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + { 0.0 0.0 0.0 1.0 } +} "> } +{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +HELP: cmatrix{ +{ $syntax <" cmatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 C{ 0.0 1.0 } 0.0 2.0 } + { 0.0 0.0 -1.0 3.0 } + { 0.0 0.0 0.0 C{ 0.0 -1.0 } } +} "> } +{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +HELP: zmatrix{ +{ $syntax <" zmatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 C{ 0.0 1.0 } 0.0 2.0 } + { 0.0 0.0 -1.0 3.0 } + { 0.0 0.0 0.0 C{ 0.0 -1.0 } } +} "> } +{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +{ + POSTPONE: smatrix{ POSTPONE: dmatrix{ + POSTPONE: cmatrix{ POSTPONE: zmatrix{ +} related-words diff --git a/basis/math/blas/matrices/matrices-tests.factor b/basis/math/blas/matrices/matrices-tests.factor index dabf3c3ee9..cf0c25745e 100644 --- a/basis/math/blas/matrices/matrices-tests.factor +++ b/basis/math/blas/matrices/matrices-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math.blas.matrices math.blas.vectors math.blas.syntax +USING: kernel math.blas.matrices math.blas.vectors sequences tools.test ; IN: math.blas.matrices.tests diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 75ab07709a..7b03ddf42a 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -4,7 +4,8 @@ math math.blas.cblas math.blas.vectors math.blas.vectors.private math.complex math.functions math.order functors words sequences sequences.merged sequences.private shuffle specialized-arrays.direct.float specialized-arrays.direct.double -specialized-arrays.float specialized-arrays.double ; +specialized-arrays.float specialized-arrays.double +parser prettyprint.backend prettyprint.custom ; IN: math.blas.matrices TUPLE: blas-matrix-base underlying ld rows cols transpose ; @@ -258,6 +259,7 @@ XGERC IS cblas_${T}ger${C} MATRIX DEFINES ${TYPE}-blas-matrix DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix +XMATRIX{ DEFINES ${T}matrix{ WHERE @@ -268,28 +270,33 @@ TUPLE: MATRIX < blas-matrix-base ; M: MATRIX element-type drop TYPE ; M: MATRIX (blas-matrix-like) - drop execute ; + drop ; M: VECTOR (blas-matrix-like) - drop execute ; + drop ; M: MATRIX (blas-vector-like) - drop execute ; + drop ; : >MATRIX ( arrays -- matrix ) - [ >ARRAY execute underlying>> ] (>matrix) - execute ; + [ >ARRAY underlying>> ] (>matrix) + ; M: VECTOR n*M.V+n*V! - [ TYPE>ARG execute ] (prepare-gemv) - [ XGEMV execute ] dip ; + [ TYPE>ARG ] (prepare-gemv) + [ XGEMV ] dip ; M: MATRIX n*M.M+n*M! - [ TYPE>ARG execute ] (prepare-gemm) - [ XGEMM execute ] dip ; + [ TYPE>ARG ] (prepare-gemm) + [ XGEMM ] dip ; M: MATRIX n*V(*)V+M! - [ TYPE>ARG execute ] (prepare-ger) - [ XGERU execute ] dip ; + [ TYPE>ARG ] (prepare-ger) + [ XGERU ] dip ; M: MATRIX n*V(*)Vconj+M! - [ TYPE>ARG execute ] (prepare-ger) - [ XGERC execute ] dip ; + [ TYPE>ARG ] (prepare-ger) + [ XGERC ] dip ; + +: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing + +M: MATRIX pprint-delims + drop \ XMATRIX{ \ } ; ;FUNCTOR @@ -305,3 +312,6 @@ M: MATRIX n*V(*)Vconj+M! "double-complex" "z" define-complex-blas-matrix >> + +M: blas-matrix-base >pprint-sequence Mrows ; +M: blas-matrix-base pprint* pprint-object ; diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/syntax/summary.txt b/basis/math/blas/syntax/summary.txt deleted file mode 100644 index a71bebb50f..0000000000 --- a/basis/math/blas/syntax/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Literal syntax for BLAS vectors and matrices diff --git a/basis/math/blas/syntax/syntax-docs.factor b/basis/math/blas/syntax/syntax-docs.factor deleted file mode 100644 index 6b58df738a..0000000000 --- a/basis/math/blas/syntax/syntax-docs.factor +++ /dev/null @@ -1,78 +0,0 @@ -USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ; -IN: math.blas.syntax - -ARTICLE: "math.blas.syntax" "BLAS interface literal syntax" -"Vectors:" -{ $subsection POSTPONE: svector{ } -{ $subsection POSTPONE: dvector{ } -{ $subsection POSTPONE: cvector{ } -{ $subsection POSTPONE: zvector{ } -"Matrices:" -{ $subsection POSTPONE: smatrix{ } -{ $subsection POSTPONE: dmatrix{ } -{ $subsection POSTPONE: cmatrix{ } -{ $subsection POSTPONE: zmatrix{ } ; - -ABOUT: "math.blas.syntax" - -HELP: svector{ -{ $syntax "svector{ 1.0 -2.0 3.0 }" } -{ $description "Construct a literal " { $link float-blas-vector } "." } ; - -HELP: dvector{ -{ $syntax "dvector{ 1.0 -2.0 3.0 }" } -{ $description "Construct a literal " { $link double-blas-vector } "." } ; - -HELP: cvector{ -{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ; - -HELP: zvector{ -{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } -{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ; - -{ - POSTPONE: svector{ POSTPONE: dvector{ - POSTPONE: cvector{ POSTPONE: zvector{ -} related-words - -HELP: smatrix{ -{ $syntax <" smatrix{ - { 1.0 0.0 0.0 1.0 } - { 0.0 1.0 0.0 2.0 } - { 0.0 0.0 1.0 3.0 } - { 0.0 0.0 0.0 1.0 } -} "> } -{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; - -HELP: dmatrix{ -{ $syntax <" dmatrix{ - { 1.0 0.0 0.0 1.0 } - { 0.0 1.0 0.0 2.0 } - { 0.0 0.0 1.0 3.0 } - { 0.0 0.0 0.0 1.0 } -} "> } -{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; - -HELP: cmatrix{ -{ $syntax <" cmatrix{ - { 1.0 0.0 0.0 1.0 } - { 0.0 C{ 0.0 1.0 } 0.0 2.0 } - { 0.0 0.0 -1.0 3.0 } - { 0.0 0.0 0.0 C{ 0.0 -1.0 } } -} "> } -{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; - -HELP: zmatrix{ -{ $syntax <" zmatrix{ - { 1.0 0.0 0.0 1.0 } - { 0.0 C{ 0.0 1.0 } 0.0 2.0 } - { 0.0 0.0 -1.0 3.0 } - { 0.0 0.0 0.0 C{ 0.0 -1.0 } } -} "> } -{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; - -{ - POSTPONE: smatrix{ POSTPONE: dmatrix{ - POSTPONE: cmatrix{ POSTPONE: zmatrix{ -} related-words diff --git a/basis/math/blas/syntax/syntax.factor b/basis/math/blas/syntax/syntax.factor deleted file mode 100644 index 95f9f7bd08..0000000000 --- a/basis/math/blas/syntax/syntax.factor +++ /dev/null @@ -1,44 +0,0 @@ -USING: kernel math.blas.vectors math.blas.matrices parser -arrays prettyprint.backend sequences ; -IN: math.blas.syntax - -: svector{ - \ } [ >float-blas-vector ] parse-literal ; parsing -: dvector{ - \ } [ >double-blas-vector ] parse-literal ; parsing -: cvector{ - \ } [ >float-complex-blas-vector ] parse-literal ; parsing -: zvector{ - \ } [ >double-complex-blas-vector ] parse-literal ; parsing - -: smatrix{ - \ } [ >float-blas-matrix ] parse-literal ; parsing -: dmatrix{ - \ } [ >double-blas-matrix ] parse-literal ; parsing -: cmatrix{ - \ } [ >float-complex-blas-matrix ] parse-literal ; parsing -: zmatrix{ - \ } [ >double-complex-blas-matrix ] parse-literal ; parsing - -M: float-blas-vector pprint-delims - drop \ svector{ \ } ; -M: double-blas-vector pprint-delims - drop \ dvector{ \ } ; -M: float-complex-blas-vector pprint-delims - drop \ cvector{ \ } ; -M: double-complex-blas-vector pprint-delims - drop \ zvector{ \ } ; - -M: float-blas-matrix pprint-delims - drop \ smatrix{ \ } ; -M: double-blas-matrix pprint-delims - drop \ dmatrix{ \ } ; -M: float-complex-blas-matrix pprint-delims - drop \ cmatrix{ \ } ; -M: double-complex-blas-matrix pprint-delims - drop \ zmatrix{ \ } ; - -M: blas-vector-base >pprint-sequence ; -M: blas-vector-base pprint* pprint-object ; -M: blas-matrix-base >pprint-sequence Mrows ; -M: blas-matrix-base pprint* pprint-object ; diff --git a/basis/math/blas/syntax/tags.txt b/basis/math/blas/syntax/tags.txt deleted file mode 100644 index 6a932d96d2..0000000000 --- a/basis/math/blas/syntax/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -math -unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index 6a932d96d2..ede10ab61b 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1,2 +1 @@ math -unportable diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor index cb26d67334..b37a4b966e 100644 --- a/basis/math/blas/vectors/vectors-docs.factor +++ b/basis/math/blas/vectors/vectors-docs.factor @@ -23,7 +23,12 @@ ARTICLE: "math.blas.vectors" "BLAS interface vector operations" { $subsection V- } "Vector inner products:" { $subsection V. } -{ $subsection V.conj } ; +{ $subsection V.conj } +"Literal syntax:" +{ $subsection POSTPONE: svector{ } +{ $subsection POSTPONE: dvector{ } +{ $subsection POSTPONE: cvector{ } +{ $subsection POSTPONE: zvector{ } ; ABOUT: "math.blas.vectors" @@ -129,3 +134,25 @@ HELP: V/n HELP: Vsub { $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } } { $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ; + +HELP: svector{ +{ $syntax "svector{ 1.0 -2.0 3.0 }" } +{ $description "Construct a literal " { $link float-blas-vector } "." } ; + +HELP: dvector{ +{ $syntax "dvector{ 1.0 -2.0 3.0 }" } +{ $description "Construct a literal " { $link double-blas-vector } "." } ; + +HELP: cvector{ +{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } +{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ; + +HELP: zvector{ +{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } +{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ; + +{ + POSTPONE: svector{ POSTPONE: dvector{ + POSTPONE: cvector{ POSTPONE: zvector{ +} related-words + diff --git a/basis/math/blas/vectors/vectors-tests.factor b/basis/math/blas/vectors/vectors-tests.factor index 5f9e8fdc42..da271a4fc7 100644 --- a/basis/math/blas/vectors/vectors-tests.factor +++ b/basis/math/blas/vectors/vectors-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math.blas.vectors math.blas.syntax sequences tools.test ; +USING: kernel math.blas.vectors sequences tools.test ; IN: math.blas.vectors.tests ! clone diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index db027b0ffd..3b7f89f730 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -2,7 +2,7 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.short-circuit fry kernel math math.blas.cblas math.complex math.functions math.order sequences.complex sequences.complex-components sequences sequences.private -functors words locals +functors words locals parser prettyprint.backend prettyprint.custom specialized-arrays.float specialized-arrays.double specialized-arrays.direct.float specialized-arrays.direct.double ; IN: math.blas.vectors @@ -138,32 +138,39 @@ VECTOR DEFINES ${TYPE}-blas-vector DEFINES <${TYPE}-blas-vector> >VECTOR DEFINES >${TYPE}-blas-vector +XVECTOR{ DEFINES ${T}vector{ + WHERE TUPLE: VECTOR < blas-vector-base ; : ( underlying length inc -- vector ) VECTOR boa ; inline : >VECTOR ( seq -- v ) - [ >ARRAY execute underlying>> ] [ length ] bi 1 execute ; + [ >ARRAY underlying>> ] [ length ] bi 1 ; M: VECTOR clone TYPE heap-size (prepare-copy) - [ XCOPY execute ] 3dip execute ; + [ XCOPY ] 3dip ; M: VECTOR element-type drop TYPE ; M: VECTOR Vswap - (prepare-swap) [ XSWAP execute ] 2dip ; + (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX execute ; + (prepare-nrm2) IXAMAX ; M: VECTOR (blas-vector-like) - drop execute ; + drop ; M: VECTOR (blas-direct-array) [ underlying>> ] [ [ length>> ] [ inc>> ] bi * ] bi - execute ; + ; + +: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing + +M: VECTOR pprint-delims + drop \ XVECTOR{ \ } ; ;FUNCTOR @@ -180,17 +187,17 @@ XSCAL IS cblas_${T}scal WHERE M: VECTOR V. - (prepare-dot) XDOT execute ; + (prepare-dot) XDOT ; M: VECTOR V.conj - (prepare-dot) XDOT execute ; + (prepare-dot) XDOT ; M: VECTOR Vnorm - (prepare-nrm2) XNRM2 execute ; + (prepare-nrm2) XNRM2 ; M: VECTOR Vasum - (prepare-nrm2) XASUM execute ; + (prepare-nrm2) XASUM ; M: VECTOR n*V+V! - (prepare-axpy) [ XAXPY execute ] dip ; + (prepare-axpy) [ XAXPY ] dip ; M: VECTOR n*V! - (prepare-scal) [ XSCAL execute ] dip ; + (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR @@ -207,13 +214,13 @@ COMPLEX>ARG DEFINES ${TYPE}-complex>arg WHERE : ( alien len -- sequence ) - 1 shift execute ; + 1 shift ; : >COMPLEX-ARRAY ( sequence -- sequence ) - >ARRAY execute ; + >ARRAY ; : COMPLEX>ARG ( complex -- alien ) - >rect 2array >ARRAY execute underlying>> ; + >rect 2array >ARRAY underlying>> ; : ARG>COMPLEX ( alien -- complex ) - 2 execute first2 rect> ; + 2 first2 rect> ; ;FUNCTOR @@ -234,22 +241,22 @@ WHERE M: VECTOR V. (prepare-dot) TYPE - [ XDOTU_SUB execute ] keep - ARG>TYPE execute ; + [ XDOTU_SUB ] keep + ARG>TYPE ; M: VECTOR V.conj (prepare-dot) TYPE - [ XDOTC_SUB execute ] keep - ARG>TYPE execute ; + [ XDOTC_SUB ] keep + ARG>TYPE ; M: VECTOR Vnorm - (prepare-nrm2) XXNRM2 execute ; + (prepare-nrm2) XXNRM2 ; M: VECTOR Vasum - (prepare-nrm2) XXASUM execute ; + (prepare-nrm2) XXASUM ; M: VECTOR n*V+V! - [ TYPE>ARG execute ] 2dip - (prepare-axpy) [ XAXPY execute ] dip ; + [ TYPE>ARG ] 2dip + (prepare-axpy) [ XAXPY ] dip ; M: VECTOR n*V! - [ TYPE>ARG execute ] dip - (prepare-scal) [ XSCAL execute ] dip ; + [ TYPE>ARG ] dip + (prepare-scal) [ XSCAL ] dip ; ;FUNCTOR @@ -270,3 +277,5 @@ M: VECTOR n*V! >> +M: blas-vector-base >pprint-sequence ; +M: blas-vector-base pprint* pprint-object ; diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 1bc692ca54..d5dff65c35 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -25,7 +25,7 @@ IN: math.combinatorics reverse 1 cut [ (>permutation) ] each ; : permutation-indices ( n seq -- permutation ) - length [ factoradic ] dip 0 pad-left >permutation ; + length [ factoradic ] dip 0 pad-head >permutation ; PRIVATE> diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor index bed3a655b1..1fcc1ead13 100644 --- a/basis/math/complex/complex-docs.factor +++ b/basis/math/complex/complex-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers" "Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:" { $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" } "Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:" -{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ 2.0 0.0 }" } +{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ -2.0 0.0 }" } "Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ; ARTICLE: "complex-numbers" "Complex numbers" diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index ff52c17047..85b4d711ac 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -122,11 +122,9 @@ PRIVATE> [ * ] 2keep gcd nip /i ; foldable : mod-inv ( x n -- y ) - tuck gcd 1 = [ - dup 0 < [ + ] [ nip ] if - ] [ - "Non-trivial divisor found" throw - ] if ; foldable + [ nip ] [ gcd 1 = ] 2bi + [ dup 0 < [ + ] [ nip ] if ] + [ "Non-trivial divisor found" throw ] if ; foldable : ^mod ( x y n -- z ) over 0 < [ diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor old mode 100644 new mode 100755 index 86c3b0de0b..089de35ac5 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -77,7 +77,7 @@ TUPLE: interval { from read-only } { to read-only } ; [ from>> ] [ to>> ] bi ; : points>interval ( seq -- interval ) - dup [ first fp-nan? ] contains? + dup [ first fp-nan? ] any? [ drop [-inf,inf] ] [ dup first [ [ endpoint-min ] reduce ] diff --git a/basis/math/libm/libm-docs.factor b/basis/math/libm/libm-docs.factor index 1fe565ee00..bf4c608d77 100644 --- a/basis/math/libm/libm-docs.factor +++ b/basis/math/libm/libm-docs.factor @@ -5,8 +5,8 @@ ARTICLE: "math.libm" "C standard library math functions" "The words in the " { $vocab-link "math.libm" } " vocabulary call C standard library math functions. They are used to implement words in the " { $vocab-link "math.functions" } " vocabulary." $nl "They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:" -{ $example "2 acos ." "C{ 0.0 1.316957896924817 }" } -{ $example "2 facos ." "0.0/0.0" } +{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" } +{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" } "Trigonometric functions:" { $subsection fcos } { $subsection fsin } diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 13090b6486..1ece3d915e 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -6,10 +6,10 @@ IN: math.polynomials : p= ( p q -- ? ) pextend = ; : ptrim ( p -- p ) - dup length 1 = [ [ zero? ] trim-right ] unless ; + dup length 1 = [ [ zero? ] trim-tail ] unless ; : 2ptrim ( p q -- p q ) [ ptrim ] bi@ ; : p+ ( p q -- r ) pextend v+ ; @@ -29,7 +29,7 @@ PRIVATE> : n*p ( n p -- n*p ) n*v ; : pextend-conv ( p q -- p q ) - 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ; + 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ; : p* ( p q -- r ) 2unempty pextend-conv dup length @@ -44,7 +44,7 @@ PRIVATE> 2ptrim 2dup [ length ] bi@ - dup 1 < [ drop 1 ] when - [ over length + 0 pad-left pextend ] keep 1+ ; + [ over length + 0 pad-head pextend ] keep 1+ ; : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences @@ -68,7 +68,8 @@ PRIVATE> dup V{ 0 } clone p= [ drop nip ] [ - tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd) + [ nip ] [ p/mod ] 2bi + [ pick p* swap [ swapd p- ] dip ] dip (pgcd) ] if ; PRIVATE> diff --git a/basis/math/ranges/ranges-tests.factor b/basis/math/ranges/ranges-tests.factor index 825c68d1b9..aedd2f7933 100644 --- a/basis/math/ranges/ranges-tests.factor +++ b/basis/math/ranges/ranges-tests.factor @@ -1,4 +1,4 @@ -USING: math.ranges sequences tools.test arrays ; +USING: math math.ranges sequences sets tools.test arrays ; IN: math.ranges.tests [ { } ] [ 1 1 (a,b) >array ] unit-test @@ -11,7 +11,7 @@ IN: math.ranges.tests [ { 1 } ] [ 1 2 [a,b) >array ] unit-test [ { 1 2 } ] [ 1 2 [a,b] >array ] unit-test -[ { } ] [ 2 1 (a,b) >array ] unit-test +[ { } ] [ 2 1 (a,b) >array ] unit-test [ { 1 } ] [ 2 1 (a,b] >array ] unit-test [ { 2 } ] [ 2 1 [a,b) >array ] unit-test [ { 2 1 } ] [ 2 1 [a,b] >array ] unit-test @@ -32,3 +32,7 @@ IN: math.ranges.tests [ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test [ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test [ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test + +[ 100 ] [ + 1 100 [a,b] [ 2^ [1,b] ] map prune length +] unit-test \ No newline at end of file diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 1a28904705..068f599b6f 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel layouts math math.order namespaces sequences -sequences.private accessors ; +sequences.private accessors classes.tuple arrays ; IN: math.ranges TUPLE: range @@ -18,6 +18,12 @@ M: range length ( seq -- n ) M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; +! For ranges with many elements, the default element-wise methods +! sequences define are unsuitable because they're O(n) +M: range equal? over range? [ tuple= ] [ 2drop f ] if ; + +M: range hashcode* tuple-hashcode ; + INSTANCE: range immutable-sequence : twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 15914e7b05..e44dbd1a75 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -24,7 +24,7 @@ M: integer / "Division by zero" throw ] [ dup 0 < [ [ neg ] bi@ ] when - 2dup gcd nip tuck /i [ /i ] dip fraction> + 2dup gcd nip tuck [ /i ] 2bi@ fraction> ] if ; M: ratio hashcode* diff --git a/basis/mime/multipart/multipart-tests.factor b/basis/mime/multipart/multipart-tests.factor index e1bf0483bc..d91e31cca2 100644 --- a/basis/mime/multipart/multipart-tests.factor +++ b/basis/mime/multipart/multipart-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings.ascii io.files io.files.unique kernel mime.multipart tools.test io.streams.duplex io multiline -assocs ; +assocs accessors ; IN: mime.multipart.tests : upload-separator ( -- seq ) @@ -20,11 +20,16 @@ IN: mime.multipart.tests [ t ] [ mime-test-stream [ upload-separator parse-multipart ] with-input-stream - nip "\"up.txt\"" swap key? + "file1" swap key? ] unit-test [ t ] [ mime-test-stream [ upload-separator parse-multipart ] with-input-stream - drop "\"text1\"" swap key? + "file1" swap key? +] unit-test + +[ t ] [ + mime-test-stream [ upload-separator parse-multipart ] with-input-stream + "file1" swap at filename>> "up.txt" = ] unit-test diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index 10ddb926dd..fc3024bd01 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -3,7 +3,7 @@ USING: multiline kernel sequences io splitting fry namespaces http.parsers hashtables assocs combinators ascii io.files.unique accessors io.encodings.binary io.files byte-arrays math -io.streams.string combinators.short-circuit strings ; +io.streams.string combinators.short-circuit strings math.order ; IN: mime.multipart CONSTANT: buffer-size 65536 @@ -16,8 +16,7 @@ header content-disposition bytes filename temp-file name name-content -uploaded-files -form-variables ; +mime-parts ; TUPLE: mime-file headers filename temporary-path ; TUPLE: mime-variable headers key value ; @@ -25,8 +24,7 @@ TUPLE: mime-variable headers key value ; : ( mime-separator -- multipart ) multipart new swap >>mime-separator - H{ } clone >>uploaded-files - H{ } clone >>form-variables ; + H{ } clone >>mime-parts ; ERROR: bad-header bytes ; @@ -47,21 +45,18 @@ ERROR: end-of-stream multipart ; dup bytes>> [ fill-bytes ] unless ; : split-bytes ( bytes separator -- leftover-bytes safe-to-dump ) - 2dup [ length ] [ length 1- ] bi* < [ - drop f - ] [ - length 1- cut-slice swap - ] if ; + dupd [ length ] bi@ 1- - short cut-slice swap ; : dump-until-separator ( multipart -- multipart ) - dup [ current-separator>> ] [ bytes>> ] bi tuck start [ + dup + [ current-separator>> ] [ bytes>> ] bi + [ nip ] [ start ] 2bi [ cut-slice [ mime-write ] - [ over current-separator>> length tail-slice >>bytes ] bi* + [ over current-separator>> length short tail-slice >>bytes ] bi* ] [ drop - dup [ bytes>> ] [ current-separator>> ] bi split-bytes - [ mime-write ] when* + dup [ bytes>> ] [ current-separator>> ] bi split-bytes mime-write >>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless ] if* ; @@ -70,31 +65,43 @@ ERROR: end-of-stream multipart ; [ dump-until-separator ] with-string-writer ; : read-header ( multipart -- multipart ) - "\r\n\r\n" dump-string dup "--\r" = [ - drop + dup bytes>> "--\r\n" sequence= [ + t >>end-of-stream? ] [ - parse-headers >>header + "\r\n\r\n" dump-string parse-headers >>header ] if ; : empty-name? ( string -- ? ) { "''" "\"\"" "" f } member? ; +: quote? ( ch -- ? ) "'\"" member? ; + +: quoted? ( str -- ? ) + { + [ length 1 > ] + [ first quote? ] + [ [ first ] [ peek ] bi = ] + } 1&& ; + +: unquote ( str -- newstr ) + dup quoted? [ but-last-slice rest-slice >string ] when ; + : save-uploaded-file ( multipart -- ) dup filename>> empty-name? [ drop ] [ [ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ] - [ filename>> ] - [ uploaded-files>> set-at ] tri + [ content-disposition>> "name" swap at unquote ] + [ mime-parts>> set-at ] tri ] if ; -: save-form-variable ( multipart -- ) +: save-mime-part ( multipart -- ) dup name>> empty-name? [ drop ] [ - [ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ] - [ name>> ] - [ form-variables>> set-at ] tri + [ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ] + [ name>> unquote ] + [ mime-parts>> set-at ] tri ] if ; : dump-mime-file ( multipart filename -- multipart ) @@ -117,12 +124,13 @@ ERROR: unknown-content-disposition multipart ; : parse-form-data ( multipart -- multipart ) "filename" lookup-disposition [ + unquote >>filename [ dump-file ] [ save-uploaded-file ] bi ] [ "name" lookup-disposition [ [ dup mime-separator>> dump-string >>name-content ] dip - >>name dup save-form-variable + >>name dup save-mime-part ] [ unknown-content-disposition ] if* @@ -155,6 +163,6 @@ ERROR: no-content-disposition multipart ; read-header dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ; -: parse-multipart ( separator -- form-variables uploaded-files ) - parse-beginning parse-multipart-loop - [ form-variables>> ] [ uploaded-files>> ] bi ; +: parse-multipart ( separator -- mime-parts ) + parse-beginning fill-bytes parse-multipart-loop + mime-parts>> ; diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index c32f62bf33..6181a72ffc 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -356,6 +356,10 @@ CONSTANT: GL_DITHER HEX: 0BD0 CONSTANT: GL_RGB HEX: 1907 CONSTANT: GL_RGBA HEX: 1908 +! GL_BGRA_ext: http://www.opengl.org/registry/specs/EXT/bgra.txt +CONSTANT: GL_BGR_EXT HEX: 80E0 +CONSTANT: GL_BGRA_EXT HEX: 80E1 + ! Implementation limits CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31 CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35 diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 2d7e2a81ac..9a15dd2105 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -2,9 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test strings namespaces make arrays sequences - peg peg.private accessors words math accessors ; + peg peg.private peg.parsers accessors words math accessors ; IN: peg.tests +[ ] [ reset-pegs ] unit-test + [ "endbegin" "begin" token parse ] must-fail @@ -193,4 +195,16 @@ IN: peg.tests "B" [ drop t ] satisfy [ 66 >= ] semantic parse ] unit-test -{ f } [ \ + T{ parser f f f } equal? ] unit-test \ No newline at end of file +{ f } [ \ + T{ parser f f f } equal? ] unit-test + +USE: compiler + +[ ] [ disable-compiler ] unit-test + +[ ] [ "" epsilon parse drop ] unit-test + +[ ] [ enable-compiler ] unit-test + +[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test + +[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test \ No newline at end of file diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 206a054d35..5ac62239d7 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -509,7 +509,7 @@ TUPLE: sp-parser p1 ; M: sp-parser (compile) ( peg -- quot ) p1>> compile-parser 1quotation '[ - input-slice [ blank? ] trim-left-slice input-from pos set @ + input-slice [ blank? ] trim-head-slice input-from pos set @ ] ; TUPLE: delay-parser quot ; diff --git a/basis/persistent/hashtables/nodes/leaf/leaf.factor b/basis/persistent/hashtables/nodes/leaf/leaf.factor index 3419e8387f..94174d5667 100644 --- a/basis/persistent/hashtables/nodes/leaf/leaf.factor +++ b/basis/persistent/hashtables/nodes/leaf/leaf.factor @@ -6,7 +6,8 @@ persistent.hashtables.nodes ; IN: persistent.hashtables.nodes.leaf : matching-key? ( key hashcode leaf-node -- ? ) - tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline + [ nip ] [ hashcode>> eq? ] 2bi + [ key>> = ] [ 2drop f ] if ; inline M: leaf-node (entry-at) [ matching-key? ] keep and ; diff --git a/basis/persistent/sequences/sequences-docs.factor b/basis/persistent/sequences/sequences-docs.factor index 986b16c737..6928d03f55 100644 --- a/basis/persistent/sequences/sequences-docs.factor +++ b/basis/persistent/sequences/sequences-docs.factor @@ -14,7 +14,7 @@ HELP: ppop { $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." } ; ARTICLE: "persistent.sequences" "Persistent sequence protocol" -"The persistent sequence protocol consists of the non-mutating sequence protocol words, such as " { $link length } " and " { $link nth } ", together with the following operations:" +"The persistent sequence protocol consists of the non-mutating sequence protocol words, such as " { $link length } " and " { $link nth } ", together with the following operations:" { $subsection new-nth } { $subsection ppush } { $subsection ppop } diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 46d4e6e5ff..1e372d7cc0 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -193,11 +193,11 @@ HELP: unparse HELP: pprint-short { $values { "obj" object } } -{ $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ; +{ $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce “shorter†output. See " { $link "prettyprint-variables" } "." } ; HELP: short. { $values { "obj" object } } -{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ; +{ $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" } } diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index b3800babe8..95f05c21ff 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -248,7 +248,8 @@ GENERIC: declarations. ( obj -- ) M: object declarations. drop ; : declaration. ( word prop -- ) - tuck name>> word-prop [ pprint-word ] [ drop ] if ; + [ nip ] [ name>> word-prop ] 2bi + [ pprint-word ] [ drop ] if ; M: word declarations. { diff --git a/basis/xml/generator/authors.txt b/basis/quoted-printable/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from basis/xml/generator/authors.txt rename to basis/quoted-printable/authors.txt diff --git a/basis/quoted-printable/quoted-printable-docs.factor b/basis/quoted-printable/quoted-printable-docs.factor new file mode 100644 index 0000000000..81219a3f84 --- /dev/null +++ b/basis/quoted-printable/quoted-printable-docs.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax strings byte-arrays io.encodings.string ; +IN: quoted-printable + +ABOUT: "quoted-printable" + +ARTICLE: "quoted-printable" "Quoted printable encoding" +"The " { $vocab-link "quoted-printable" } " vocabulary implements RFC 2045 part 6.7, providing words for reading and generating quotable printed text." +{ $subsection >quoted } +{ $subsection >quoted-lines } +{ $subsection quoted> } ; + +HELP: >quoted +{ $values { "byte-array" byte-array } { "string" string } } +{ $description "Encodes a byte array as quoted printable, on a single line." } +{ $warning "To encode a string in quoted printable, first use the " { $link encode } " word." } ; + +HELP: >quoted-lines +{ $values { "byte-array" byte-array } { "string" string } } +{ $description "Encodes a byte array as quoted printable, with soft line breaks inserted so the output lines are no longer than 76 characters." } +{ $warning "To encode a string in quoted printable, first use the " { $link encode } " word with a specific encoding." } ; + +HELP: quoted> +{ $values { "string" string } { "byte-array" byte-array } } +{ $description "Decodes a quoted printable string into an array of the bytes represented." } +{ $warning "When decoding something in quoted printable form and using it as a string, be sure to use the " { $link decode } " word rather than simply converting the byte array to a string." } ; diff --git a/basis/quoted-printable/quoted-printable-tests.factor b/basis/quoted-printable/quoted-printable-tests.factor new file mode 100644 index 0000000000..6f42a48b37 --- /dev/null +++ b/basis/quoted-printable/quoted-printable-tests.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test quoted-printable multiline io.encodings.string +sequences io.encodings.8-bit splitting kernel ; +IN: quoted-printable.tests + +[ <" José was the +person who knew how to write the letters: + Å‘ and ü +and we didn't know hów tö do thât"> ] +[ <" Jos=E9 was the +person who knew how to write the letters: + =F5 and =FC=20 +and w= +e didn't know h=F3w t=F6 do th=E2t"> quoted> latin2 decode ] unit-test + +[ <" Jos=E9 was the=0Aperson who knew how to write the letters:=0A =F5 and =FC=0Aand we didn't know h=F3w t=F6 do th=E2t"> ] +[ <" José was the +person who knew how to write the letters: + Å‘ and ü +and we didn't know hów tö do thât"> latin2 encode >quoted ] unit-test + +: message ( -- str ) + 55 [ "hello" ] replicate concat ; + +[ f ] [ message >quoted "=\r\n" swap subseq? ] unit-test +[ 1 ] [ message >quoted string-lines length ] unit-test +[ t ] [ message >quoted-lines "=\r\n" swap subseq? ] unit-test +[ 4 ] [ message >quoted-lines string-lines length ] unit-test +[ "===o" ] [ message >quoted-lines string-lines [ peek ] "" map-as ] unit-test diff --git a/basis/quoted-printable/quoted-printable.factor b/basis/quoted-printable/quoted-printable.factor new file mode 100644 index 0000000000..3be1a07eab --- /dev/null +++ b/basis/quoted-printable/quoted-printable.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: sequences strings kernel io.encodings.string +math.order ascii math io io.encodings.utf8 io.streams.string +combinators.short-circuit math.parser arrays ; +IN: quoted-printable + +! This implements RFC 2045 section 6.7 + + CHAR: ~ between? ] + [ CHAR: \t = ] + } 1|| ; + +: char>quoted ( ch -- str ) + dup printable? [ 1string ] [ + assure-small >hex >upper + 2 CHAR: 0 pad-head + CHAR: = prefix + ] if ; + +: take-some ( seqs -- seqs seq ) + 0 over [ length + dup 76 >= ] find drop nip + [ 1- cut-slice swap ] [ f swap ] if* concat ; + +: divide-lines ( strings -- strings ) + [ dup ] [ take-some ] [ ] produce nip ; + +PRIVATE> + +: >quoted ( byte-array -- string ) + [ char>quoted ] { } map-as concat "" like ; + +: >quoted-lines ( byte-array -- string ) + [ char>quoted ] { } map-as + divide-lines "=\r\n" join ; + + ] if + ] when ; + +: read-quoted ( -- bytes ) + [ read1 dup ] [ read-char ] [ drop ] B{ } produce-as ; + +PRIVATE> + +: quoted> ( string -- byte-array ) + ! Input should already be normalized to make \r\n into \n + [ read-quoted ] with-string-reader ; diff --git a/basis/quoted-printable/summary.txt b/basis/quoted-printable/summary.txt new file mode 100644 index 0000000000..c32ac1fc80 --- /dev/null +++ b/basis/quoted-printable/summary.txt @@ -0,0 +1 @@ +Quoted printable encoding/decoding diff --git a/basis/quoted-printable/tags.txt b/basis/quoted-printable/tags.txt new file mode 100644 index 0000000000..8fd3eccc9a --- /dev/null +++ b/basis/quoted-printable/tags.txt @@ -0,0 +1,2 @@ +parsing +web diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index 18c9ca781c..01b389c19c 100755 --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -73,7 +73,7 @@ ARTICLE: "random-protocol" "Random protocol" ARTICLE: "random" "Generating random integers" "The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers." $nl -"The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "." +"The “Mersenne Twister†pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "." $nl "Generate a random object:" { $subsection random } diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index c3e98ae1ec..549669cab7 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -72,7 +72,7 @@ IN: regexp.dfa dup [ nfa-traversal-flags>> ] [ dfa-table>> transitions>> keys ] bi - [ tuck [ swap at ] with map concat ] with H{ } map>assoc + [ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc >>dfa-traversal-flags drop ; : construct-dfa ( regexp -- ) diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 2f397538a0..377535eccd 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -63,7 +63,7 @@ left-parenthesis pipe caret dash ; : cut-out ( vector n -- vector' vector ) cut rest ; ERROR: cut-stack-error ; : cut-stack ( obj vector -- vector' vector ) - tuck last-index [ cut-stack-error ] unless* cut-out swap ; + [ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ; : ( obj -- kleene ) possessive-kleene-star boa ; : ( obj -- kleene ) reluctant-kleene-star boa ; diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 6fc21be19c..1cd9a2392e 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -287,9 +287,13 @@ IN: regexp-tests [ { "1" "2" "3" "4" } ] [ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test -[ { "1" "2" "3" "4" } ] +[ { "1" "2" "3" "4" "" } ] [ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ re-split [ >string ] map ] unit-test +[ { "" } ] [ "" R/ =/ re-split [ >string ] map ] unit-test + +[ { "a" "" } ] [ "a=" R/ =/ re-split [ >string ] map ] unit-test + [ { "ABC" "DEF" "GHI" } ] [ "1ABC2DEF3GHI4" R/ [A-Z]+/ all-matches [ >string ] map ] unit-test @@ -299,14 +303,16 @@ IN: regexp-tests [ 0 ] [ "123" R/ [A-Z]+/ count-matches ] unit-test -[ "1.2.3.4" ] +[ "1.2.3.4." ] [ "1ABC2DEF3GHI4JK" R/ [A-Z]+/ "." re-replace ] unit-test + +[ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test /* ! FIXME [ f ] [ "ab" "a(?!b)" first-match ] unit-test [ "a" ] [ "ac" "a(?!b)" first-match >string ] unit-test -! [ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test +[ t ] [ "fxxbar" "(?!foo).{3}bar" matches? ] unit-test [ f ] [ "foobar" "(?!foo).{3}bar" matches? ] unit-test [ "a" ] [ "ab" "a(?=b)(?=b)" first-match >string ] unit-test [ "a" ] [ "ba" "a(?<=b)(?<=b)" first-match >string ] unit-test @@ -317,7 +323,7 @@ IN: regexp-tests */ ! Bug in parsing word -[ t ] [ "a" R' a' matches? ] unit-test +[ t ] [ "a" R' a' matches? ] unit-test ! Convert to lowercase until E [ f ] [ "AA" R/ \LAA\E/ matches? ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index c615719cc4..86f978373b 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -61,8 +61,11 @@ IN: regexp dupd first-match [ split1-slice swap ] [ "" like f swap ] if* ; +: (re-split) ( string regexp -- ) + over [ [ re-cut , ] keep (re-split) ] [ 2drop ] if ; + : re-split ( string regexp -- seq ) - [ dup length 0 > ] swap '[ _ re-cut ] [ ] produce nip ; + [ (re-split) ] { } make ; : re-replace ( string regexp replacement -- result ) [ re-split ] dip join ; diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor index 5375d813e1..e5c31a54e0 100644 --- a/basis/regexp/transition-tables/transition-tables.factor +++ b/basis/regexp/transition-tables/transition-tables.factor @@ -35,7 +35,7 @@ TUPLE: transition-table transitions start-state final-states ; H{ } clone >>final-states ; : maybe-initialize-key ( key hashtable -- ) - 2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ; + 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; : set-transition ( transition hash -- ) #! set the state as a key diff --git a/basis/sequences/deep/deep-docs.factor b/basis/sequences/deep/deep-docs.factor old mode 100644 new mode 100755 index f067e6ecdd..6193c7a7e8 --- a/basis/sequences/deep/deep-docs.factor +++ b/basis/sequences/deep/deep-docs.factor @@ -21,10 +21,10 @@ HELP: deep-find { $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } { $see-also find } ; -HELP: deep-contains? +HELP: deep-any? { $values { "obj" object } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } } { $description "Tests whether the given object or any subnode satisfies the given quotation." } -{ $see-also contains? } ; +{ $see-also any? } ; HELP: flatten { $values { "obj" object } { "seq" "a sequence" } } @@ -41,7 +41,7 @@ ARTICLE: "sequences.deep" "Deep sequence combinators" { $subsection deep-map } { $subsection deep-filter } { $subsection deep-find } -{ $subsection deep-contains? } +{ $subsection deep-any? } { $subsection deep-change-each } "A utility word to collapse nested subsequences:" { $subsection flatten } ; diff --git a/basis/sequences/deep/deep-tests.factor b/basis/sequences/deep/deep-tests.factor old mode 100644 new mode 100755 index 2d3260f427..e26241abc3 --- a/basis/sequences/deep/deep-tests.factor +++ b/basis/sequences/deep/deep-tests.factor @@ -19,7 +19,7 @@ IN: sequences.deep.tests [ { { "heyhello" "hihello" } } ] [ "hey" 1array 1array [ [ change-something ] deep-change-each ] keep ] unit-test -[ t ] [ "foo" [ string? ] deep-contains? ] unit-test +[ t ] [ "foo" [ string? ] deep-any? ] unit-test [ "foo" ] [ "foo" [ string? ] deep-find ] unit-test diff --git a/basis/sequences/deep/deep.factor b/basis/sequences/deep/deep.factor old mode 100644 new mode 100755 index d942b3f4c4..bfc102fdc2 --- a/basis/sequences/deep/deep.factor +++ b/basis/sequences/deep/deep.factor @@ -33,10 +33,10 @@ M: object branch? drop f ; : deep-find ( obj quot -- elt ) (deep-find) drop ; inline -: deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline +: deep-any? ( obj quot -- ? ) (deep-find) nip ; inline : deep-all? ( obj quot -- ? ) - '[ @ not ] deep-contains? not ; inline + '[ @ not ] deep-any? not ; inline : deep-member? ( obj seq -- ? ) swap '[ diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 3ec1e96c72..4a0d3777b8 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -221,8 +221,7 @@ SYMBOL: deserialized (deserialize) (deserialize) 2dup lookup dup [ 2nip ] [ drop - "Unknown word: " -rot - 2array unparse append throw + 2array unparse "Unknown word: " prepend throw ] if ; : deserialize-gensym ( -- word ) diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor index f986404404..5d7791292b 100644 --- a/basis/smtp/server/server.factor +++ b/basis/smtp/server/server.factor @@ -4,7 +4,7 @@ USING: combinators kernel prettyprint io io.timeouts sequences namespaces io.sockets io.sockets.secure continuations calendar io.encodings.ascii io.streams.duplex destructors locals concurrency.promises threads accessors smtp.private -io.sockets.secure.unix.debug ; +io.sockets.secure.unix.debug io.crlf ; IN: smtp.server ! Mock SMTP server for testing purposes. diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 2ffc2e6db3..03b9d8af11 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -6,7 +6,7 @@ io.encodings.utf8 io.timeouts io.sockets io.sockets.secure io.encodings.ascii kernel logging sequences combinators splitting assocs strings math.order math.parser random system calendar summary calendar.format accessors sets hashtables -base64 debugger classes prettyprint ; +base64 debugger classes prettyprint io.crlf ; IN: smtp SYMBOL: smtp-domain @@ -50,12 +50,6 @@ TUPLE: email +HELP: human<=> { $values { "obj1" object } { "obj2" object } { "<=>" "an ordering specifier" } } { $description "Compares two objects after converting numbers in the string into integers." } ; -HELP: human->=< +HELP: human>=< { $values { "obj1" object } { "obj2" object } { ">=<" "an ordering specifier" } } -{ $description "Compares two objects using the " { $link human-<=> } " word and inverts the result." } ; +{ $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ; HELP: human-compare { $values @@ -44,22 +44,22 @@ HELP: human-sort-keys { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements comparing first elements of pairs using the " { $link human-<=> } " word." } ; +{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ; HELP: human-sort-values { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements comparing second elements of pairs using the " { $link human-<=> } " word." } ; +{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ; { <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words -ARTICLE: "sorting.human" "sorting.human" +ARTICLE: "sorting.human" "Human-friendly sorting" "The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl "Comparing two objects:" -{ $subsection human-<=> } -{ $subsection human->=< } +{ $subsection human<=> } +{ $subsection human>=< } { $subsection human-compare } "Sort a sequence:" { $subsection human-sort } diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index 2c4d391a60..1c7392901b 100644 --- a/basis/sorting/human/human.factor +++ b/basis/sorting/human/human.factor @@ -7,13 +7,13 @@ IN: sorting.human : find-numbers ( string -- seq ) [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ; -: human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ; +: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ; -: human->=< ( obj1 obj2 -- >=< ) human-<=> invert-comparison ; inline +: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline -: human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ; +: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; -: human-sort ( seq -- seq' ) [ human-<=> ] sort ; +: human-sort ( seq -- seq' ) [ human<=> ] sort ; : human-sort-keys ( seq -- sortedseq ) [ [ first ] human-compare ] sort ; diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index 7a4eeb8e75..46824c6fdb 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -41,7 +41,7 @@ TUPLE: tuple2 d ; T{ sort-test f 1 1 11 } T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } - } { { a>> human-<=> } { b>> human->=< } { c>> <=> } } sort-by-slots + } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots ] unit-test [ @@ -64,7 +64,7 @@ TUPLE: tuple2 d ; T{ sort-test f 2 5 3 } T{ sort-test f 2 5 2 } } - { { a>> human-<=> } { b>> <=> } } [ sort-by-slots ] keep + { { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep [ but-last-slice ] map split-by-slots [ >array ] map ] unit-test diff --git a/basis/soundex/soundex.factor b/basis/soundex/soundex.factor index 164f634185..2fd928252f 100644 --- a/basis/soundex/soundex.factor +++ b/basis/soundex/soundex.factor @@ -14,7 +14,7 @@ TR: soundex-tr [ 2 [ = not ] assoc-filter values ] [ first ] bi prefix ; : first>upper ( seq -- seq' ) 1 head >upper ; -: trim-first ( seq -- seq' ) dup first [ = ] curry trim-left ; +: trim-first ( seq -- seq' ) dup first [ = ] curry trim-head ; : remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ; : remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ; : pad-4 ( first seq -- seq' ) "000" 3append 4 head ; diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 14fb739947..ce23186fc6 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -27,8 +27,8 @@ TUPLE: A M: A length length>> ; M: A nth-unsafe underlying>> NTH call ; M: A set-nth-unsafe underlying>> SET-NTH call ; -M: A like drop dup A instance? [ >A' execute ] unless ; -M: A new-sequence drop execute ; +M: A like drop dup A instance? [ >A' ] unless ; +M: A new-sequence drop ; INSTANCE: A sequence diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 579da5b84a..9a56346be4 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -49,9 +49,9 @@ M: A set-nth-unsafe underlying>> SET-NTH call ; : >A ( seq -- specialized-array ) A new clone-like ; inline -M: A like drop dup A instance? [ >A execute ] unless ; +M: A like drop dup A instance? [ >A ] unless ; -M: A new-sequence drop (A) execute ; +M: A new-sequence drop (A) ; M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; @@ -64,13 +64,13 @@ M: A resize M: A byte-length underlying>> length ; -M: A pprint-delims drop A{ \ } ; +M: A pprint-delims drop \ A{ \ } ; M: A >pprint-sequence ; M: A pprint* pprint-object ; -: A{ \ } [ >A execute ] parse-literal ; parsing +: A{ \ } [ >A ] parse-literal ; parsing INSTANCE: A sequence diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 6069a4cb4a..2410cc284e 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -18,28 +18,28 @@ WHERE TUPLE: V { underlying A } { length array-capacity } ; -: ( capacity -- vector )     execute 0 V boa ; inline +: ( capacity -- vector ) 0 V boa ; inline M: V like drop dup V instance? [ - dup A instance? [ dup length V boa ] [ >V execute ] if + dup A instance? [ dup length V boa ] [ >V ] if ] unless ; -M: V new-sequence drop [ execute ] [ >fixnum ] bi V boa ; +M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; -M: A new-resizable drop execute ; +M: A new-resizable drop ; M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; : >V ( seq -- vector ) V new clone-like ; inline -M: V pprint-delims drop V{ \ } ; +M: V pprint-delims drop \ V{ \ } ; M: V >pprint-sequence ; M: V pprint* pprint-object ; -: V{ \ } [ >V execute ] parse-literal ; parsing +: V{ \ } [ >V ] parse-literal ; parsing INSTANCE: V growable diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor old mode 100644 new mode 100755 index 9516b8cd7d..b08bdd8436 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -147,7 +147,7 @@ M: object apply-object push-literal ; { { [ dup deferred? ] [ drop f ] } { [ dup crossref? not ] [ drop f ] } - [ def>> [ word? ] contains? ] + [ def>> [ word? ] any? ] } cond ; : ?missing-effect ( word -- ) diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor old mode 100644 new mode 100755 index aa179fe191..2eb4fb46a9 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -17,7 +17,7 @@ SYMBOL: +bottom+ : pad-with-bottom ( seq -- newseq ) dup empty? [ dup [ length ] map supremum - '[ _ +bottom+ pad-left ] map + '[ _ +bottom+ pad-head ] map ] unless ; : phi-inputs ( max-d-in pairs -- newseq ) @@ -108,7 +108,7 @@ M: callable infer-branch (infer-if) ] [ drop 2 consume-d - dup [ known [ curried? ] [ composed? ] bi or ] contains? [ + dup [ known [ curried? ] [ composed? ] bi or ] any? [ output-d [ rot [ drop call ] [ nip call ] if ] infer-quot-here diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 3836fadeb7..7cdce301b5 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -643,7 +643,7 @@ M: object infer-call* \ dll-valid? { object } { object } define-primitive -\ modify-code-heap { array object } { } define-primitive +\ modify-code-heap { array } { } define-primitive \ unimplemented { } { } define-primitive diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index f208178b10..5b67cd9adc 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -21,7 +21,7 @@ $nl ARTICLE: "inference-combinators" "Combinator stack effects" "Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." -{ $example "[ dup call ] infer." "... an error ..." } +{ $example "[ dup call ] infer." "Literal value expected\n\nType :help for debugging help." } "On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:" { $example "[ [ 2 + ] call ] infer." "( object -- object )" } "Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:" @@ -35,7 +35,15 @@ $nl "Here is an example where the stack effect cannot be inferred:" { $code ": foo 0 [ + ] ;" "[ foo reduce ] infer." } "However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":" -{ $example ": foo 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } ; +{ $example ": foo 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } +"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:" +{ $example + "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Literal value expected\n\nType :help for debugging help." +} +"To make this work, pass the quotation on the retain stack instead:" +{ $example + "[ [ reverse ] [ [ reverse ] map ] dip call ] infer." "( object -- object )" +} ; ARTICLE: "inference-branches" "Branch stack effects" "Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "." @@ -58,12 +66,14 @@ $nl $nl "If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "." $nl -"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example," -{ $see loop } -"An inline recursive word cannot pass a quotation through the recursive call. For example, the following will not infer:" -{ $code ": foo ( a b c -- d e f ) [ f foo drop ] when 2dup call ; inline" "[ 1 [ 1+ ] foo ] infer." } +"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:" +{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Literal value expected\n\nType :help for debugging help." } +"The following is correct:" +{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" } +"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:" +{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Literal value expected\n\nType :help for debugging help." } "However a small change can be made:" -{ $example ": foo ( a b c -- d ) [ 2dup f foo drop ] when call ; inline" "[ 1 [ 1+ ] t foo ] infer." "( -- object )" } +{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" } "An inline recursive word must have a fixed stack effect in its base case. The following will not infer:" { $code ": foo ( quot ? -- ) [ f foo ] [ call ] if ; inline" diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor old mode 100644 new mode 100755 index 299dc1b551..7afac0440f --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -125,9 +125,9 @@ IN: stack-checker.transforms #! Can we use a fast byte array test here? { { [ dup length 8 < ] [ f ] } - { [ dup [ integer? not ] contains? ] [ f ] } - { [ dup [ 0 < ] contains? ] [ f ] } - { [ dup [ bit-member-n >= ] contains? ] [ f ] } + { [ dup [ integer? not ] any? ] [ f ] } + { [ dup [ 0 < ] any? ] [ f ] } + { [ dup [ bit-member-n >= ] any? ] [ f ] } [ t ] } cond nip ; diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor index 1ddcbf8090..8cfdc9e1d5 100644 --- a/basis/syndication/syndication-tests.factor +++ b/basis/syndication/syndication-tests.factor @@ -1,5 +1,5 @@ USING: syndication io kernel io.files tools.test io.encodings.utf8 -calendar urls ; +calendar urls xml.writer ; IN: syndication.tests \ download-feed must-infer @@ -43,3 +43,4 @@ IN: syndication.tests } } } ] [ "resource:basis/syndication/test/atom.xml" load-news-file ] unit-test +[ ] [ "resource:basis/syndication/test/atom.xml" load-news-file feed>xml xml>string drop ] unit-test diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor old mode 100644 new mode 100755 index c82fe4006d..4cd5ef17b3 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. ! Portions copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: xml.utilities kernel assocs xml.generator math.order +USING: xml.utilities kernel assocs math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities.html io.files io - http.client namespaces make xml.generator hashtables + http.client namespaces make xml.literals hashtables calendar.format accessors continuations urls present ; IN: syndication : any-tag-named ( tag names -- tag-inside ) - f -rot [ tag-named nip dup ] with find 2drop ; + [ f ] 2dip [ tag-named nip dup ] with find 2drop ; TUPLE: feed title url entries ; @@ -70,8 +70,8 @@ TUPLE: entry title url description date ; tri ; : atom-entry-link ( tag -- url/f ) - "link" tags-named [ "rel" swap at "alternate" = ] find nip - dup [ "href" swap at >url ] when ; + "link" tags-named [ "rel" attr "alternate" = ] find nip + dup [ "href" attr >url ] when ; : atom1.0-entry ( tag -- entry ) entry new @@ -80,8 +80,8 @@ TUPLE: entry title url description date ; [ atom-entry-link >>url ] [ { "content" "summary" } any-tag-named - dup children>> [ string? not ] contains? - [ children>> [ write-xml-chunk ] with-string-writer ] + dup children>> [ string? not ] any? + [ children>> xml>string ] [ children>string ] if >>description ] [ @@ -95,7 +95,7 @@ TUPLE: entry title url description date ; feed new swap [ "title" tag-named children>string >>title ] - [ "link" tag-named "href" swap at >url >>url ] + [ "link" tag-named "href" attr >url >>url ] [ "entry" tags-named [ atom1.0-entry ] map set-entries ] tri ; @@ -114,26 +114,31 @@ TUPLE: entry title url description date ; http-get nip string>feed ; ! Atom generation -: simple-tag, ( content name -- ) - [ , ] tag, ; -: simple-tag*, ( content name attrs -- ) - [ , ] tag*, ; - -: entry, ( entry -- ) - "entry" [ - { - [ title>> "title" { { "type" "html" } } simple-tag*, ] - [ url>> present "href" associate "link" swap contained*, ] - [ date>> timestamp>rfc3339 "published" simple-tag, ] - [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ] - } cleave - ] tag, ; +: entry>xml ( entry -- xml ) + { + [ title>> ] + [ url>> present ] + [ date>> timestamp>rfc3339 ] + [ description>> ] + } cleave + [XML + + <-> + /> + <-> + <-> + + XML] ; : feed>xml ( feed -- xml ) - "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [ - [ title>> "title" simple-tag, ] - [ url>> present "href" associate "link" swap contained*, ] - [ entries>> [ entry, ] each ] - tri - ] make-xml* ; + [ title>> ] + [ url>> present ] + [ entries>> [ entry>xml ] map ] tri + + <-> + /> + <-> + + XML> ; diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor old mode 100644 new mode 100755 index e7e2e55259..3d09802576 --- a/basis/tools/crossref/crossref-tests.factor +++ b/basis/tools/crossref/crossref-tests.factor @@ -10,4 +10,4 @@ M: integer foo + ; "resource:basis/tools/crossref/test/foo.factor" run-file [ t ] [ integer \ foo method \ + usage member? ] unit-test -[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test +[ t ] [ \ foo usage [ pathname? ] any? ] unit-test diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index a915551263..cb52b1d5db 100644 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -59,8 +59,8 @@ SINGLETON: udis-disassembler dup [ second length ] map supremum '[ [ - [ first >hex cell 2 * CHAR: 0 pad-left % ": " % ] - [ second _ CHAR: \s pad-right % " " % ] + [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ] + [ second _ CHAR: \s pad-tail % " " % ] [ third % ] tri ] "" make diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 936c682322..7508c37cac 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -9,22 +9,22 @@ IN: tools.files : dir-or-size ( file-info -- str ) dup directory? [ - drop "" 20 CHAR: \s pad-right + drop "" 20 CHAR: \s pad-tail ] [ - size>> number>string 20 CHAR: \s pad-left + size>> number>string 20 CHAR: \s pad-head ] if ; : listing-time ( timestamp -- string ) [ hour>> ] [ minute>> ] bi - [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ; + [ number>string 2 CHAR: 0 pad-head ] bi@ ":" glue ; : listing-date ( timestamp -- string ) [ month>> month-abbreviation ] - [ day>> number>string 2 CHAR: \s pad-left ] + [ day>> number>string 2 CHAR: \s pad-head ] [ dup year>> dup now year>> = [ drop listing-time ] [ nip number>string ] if - 5 CHAR: \s pad-left + 5 CHAR: \s pad-head ] tri 3array " " join ; : read>string ( ? -- string ) "r" "-" ? ; inline diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index d16d6b2595..b646760889 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -12,13 +12,13 @@ IN: tools.hexdump [ >hex write "h" write nl ] bi ; : write-offset ( lineno -- ) - 16 * >hex 8 CHAR: 0 pad-left write "h: " write ; + 16 * >hex 8 CHAR: 0 pad-head write "h: " write ; : >hex-digit ( digit -- str ) - >hex 2 CHAR: 0 pad-left " " append ; + >hex 2 CHAR: 0 pad-head " " append ; : >hex-digits ( bytes -- str ) - [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ; + [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ; : >ascii ( bytes -- str ) [ [ printable? ] keep CHAR: . ? ] "" map-as ; diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor old mode 100644 new mode 100755 index b6e8eb2a46..acea984700 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -22,7 +22,7 @@ ERROR: no-vocab vocab ; : contains-dot? ( string -- ? ) ".." swap subseq? ; -: contains-separator? ( string -- ? ) [ path-separator? ] contains? ; +: contains-separator? ( string -- ? ) [ path-separator? ] any? ; : check-vocab-name ( string -- string ) dup contains-dot? [ vocab-name-contains-dot ] when @@ -92,7 +92,7 @@ ERROR: no-vocab vocab ; ] if ; : lookup-type ( string -- object/string ? ) - "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-right + "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-tail H{ { "object" object } { "obj" object } { "quot" quotation } diff --git a/basis/tools/threads/threads-docs.factor b/basis/tools/threads/threads-docs.factor index d4c5be9c17..c60255b377 100644 --- a/basis/tools/threads/threads-docs.factor +++ b/basis/tools/threads/threads-docs.factor @@ -2,10 +2,10 @@ IN: tools.threads USING: help.markup help.syntax threads ; HELP: threads. -{ $description "Prints a list of running threads and their state. The ``Waiting on'' column displays one of the following:" +{ $description "Prints a list of running threads and their state. The “Waiting on†column displays one of the following:" { $list - "``running'' if the thread is the current thread" - "``yield'' if the thread is waiting to run" + "“running†if the thread is the current thread" + "“yield†if the thread is waiting to run" { "the string given to " { $link suspend } " if the thread is suspended" } } } ; diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/tools/vocabs/monitor/monitor.factor index ac0160e58f..1914da78b2 100644 --- a/basis/tools/vocabs/monitor/monitor.factor +++ b/basis/tools/vocabs/monitor/monitor.factor @@ -1,16 +1,16 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.pathnames io.monitors init kernel vocabs vocabs.loader tools.vocabs namespaces continuations sequences splitting assocs command-line concurrency.messaging -io.backend sets tr ; +io.backend sets tr accessors ; IN: tools.vocabs.monitor TR: convert-separators "/\\" ".." ; : vocab-dir>vocab-name ( path -- vocab ) - trim-left-separators - trim-right-separators + trim-head-separators + trim-tail-separators convert-separators ; : path>vocab-name ( path -- vocab ) @@ -29,7 +29,7 @@ TR: convert-separators "/\\" ".." ; : monitor-loop ( -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. - receive first path>vocab changed-vocab + receive path>> path>vocab changed-vocab reset-cache monitor-loop ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 67386c1807..dc2cedfef8 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -350,7 +350,7 @@ M: editor gadget-text* editor-string % ; dupd editor-select-next mark>caret ; : editor-select ( from to editor -- ) - tuck caret>> set-model mark>> set-model ; + tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ; : select-elt ( editor elt -- ) [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index baf025d116..2af0f6e6a2 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -165,7 +165,9 @@ M: gadget dim-changed in-layout? get [ invalidate ] [ invalidate* ] if ; M: gadget (>>dim) ( dim gadget -- ) - 2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ; + 2dup dim>> = + [ 2drop ] + [ [ nip ] [ call-next-method ] 2bi dim-changed ] if ; GENERIC: pref-dim* ( gadget -- dim ) @@ -250,7 +252,7 @@ M: gadget ungraft* drop ; f >>parent drop ; : unfocus-gadget ( child gadget -- ) - tuck focus>> eq? [ f >>focus ] when drop ; + [ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ; SYMBOL: in-layout? @@ -286,10 +288,7 @@ SYMBOL: in-layout? dup unparent over >>parent tuck ((add-gadget)) - tuck graft-state>> second - [ graft ] - [ drop ] - if ; + tuck graft-state>> second [ graft ] [ drop ] if ; : add-gadget ( parent child -- parent ) not-in-layout @@ -316,7 +315,7 @@ SYMBOL: in-layout? : (screen-rect) ( gadget -- loc ext ) dup parent>> [ [ rect-extent ] dip (screen-rect) - [ tuck v+ ] dip vmin [ v+ ] dip + [ [ nip ] [ v+ ] 2bi ] dip [ v+ ] [ vmin ] 2bi* ] [ rect-extent ] if* ; diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor index af249bbdc8..2b33d2bfe1 100644 --- a/basis/ui/gadgets/incremental/incremental.factor +++ b/basis/ui/gadgets/incremental/incremental.factor @@ -23,7 +23,7 @@ M: incremental pref-dim* ] keep orientation>> set-axis ; : update-cursor ( gadget incremental -- ) - tuck next-cursor >>cursor drop ; + [ nip ] [ next-cursor ] 2bi >>cursor drop ; : incremental-loc ( gadget incremental -- ) [ cursor>> ] [ orientation>> ] bi v* diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index 8e1cc8d8f0..2caea23480 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -85,7 +85,7 @@ ARTICLE: "ui-completion-vocabs" "Vocabulary completion popup" { $operations "kernel" vocab } ; ARTICLE: "ui-completion-sources" "Source file completion popup" -"The source file completion popup lists all source files which have been previously loaded by " { $link run-file } ". Clicking a source file or pressing " { $snippet "RET" } " opens the source file in your editor with " { $link edit } "." +"The source file completion popup lists all source files which have been previously loaded by " { $link run-file } ". Clicking a source file or pressing " { $snippet "RET" } " opens the source file in your editor with " { $link edit } "." { $operations P" " } ; ARTICLE: "ui-completion" "UI completion popups" diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index 64a98fee03..5c0085bc45 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -185,7 +185,9 @@ $nl { $subsection add-gadgets } { $subsection clear-gadget } "The children of a gadget are available via the " -{ $snippet "children" } " slot. " "Working with gadget children:" +{ $snippet "children" } " slot. " +$nl +"Working with gadget children:" { $subsection gadget-child } { $subsection nth-gadget } { $subsection each-child } @@ -199,7 +201,7 @@ $nl { $subsection relayout-1 } "Gadgets implement a generic word to inform their parents of their preferred size:" { $subsection pref-dim* } -"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ; +"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ; ARTICLE: "ui-null-layout" "Manual layouts" "When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually by setting the " { $snippet "loc" } " field." ; diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index 666ebf2f18..34cff42777 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -144,7 +144,7 @@ M: world selection-notify-event : supported-type? ( atom -- ? ) { "UTF8_STRING" "STRING" "TEXT" } - [ x-atom = ] with contains? ; + [ x-atom = ] with any? ; : clipboard-for-atom ( atom -- clipboard ) { diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 336d99657e..6bcf8b50cc 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -96,7 +96,7 @@ PRIVATE> : first-grapheme ( str -- i ) unclip-slice grapheme-class over - [ grapheme-class tuck grapheme-break? ] find drop + [ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop nip swap length or 1+ ; } +"Predicates for weak equality testing:" { $subsection primary= } { $subsection secondary= } { $subsection tertiary= } @@ -14,12 +15,12 @@ ARTICLE: "unicode.collation" "Collation and weak comparison" ABOUT: "unicode.collation" HELP: sort-strings -{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } } -{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ; +{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in lexicographical order" } } +{ $description "This word takes a sequence of strings and sorts them according to the Unicode Collation Algorithm with the default collation order described in the DUCET. It uses code point order as a tie-breaker." } ; HELP: collation-key { $values { "string" string } { "key" byte-array } } -{ $description "This takes a string and gives a representation of the collation key, which can be compared with <=>" } ; +{ $description "This takes a string and gives a representation of the collation key, which can be compared with " { $link <=> } ". The representation is according to the DUCET." } ; HELP: string<=> { $values { "str1" string } { "str2" string } { "<=>" "one of +lt+, +gt+ or +eq+" } } @@ -27,16 +28,16 @@ HELP: string<=> HELP: primary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "This checks whether the first level of collation is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation and accent marks." } ; +{ $description "This checks whether the first level of collation key is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation, whitespace and accent marks." } ; HELP: secondary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "This checks whether the first two levels of collation are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to primary=." } ; +{ $description "This checks whether the first two levels of collation key are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to " { $link primary= } "." } ; HELP: tertiary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "Along the same lines as secondary=, but case is significant." } ; +{ $description "This checks if the first three levels of collation key are equal. For Latin-based scripts, it can be understood as testing for what " { $link secondary= } " tests for, but case is significant." } ; HELP: quaternary= { $values { "str1" string } { "str2" string } { "?" "t or f" } } -{ $description "This is similar to tertiary= but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ; +{ $description "This checks if the first four levels of collation key are equal. This is similar to " { $link tertiary= } " but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ; diff --git a/basis/unicode/collation/collation.factor b/basis/unicode/collation/collation.factor old mode 100644 new mode 100755 index 5718ae12a7..a8bd788e2a --- a/basis/unicode/collation/collation.factor +++ b/basis/unicode/collation/collation.factor @@ -88,7 +88,7 @@ ducet insert-helpers : add ( char -- ) dup blocked? [ 1string , ] [ dup possible-bases dup length - [ ?combine ] with with contains? + [ ?combine ] with with any? [ drop ] [ 1string , ] if ] if ; @@ -125,7 +125,7 @@ PRIVATE> : filter-ignorable ( weights -- weights' ) f swap [ - tuck primary>> zero? and + [ nip ] [ primary>> zero? and ] 2bi [ swap ignorable?>> or ] [ swap completely-ignorable? or not ] 2bi ] filter nip ; @@ -138,7 +138,7 @@ PRIVATE> : insensitive= ( str1 str2 levels-removed -- ? ) [ [ collation-key ] dip - [ [ 0 = not ] trim-right but-last ] times + [ [ 0 = not ] trim-tail but-last ] times ] curry bi@ = ; PRIVATE> diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index e78b4c104a..2407b740b0 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -72,7 +72,7 @@ VALUE: properties : exclusions ( -- set ) exclusions-file utf8 file-lines - [ "#" split1 drop [ blank? ] trim-right hex> ] map harvest ; + [ "#" split1 drop [ blank? ] trim-tail hex> ] map harvest ; : remove-exclusions ( alist -- alist ) exclusions [ dup ] H{ } map>assoc assoc-diff ; diff --git a/basis/unicode/normalize/normalize-docs.factor b/basis/unicode/normalize/normalize-docs.factor index 4b1e3485ef..453ab24388 100644 --- a/basis/unicode/normalize/normalize-docs.factor +++ b/basis/unicode/normalize/normalize-docs.factor @@ -4,7 +4,13 @@ IN: unicode.normalize ABOUT: "unicode.normalize" ARTICLE: "unicode.normalize" "Unicode normalization" -"The " { $vocab-link "unicode.normalize" "unicode.normalize" } " vocabulary defines words for normalizing Unicode strings. In Unicode, it is often possible to have multiple sequences of characters which really represent exactly the same thing. For example, to represent e with an acute accent above, there are two possible strings: \"e\\u000301\" (the e character, followed by the combining acute accent character) and \"\\u0000e9\" (a single character, e with an acute accent). There are four normalization forms: NFD, NFC, NFKD, and NFKC. Basically, in NFD and NFKD, everything is expanded, whereas in NFC and NFKC, everything is contracted. In NFKD and NFKC, more things are expanded and contracted. This is a process which loses some information, so it should be done only with care. Most of the world uses NFC to communicate, but for many purposes, NFD/NFKD is easier to process. For more information, see Unicode Standard Annex #15 and section 3 of the Unicode standard." +"The " { $vocab-link "unicode.normalize" "unicode.normalize" } " vocabulary defines words for normalizing Unicode strings." +$nl +"In Unicode, it is often possible to have multiple sequences of characters which really represent exactly the same thing. For example, to represent e with an acute accent above, there are two possible strings: " { $snippet "\"e\\u000301\"" } " (the e character, followed by the combining acute accent character) and " { $snippet "\"\\u0000e9\"" } " (a single character, e with an acute accent)." +$nl +"There are four normalization forms: NFD, NFC, NFKD, and NFKC. Basically, in NFD and NFKD, everything is expanded, whereas in NFC and NFKC, everything is contracted. In NFKD and NFKC, more things are expanded and contracted. This is a process which loses some information, so it should be done only with care." +$nl +"Most of the world uses NFC to communicate, but for many purposes, NFD/NFKD is easier to process. For more information, see Unicode Standard Annex #15 and section 3 of the Unicode standard." { $subsection nfc } { $subsection nfd } { $subsection nfkc } @@ -12,16 +18,16 @@ ARTICLE: "unicode.normalize" "Unicode normalization" HELP: nfc { $values { "string" string } { "nfc" "a string in NFC" } } -{ $description "Converts a string to Normalization Form C" } ; +{ $description "Converts a string to Normalization Form C." } ; HELP: nfd { $values { "string" string } { "nfd" "a string in NFD" } } -{ $description "Converts a string to Normalization Form D" } ; +{ $description "Converts a string to Normalization Form D." } ; HELP: nfkc { $values { "string" string } { "nfkc" "a string in NFKC" } } -{ $description "Converts a string to Normalization Form KC" } ; +{ $description "Converts a string to Normalization Form KC." } ; HELP: nfkd { $values { "string" string } { "nfkd" "a string in NFKD" } } -{ $description "Converts a string to Normalization Form KD" } ; +{ $description "Converts a string to Normalization Form KD." } ; diff --git a/basis/unicode/unicode-docs.factor b/basis/unicode/unicode-docs.factor index 5b7b7e9ab3..4ae326ac84 100644 --- a/basis/unicode/unicode-docs.factor +++ b/basis/unicode/unicode-docs.factor @@ -1,8 +1,14 @@ -USING: help.markup help.syntax ; +USING: help.markup help.syntax strings ; IN: unicode ARTICLE: "unicode" "Unicode" -"Unicode is a set of characters, or " { $emphasis "code points" } " covering what's used in most world writing systems. Any Factor string can hold any of these code points transparently; a factor string is a sequence of Unicode code points. Unicode is accompanied by several standard algorithms for common operations like encoding in files, capitalizing a string, finding the boundaries between words, etc. When a programmer is faced with a string manipulation problem, where the string represents human language, a Unicode algorithm is often much better than the naive one. This is not in terms of efficiency, but rather internationalization. Even English text that remains in ASCII is better served by the Unicode collation algorithm than a naive algorithm. The Unicode algorithms implemented here are:" +"The " { $vocab-link "unicode" } " vocabulary and its sub-vocabularies implement support for the Unicode 5.1 character set." +$nl +"The Unicode character set contains most of the world's writing systems. Unicode is intended as a replacement for, and is a superset of, such legacy character sets as ASCII, Latin1, MacRoman, and so on. Unicode characters are called " { $emphasis "code points" } "; Factor's " { $link "strings" } " are sequences of code points." +$nl +"The Unicode character set is accompanied by several standard algorithms for common operations like encoding text in files, capitalizing a string, finding the boundaries between words, and so on." +$nl +"The Unicode algorithms implemented by the " { $vocab-link "unicode" } " vocabulary are:" { $vocab-subsection "Case mapping" "unicode.case" } { $vocab-subsection "Collation and weak comparison" "unicode.collation" } { $vocab-subsection "Character classes" "unicode.categories" } @@ -11,6 +17,6 @@ ARTICLE: "unicode" "Unicode" "The following are mostly for internal use:" { $vocab-subsection "Unicode syntax" "unicode.syntax" } { $vocab-subsection "Unicode data tables" "unicode.data" } -{ $see-also "io.encodings" } ; +{ $see-also "ascii" "io.encodings" } ; ABOUT: "unicode" diff --git a/basis/unix/debugger/debugger.factor b/basis/unix/debugger/debugger.factor index ea32657057..e059e1a184 100644 --- a/basis/unix/debugger/debugger.factor +++ b/basis/unix/debugger/debugger.factor @@ -9,7 +9,7 @@ M: unix-error error. dup message>> write " (" write errno>> pprint ")" print ; M: unix-system-call-error error. - "Unix system call ``" write dup word>> pprint "'' failed:" print + "Unix system call “" write dup word>> pprint "†failed:" print nl dup message>> write " (" write dup errno>> pprint ")" print nl diff --git a/basis/unix/groups/groups-docs.factor b/basis/unix/groups/groups-docs.factor index 07911bc96b..05b22d3413 100644 --- a/basis/unix/groups/groups-docs.factor +++ b/basis/unix/groups/groups-docs.factor @@ -83,7 +83,6 @@ ARTICLE: "unix.groups" "Unix groups" $nl "Listing all groups:" { $subsection all-groups } -"Returning a passwd tuple:" "Real groups:" { $subsection real-group-name } { $subsection real-group-id } diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 6e83ea9a42..22757cdbe1 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -1,6 +1,6 @@ USING: kernel alien.c-types alien.strings sequences math alien.syntax unix vectors kernel namespaces continuations threads assocs vectors -io.backend.unix io.encodings.utf8 unix.utilities ; +io.backend.unix io.encodings.utf8 unix.utilities fry ; IN: unix.process ! Low-level Unix process launching utilities. These are used @@ -36,7 +36,7 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ; [ [ first ] [ ] bi ] dip exec-with-env ; : with-fork ( child parent -- ) - [ [ fork-process dup zero? ] dip [ drop ] prepose ] dip + [ [ fork-process dup zero? ] dip '[ drop @ ] ] dip if ; inline CONSTANT: SIGKILL 9 diff --git a/basis/unix/stat/netbsd/netbsd.factor b/basis/unix/stat/netbsd/netbsd.factor index 6fccd570e3..0bcb886417 100644 --- a/basis/unix/stat/netbsd/netbsd.factor +++ b/basis/unix/stat/netbsd/netbsd.factor @@ -5,3 +5,34 @@ cell-bits { { 32 [ "unix.stat.netbsd.32" require ] } { 64 [ "unix.stat.netbsd.64" require ] } } case + +: _VFS_NAMELEN 32 ; inline +: _VFS_MNAMELEN 1024 ; inline + +C-STRUCT: statvfs + { "ulong" "f_flag" } + { "ulong" "f_bsize" } + { "ulong" "f_frsize" } + { "ulong" "f_iosize" } + { "fsblkcnt_t" "f_blocks" } + { "fsblkcnt_t" "f_bfree" } + { "fsblkcnt_t" "f_bavail" } + { "fsblkcnt_t" "f_bresvd" } + { "fsfilcnt_t" "f_files" } + { "fsfilcnt_t" "f_ffree" } + { "fsfilcnt_t" "f_favail" } + { "fsfilcnt_t" "f_fresvd" } + { "uint64_t" "f_syncreads" } + { "uint64_t" "f_syncwrites" } + { "uint64_t" "f_asyncreads" } + { "uint64_t" "f_asyncwrites" } + { "fsid_t" "f_fsidx" } + { "ulong" "f_fsid" } + { "ulong" "f_namemax" } + { "uid_t" "f_owner" } + { { "uint32_t" 4 } "f_spare" } + { { "char" _VFS_NAMELEN } "f_fstypename" } + { { "char" _VFS_NAMELEN } "f_mntonname" } + { { "char" _VFS_NAMELEN } "f_mntfromname" } ; + +FUNCTION: int statvfs ( char* path, statvfs* buf ) ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index c2b5ad4ea4..42444261e2 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -155,8 +155,8 @@ FUNCTION: int utime ( char* path, utimebuf* buf ) ; : change-file-times ( filename access modification -- ) "utimebuf" - tuck set-utimbuf-modtime - tuck set-utimbuf-actime + [ set-utimbuf-modtime ] keep + [ set-utimbuf-actime ] keep [ utime ] unix-system-call drop ; FUNCTION: int pclose ( void* file ) ; diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor index 2d46ab2d81..faee36d076 100644 --- a/basis/unix/users/users-docs.factor +++ b/basis/unix/users/users-docs.factor @@ -91,7 +91,6 @@ ARTICLE: "unix.users" "Unix users" $nl "Listing all users:" { $subsection all-users } -"Returning a passwd tuple:" "Real user:" { $subsection real-user-name } { $subsection real-user-id } diff --git a/basis/unix/utmpx/utmpx.factor b/basis/unix/utmpx/utmpx.factor index 6b70ceee2e..9f12bc599b 100644 --- a/basis/unix/utmpx/utmpx.factor +++ b/basis/unix/utmpx/utmpx.factor @@ -33,7 +33,7 @@ HOOK: new-utmpx-record os ( -- utmpx-record ) HOOK: utmpx>utmpx-record os ( utmpx -- utmpx-record ) : memory>string ( alien n -- string ) - memory>byte-array utf8 decode [ 0 = ] trim-right ; + memory>byte-array utf8 decode [ 0 = ] trim-tail ; M: unix new-utmpx-record utmpx-record new ; diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index f621384ede..7fed4b5f58 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -18,7 +18,7 @@ IN: urls.encoding : push-utf8 ( ch -- ) 1string utf8 encode - [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + [ CHAR: % , >hex 2 CHAR: 0 pad-head % ] each ; PRIVATE> diff --git a/basis/uuid/uuid.factor b/basis/uuid/uuid.factor index 337ea22df5..2fd6ffdaec 100644 --- a/basis/uuid/uuid.factor +++ b/basis/uuid/uuid.factor @@ -43,7 +43,7 @@ IN: uuid ] dip 76 shift bitor ; : uuid>string ( n -- string ) - >hex 32 CHAR: 0 pad-left + >hex 32 CHAR: 0 pad-head [ CHAR: - 20 ] dip insert-nth [ CHAR: - 16 ] dip insert-nth [ CHAR: - 12 ] dip insert-nth @@ -52,13 +52,10 @@ IN: uuid : string>uuid ( string -- n ) [ CHAR: - = not ] filter 16 base> ; -: uuid>byte-array ( n -- byte-array ) - 16 >be ; - PRIVATE> : uuid-parse ( string -- byte-array ) - string>uuid uuid>byte-array ; + string>uuid 16 >be ; : uuid-unparse ( byte-array -- string ) be> uuid>string ; diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 731efa9b25..d3e823f844 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -792,7 +792,7 @@ LIBRARY: kernel32 ! FUNCTION: AddRefActCtx ! FUNCTION: AddVectoredExceptionHandler ! FUNCTION: AllocateUserPhysicalPages -! FUNCTION: AllocConsole +FUNCTION: BOOL AllocConsole ( ) ; ! FUNCTION: AreFileApisANSI ! FUNCTION: AssignProcessToJobObject ! FUNCTION: AttachConsole @@ -1111,7 +1111,7 @@ FUNCTION: BOOL FindVolumeMountPointClose ( HANDLE hFindVolumeMountPoint ) ; ! FUNCTION: FoldStringW ! FUNCTION: FormatMessageA ! FUNCTION: FormatMessageW -! FUNCTION: FreeConsole +FUNCTION: BOOL FreeConsole ( ) ; ! FUNCTION: FreeEnvironmentStringsA FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ; ALIAS: FreeEnvironmentStrings FreeEnvironmentStringsW @@ -1179,7 +1179,7 @@ ALIAS: GetComputerNameEx GetComputerNameExW ! FUNCTION: GetConsoleSelectionInfo FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ; ALIAS: GetConsoleTitle GetConsoleTitleW -! FUNCTION: GetConsoleWindow +FUNCTION: HWND GetConsoleWindow ( ) ; ! FUNCTION: GetCPFileNameFromRegistry ! FUNCTION: GetCPInfo ! FUNCTION: GetCPInfoExA diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 05a306640d..3d080817bf 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -163,10 +163,10 @@ M: ole32-error error. ] keep ; : (guid-section%) ( guid quot len -- ) - [ call >hex ] dip CHAR: 0 pad-left % ; inline + [ call >hex ] dip CHAR: 0 pad-head % ; inline : (guid-byte%) ( guid byte -- ) - swap nth >hex 2 CHAR: 0 pad-left % ; inline + swap nth >hex 2 CHAR: 0 pad-head % ; inline : guid>string ( guid -- string ) [ diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index 472488ddc2..d3fe0a8447 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -41,7 +41,7 @@ TUPLE: x-clipboard atom contents ; ] if ; : own-selection ( prop win -- ) - dpy get -rot CurrentTime XSetSelectionOwner drop + [ dpy get ] 2dip CurrentTime XSetSelectionOwner drop flush-dpy ; : set-targets-prop ( evt -- ) diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 67ece9d1c7..be9f8cf7a9 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -37,7 +37,7 @@ IN: x11.windows : set-size-hints ( window -- ) "XSizeHints" USPosition over set-XSizeHints-flags - dpy get -rot XSetWMNormalHints ; + [ dpy get ] 2dip XSetWMNormalHints ; : auto-position ( window loc -- ) { 0 0 } = [ drop ] [ set-size-hints ] if ; diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 602fb90172..d9028756f2 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2005, 2006 Daniel Ehrenberg +! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel xml arrays math generic http.client combinators hashtables namespaces io base64 sequences strings calendar xml.data xml.writer xml.utilities assocs math.parser -debugger calendar.format math.order ; +debugger calendar.format math.order xml.literals xml.dispatch ; IN: xml-rpc ! * Sending RPC requests @@ -15,56 +15,70 @@ GENERIC: item>xml ( object -- xml ) M: integer item>xml dup 31 2^ neg 31 2^ 1 - between? [ "Integers must fit in 32 bits" throw ] unless - number>string "i4" build-tag ; + [XML <-> XML] ; UNION: boolean t POSTPONE: f ; M: boolean item>xml - "1" "0" ? "boolean" build-tag ; + "1" "0" ? [XML <-> XML] ; M: float item>xml - number>string "double" build-tag ; + number>string [XML <-> XML] ; -M: string item>xml ! This should change < and & - "string" build-tag ; +M: string item>xml + [XML <-> XML] ; : struct-member ( name value -- tag ) - swap dup string? - [ "Struct member name must be string" throw ] unless - "name" build-tag swap - item>xml "value" build-tag - 2array "member" build-tag* ; + over string? [ "Struct member name must be string" throw ] unless + item>xml + [XML + + <-> + <-> + + XML] ; M: hashtable item>xml [ struct-member ] { } assoc>map - "struct" build-tag* ; + [XML <-> XML] ; M: array item>xml - [ item>xml "value" build-tag ] map - "data" build-tag* "array" build-tag ; + [ item>xml [XML <-> XML] ] map + [XML <-> XML] ; TUPLE: base64 string ; C: base64 M: base64 item>xml - string>> >base64 "base64" build-tag ; + string>> >base64 + [XML <-> XML] ; : params ( seq -- xml ) - [ item>xml "value" build-tag "param" build-tag ] map - "params" build-tag* ; + [ item>xml [XML <-> XML] ] map + [XML <-> XML] ; : method-call ( name seq -- xml ) - params [ "methodName" build-tag ] dip - 2array "methodCall" build-tag* build-xml ; + params + + <-> + <-> + + XML> ; : return-params ( seq -- xml ) - params "methodResponse" build-tag build-xml ; + params <-> XML> ; : return-fault ( fault-code fault-string -- xml ) [ "faultString" set "faultCode" set ] H{ } make-assoc item>xml - "value" build-tag "fault" build-tag "methodResponse" build-tag - build-xml ; + + + <-> + + + XML> ; TUPLE: rpc-method name params ; @@ -162,10 +176,3 @@ TAG: array xml>item : invoke-method ( params method url -- ) [ swap ] dip post-rpc ; - -: put-http-response ( string -- ) - "HTTP/1.1 200 OK\nConnection: close\nContent-Length: " write - dup length number>string write - "\nContent-Type: text/xml\nDate: " write - now timestamp>http-string write "\n\n" write - write ; diff --git a/basis/xml/autoencoding/autoencoding.factor b/basis/xml/autoencoding/autoencoding.factor index 5d7e460862..fe4762acbe 100644 --- a/basis/xml/autoencoding/autoencoding.factor +++ b/basis/xml/autoencoding/autoencoding.factor @@ -2,44 +2,64 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces xml.name io.encodings.utf8 xml.elements io.encodings.utf16 xml.tokenize xml.state math ascii sequences -io.encodings.string io.encodings combinators ; +io.encodings.string io.encodings combinators accessors +xml.data io.encodings.iana ; IN: xml.autoencoding +: decode-stream ( encoding -- ) + spot get [ swap re-decode ] change-stream drop ; + : continue-make-tag ( str -- tag ) parse-name-starting middle-tag end-tag ; : start-utf16le ( -- tag ) - utf16le decode-input-if - CHAR: ? expect - 0 expect check instruct ; + utf16le decode-stream + "?\0" expect + check instruct ; : 10xxxxxx? ( ch -- ? ) -6 shift 3 bitand 2 = ; : start> dup "UTF-16" = + [ drop ] [ name>encoding [ decode-stream ] when* ] if ; + +: instruct-encoding ( instruct/prolog -- ) + dup prolog? + [ prolog-encoding ] + [ drop utf8 decode-stream ] if ; + +: go-utf8 ( -- ) + check utf8 decode-stream next next ; + : start< ( -- tag ) + ! What if first letter of processing instruction is non-ASCII? get-next { { 0 [ next next start-utf16le ] } - { CHAR: ? [ check next next instruct ] } ! XML prolog parsing sets the encoding - { CHAR: ! [ check utf8 decode-input next next direct ] } + { CHAR: ? [ go-utf8 instruct dup instruct-encoding ] } + { CHAR: ! [ go-utf8 direct ] } [ check start, in the case of XML chunks? - } case check ; + [ drop utf8 decode-stream check f ] + } case ; diff --git a/basis/xml/autoencoding/summary.txt b/basis/xml/autoencoding/summary.txt new file mode 100644 index 0000000000..c7517b13d9 --- /dev/null +++ b/basis/xml/autoencoding/summary.txt @@ -0,0 +1 @@ +Implements the automatic detection of encodings of XML documents diff --git a/basis/xml/backend/backend.factor b/basis/xml/backend/backend.factor deleted file mode 100644 index 5dee38695d..0000000000 --- a/basis/xml/backend/backend.factor +++ /dev/null @@ -1,6 +0,0 @@ -! Copyright (C) 2008 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -IN: xml.backend - -! A stack of { tag children } pairs -SYMBOL: xml-stack diff --git a/basis/xml/char-classes/char-classes.factor b/basis/xml/char-classes/char-classes.factor index 03e85e3ea3..d510c8a881 100644 --- a/basis/xml/char-classes/char-classes.factor +++ b/basis/xml/char-classes/char-classes.factor @@ -1,6 +1,7 @@ -! Copyright (C) 2005, 2007 Daniel Ehrenberg +! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences unicode.syntax math math.order combinators ; +USING: kernel sequences unicode.syntax math math.order combinators +hints ; IN: xml.char-classes CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_: ; @@ -26,8 +27,10 @@ CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7: ; ! 1.1: ! [#x1-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF] { - { [ dup HEX: 20 < ] [ "\t\r\n" member? and ] } + { [ dup HEX: 20 < ] [ swap [ "\t\r\n" member? ] [ zero? not ] if ] } { [ nip dup HEX: D800 < ] [ drop t ] } { [ dup HEX: E000 < ] [ drop f ] } [ { HEX: FFFE HEX: FFFF } member? not ] } cond ; + +HINTS: text? { object fixnum } ; diff --git a/basis/xml/char-classes/summary.txt b/basis/xml/char-classes/summary.txt new file mode 100644 index 0000000000..8f70bddc94 --- /dev/null +++ b/basis/xml/char-classes/summary.txt @@ -0,0 +1 @@ +XML-related character classes diff --git a/basis/xml/data/data-docs.factor b/basis/xml/data/data-docs.factor index c5f4f6d670..639ef5591c 100644 --- a/basis/xml/data/data-docs.factor +++ b/basis/xml/data/data-docs.factor @@ -4,7 +4,7 @@ IN: xml.data ABOUT: "xml.data" ARTICLE: "xml.data" "XML data types" -{ $vocab-link "xml.data" } " defines a simple document object model for XML. Everything is simply a tuple and can be manipulated as such." +"The " { $vocab-link "xml.data" } " vocabulary defines a simple document object model for XML. Everything is simply a tuple and can be manipulated as such." { $subsection { "xml.data" "classes" } } { $subsection { "xml.data" "constructors" } } "Simple words for manipulating names:" @@ -13,15 +13,17 @@ ARTICLE: "xml.data" "XML data types" "For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ; ARTICLE: { "xml.data" "classes" } "XML data classes" - "Data types that XML documents are made of:" - { $subsection name } + "XML documents and chunks are made of the following classes:" + { $subsection xml } + { $subsection xml-chunk } { $subsection tag } + { $subsection name } { $subsection contained-tag } { $subsection open-tag } - { $subsection xml } { $subsection prolog } { $subsection comment } { $subsection instruction } + { $subsection unescaped } { $subsection element-decl } { $subsection attlist-decl } { $subsection entity-decl } @@ -32,13 +34,15 @@ ARTICLE: { "xml.data" "classes" } "XML data classes" ARTICLE: { "xml.data" "constructors" } "XML data constructors" "These data types are constructed with:" - { $subsection } - { $subsection } - { $subsection } { $subsection } + { $subsection } + { $subsection } + { $subsection } + { $subsection } { $subsection } { $subsection } { $subsection } + { $subsection } { $subsection } { $subsection } { $subsection } @@ -49,7 +53,7 @@ ARTICLE: { "xml.data" "constructors" } "XML data constructors" { $subsection } ; HELP: tag -{ $class-description "tuple representing an XML tag, delegating to a " { $link +{ $class-description "Tuple representing an XML tag, delegating to a " { $link name } ", containing the slots attrs (an alist of names to strings) and children (a sequence). Tags implement the sequence protocol by acting like a sequence of its chidren, and the assoc protocol by acting like its attributes." } { $see-also name contained-tag xml } ; @@ -58,38 +62,38 @@ HELP: { "attrs" "an alist of names to strings" } { "children" sequence } { "tag" tag } } -{ $description "constructs an XML " { $link tag } " with the name (not a string) and tag attributes specified in attrs and children specified" } +{ $description "Constructs an XML " { $link tag } " with the name (not a string) and tag attributes specified in attrs and children specified." } { $see-also tag } ; HELP: name -{ $class-description "represents an XML name, with the fields space (a string representing the namespace, as written in the document, tag (a string of the actual name of the tag) and url (a string of the URL that the namespace points to)" } +{ $class-description "Represents an XML name, with the fields space (a string representing the namespace, as written in the document, tag (a string of the actual name of the tag) and url (a string of the URL that the namespace points to)." } { $see-also tag } ; HELP: { $values { "space" "a string" } { "main" "a string" } { "url" "a string" } { "name" "an XML tag name" } } -{ $description "creates a name tuple with the name-space space and the tag-name tag and the tag-url url." } +{ $description "Creates a name tuple with the namespace prefix space, the the given main part of the name, and the namespace URL given by url." } { $see-also name } ; HELP: contained-tag -{ $class-description "delegates to tag representing a tag like with no contents. The tag attributes are accessed with tag-attrs" } +{ $class-description "This is a subclass of " { $link tag } " consisting of tags with no body, like " { $snippet "" } "." } { $see-also tag } ; HELP: { $values { "name" "an XML tag name" } { "attrs" "an alist from names to strings" } { "tag" tag } } -{ $description "creates an empty tag (like ) with the specified name and tag attributes. This delegates to tag" } +{ $description "Creates an empty tag (like " { $snippet "" } ") with the specified name and tag attributes." } { $see-also contained-tag } ; HELP: xml -{ $class-description "tuple representing an XML document, delegating to the main tag, containing the fields prolog (the header ), before (whatever comes between the prolog and the main tag) and after (whatever comes after the main tag)" } +{ $class-description "Tuple representing an XML document, delegating to the main tag, containing the fields prolog (the header " { $snippet "" } "), before (whatever comes between the prolog and the main tag) and after (whatever comes after the main tag)." } { $see-also tag prolog } ; HELP: { $values { "prolog" "an XML prolog" } { "before" "a sequence of XML elements" } { "body" tag } { "after" "a sequence of XML elements" } { "xml" "an XML document" } } -{ $description "creates an XML document, delegating to the main tag, with the specified prolog, before, and after" } +{ $description "Creates an XML document. The " { $snippet "before" } " and " { $snippet "after" } " slots store what comes before and after the main tag, and " { $snippet "body" } "contains the main tag itself." } { $see-also xml } ; HELP: prolog @@ -99,47 +103,46 @@ HELP: prolog HELP: { $values { "version" "a string, 1.0 or 1.1" } { "encoding" "a string" } { "standalone" "a boolean" } { "prolog" "an XML prolog" } } -{ $description "creates an XML prolog tuple" } +{ $description "Creates an XML prolog tuple." } { $see-also prolog } ; HELP: comment -{ $class-description "represents a comment in XML. Has one slot, text, which contains the string of the comment" } +{ $class-description "Represents a comment in XML. This tuple has one slot, " { $snippet "text" } ", which contains the string of the comment." } { $see-also } ; HELP: -{ $values { "text" "a string" } { "comment" "a comment" } } -{ $description "creates an XML comment tuple" } +{ $values { "text" string } { "comment" comment } } +{ $description "Creates an XML " { $link comment } " tuple." } { $see-also comment } ; HELP: instruction -{ $class-description "represents an XML instruction, such as . Contains one slot, text, which contains the string between the question marks." } +{ $class-description "Represents an XML instruction, such as " { $snippet "" } ". Contains one slot, " { $snippet "text" } ", which contains the string between the question marks." } { $see-also } ; HELP: { $values { "text" "a string" } { "instruction" "an XML instruction" } } -{ $description "creates an XML parsing instruction, such as ." } +{ $description "Creates an XML parsing instruction, like " { $snippet "" } "." } { $see-also instruction } ; HELP: opener -{ $class-description "describes an opening tag, like . Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." } -{ $see-also closer contained } ; +{ $class-description "Describes an opening tag, like " { $snippet "" } ". Contains two slots, " { $snippet "name" } " and " { $snippet "attrs" } " containing, respectively, the name of the tag and its attributes." } ; HELP: closer -{ $class-description "describes a closing tag, like . Contains one slot, name, containing the tag's name. Usually, the name-url will be f." } -{ $see-also opener contained } ; +{ $class-description "Describes a closing tag, like " { $snippet "" } ". Contains one slot, " { $snippet "name" } ", containing the closer's name." } ; HELP: contained -{ $class-description "represents a self-closing tag, like . Contains two slots, name and attrs containing, respectively, the name of the tag and its attributes. Usually, the name-url will be f." } -{ $see-also opener closer } ; +{ $class-description "Represents a self-closing tag, like " { $snippet "" } ". Contains two slots," { $snippet "name" } " and " { $snippet "attrs" } " containing, respectively, the name of the tag and its attributes." } ; + +{ opener closer contained } related-words HELP: open-tag -{ $class-description "represents a tag that does have children, ie is not a contained tag" } -{ $notes "the constructor used for this class is simply " { $link } "." } +{ $class-description "Represents a tag that does have children, ie. is not a contained tag" } +{ $notes "The constructor used for this class is simply " { $link } "." } { $see-also tag contained-tag } ; HELP: names-match? { $values { "name1" "a name" } { "name2" "a name" } { "?" "t or f" } } -{ $description "checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." } +{ $description "Checks to see if the two names match, that is, if all fields are equal, ignoring fields whose value is f in either name." } { $example "USING: prettyprint xml.data ;" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" } { $see-also name } ; @@ -150,3 +153,66 @@ HELP: assure-name HELP: { $values { "string" string } { "name" name } } { $description "Converts a string into an XML name with an empty prefix and URL." } ; + +HELP: element-decl +{ $class-description "Describes the class of element declarations, like ." } ; + +HELP: +{ $values { "name" name } { "content-spec" string } { "element-decl" entity-decl } } +{ $description "Creates an element declaration object, of the class " { $link element-decl } } ; + +HELP: attlist-decl +{ $class-description "Describes the class of element declarations, like " { $snippet "" } "." } ; + +HELP: +{ $values { "name" name } { "att-defs" string } { "attlist-decl" attlist-decl } } +{ $description "Creates an element declaration object, of the class " { $link attlist-decl } } ; + +HELP: entity-decl +{ $class-description "Describes the class of element declarations, like " { $snippet "" } "." } ; + +HELP: +{ $values { "name" name } { "def" string } { "pe?" "t or f" } { "entity-decl" entity-decl } } +{ $description "Creates an entity declaration object, of the class " { $link entity-decl } ". The pe? slot should be t if the object is a DTD-internal entity, like " { $snippet "" } " and f if the object is like " { $snippet "" } ", that is, it can be used outside of the DTD." } ; + +HELP: system-id +{ $class-description "Describes the class of system identifiers within an XML DTD directive, such as " { $snippet "" } "." } ; + +HELP: +{ $values { "system-literal" string } { "system-id" system-id } } +{ $description "Constructs a " { $link system-id } " tuple." } ; + +HELP: public-id +{ $class-description "Describes the class of public identifiers within an XML DTD directive, such as " { $snippet "" } } ; + +HELP: +{ $values { "pubid-literal" string } { "system-literal" string } { "public-id" public-id } } +{ $description "Constructs a " { $link system-id } " tuple." } ; + +HELP: notation-decl +{ $class-description "Describes the class of element declarations, like " { $snippet "" } "." } ; + +HELP: +{ $values { "name" string } { "id" id } { "notation-decl" notation-decl } } +{ $description "Creates an notation declaration object, of the class " { $link notation-decl } "." } ; + +HELP: doctype-decl +{ $class-description "Describes the class of doctype declarations." } ; + +HELP: +{ $values { "name" name } { "external-id" id } { "internal-subset" sequence } { "doctype-decl" doctype-decl } } +{ $description "Creates a new doctype declaration object, of the class " { $link doctype-decl } ". Only one of external-id or internal-subset will be non-null." } ; + +HELP: unescaped +{ $class-description "When constructing XML documents to write to output, it can be useful to splice in a string which is already written. This tuple type allows for that. Printing an " { $snippet "unescaped" } " is the same is printing its " { $snippet "string" } " slot." } ; + +HELP: +{ $values { "string" string } { "unescaped" unescaped } } +{ $description "Constructs an " { $link unescaped } " tuple, given a string." } ; + +HELP: xml-chunk +{ $class-description "Encapsulates a balanced fragment of an XML document. This is a sequence (following the sequence protocol) of XML data types, eg " { $link string } "s and " { $link tag } "s." } ; + +HELP: +{ $values { "seq" sequence } { "xml-chunk" xml-chunk } } +{ $description "Constructs an " { $link xml-chunk } " tuple, given a sequence to be its contents." } ; diff --git a/basis/xml/data/data.factor b/basis/xml/data/data.factor index 68e91743d3..6cd975d42d 100644 --- a/basis/xml/data/data.factor +++ b/basis/xml/data/data.factor @@ -1,11 +1,19 @@ -! Copyright (C) 2005, 2006 Daniel Ehrenberg +! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private assocs arrays delegate.protocols delegate vectors accessors multiline -macros words quotations combinators slots fry ; +macros words quotations combinators slots fry strings ; IN: xml.data -TUPLE: name space main url ; +TUPLE: interpolated var ; +C: interpolated + +UNION: nullable-string string POSTPONE: f ; + +TUPLE: name + { space nullable-string } + { main string } + { url nullable-string } ; C: name : ?= ( object/f object/f -- ? ) @@ -25,48 +33,7 @@ C: name : assure-name ( string/name -- name ) dup name? [ ] unless ; -TUPLE: opener name attrs ; -C: opener - -TUPLE: closer name ; -C: closer - -TUPLE: contained name attrs ; -C: contained - -TUPLE: comment text ; -C: comment - -TUPLE: directive ; - -TUPLE: element-decl < directive name content-spec ; -C: element-decl - -TUPLE: attlist-decl < directive name att-defs ; -C: attlist-decl - -TUPLE: entity-decl < directive name def pe? ; -C: entity-decl - -TUPLE: system-id system-literal ; -C: system-id - -TUPLE: public-id pubid-literal system-literal ; -C: public-id - -TUPLE: doctype-decl < directive name external-id internal-subset ; -C: doctype-decl - -TUPLE: notation-decl < directive name id ; -C: notation-decl - -TUPLE: instruction text ; -C: instruction - -TUPLE: prolog version encoding standalone ; -C: prolog - -TUPLE: attrs alist ; +TUPLE: attrs { alist sequence } ; C: attrs : attr@ ( key alist -- index {key,value} ) @@ -98,22 +65,96 @@ M: attrs assoc-like M: attrs clear-assoc f >>alist drop ; M: attrs delete-at - tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ; + [ nip ] [ attr@ drop ] 2bi + [ swap alist>> delete-nth ] [ drop ] if* ; M: attrs clone alist>> clone ; INSTANCE: attrs assoc -TUPLE: tag name attrs children ; +TUPLE: opener { name name } { attrs attrs } ; +C: opener + +TUPLE: closer { name name } ; +C: closer + +TUPLE: contained { name name } { attrs attrs } ; +C: contained + +TUPLE: comment { text string } ; +C: comment + +TUPLE: directive ; + +TUPLE: element-decl < directive + { name string } + { content-spec string } ; +C: element-decl + +TUPLE: attlist-decl < directive + { name string } + { att-defs string } ; +C: attlist-decl + +UNION: boolean t POSTPONE: f ; + +TUPLE: entity-decl < directive + { name string } + { def string } + { pe? boolean } ; +C: entity-decl + +TUPLE: system-id { system-literal string } ; +C: system-id + +TUPLE: public-id { pubid-literal string } { system-literal string } ; +C: public-id + +UNION: id system-id public-id POSTPONE: f ; + +TUPLE: dtd + { directives sequence } + { entities assoc } + { parameter-entities assoc } ; +C: dtd + +UNION: dtd/f dtd POSTPONE: f ; + +TUPLE: doctype-decl < directive + { name string } + { external-id id } + { internal-subset dtd/f } ; +C: doctype-decl + +TUPLE: notation-decl < directive + { name string } + { id string } ; +C: notation-decl + +TUPLE: instruction { text string } ; +C: instruction + +TUPLE: prolog + { version string } + { encoding string } + { standalone boolean } ; +C: prolog + +TUPLE: tag + { name name } + { attrs attrs } + { children sequence } ; : ( name attrs children -- tag ) [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri* tag boa ; -! For convenience, tags follow the assoc protocol too (for attrs) -CONSULT: assoc-protocol tag attrs>> ; -INSTANCE: tag assoc +: attr ( tag/xml name -- string ) + swap attrs>> at ; + +: set-attr ( tag/xml value name -- ) + rot attrs>> set-at ; ! They also follow the sequence protocol (for children) CONSULT: sequence-protocol tag children>> ; @@ -137,15 +178,16 @@ MACRO: clone-slots ( class -- tuple ) M: tag clone tag clone-slots ; -TUPLE: xml prolog before body after ; +TUPLE: xml + { prolog prolog } + { before sequence } + { body tag } + { after sequence } ; C: xml CONSULT: sequence-protocol xml body>> ; INSTANCE: xml sequence -CONSULT: assoc-protocol xml body>> ; -INSTANCE: xml assoc - CONSULT: tag xml body>> ; CONSULT: name xml body>> ; @@ -173,3 +215,15 @@ M: xml like PREDICATE: contained-tag < tag children>> not ; PREDICATE: open-tag < tag children>> ; + +TUPLE: unescaped string ; +C: unescaped + +UNION: xml-data + tag comment string directive instruction unescaped ; + +TUPLE: xml-chunk seq ; +C: xml-chunk + +CONSULT: sequence-protocol xml-chunk seq>> ; +INSTANCE: xml-chunk sequence diff --git a/basis/xml/data/summary.txt b/basis/xml/data/summary.txt new file mode 100644 index 0000000000..d8f0f0dc0a --- /dev/null +++ b/basis/xml/data/summary.txt @@ -0,0 +1 @@ +Contains XML data types and basic tools for manipulation diff --git a/basis/xml/data/tags.txt b/basis/xml/data/tags.txt new file mode 100644 index 0000000000..2a501370ae --- /dev/null +++ b/basis/xml/data/tags.txt @@ -0,0 +1,2 @@ +collections +assocs diff --git a/core/io/encodings/binary/authors.txt b/basis/xml/dispatch/authors.txt similarity index 100% rename from core/io/encodings/binary/authors.txt rename to basis/xml/dispatch/authors.txt diff --git a/basis/xml/dispatch/dispatch-docs.factor b/basis/xml/dispatch/dispatch-docs.factor new file mode 100644 index 0000000000..572a75cd05 --- /dev/null +++ b/basis/xml/dispatch/dispatch-docs.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax ; +IN: xml.dispatch + +ABOUT: "xml.dispatch" + +ARTICLE: "xml.dispatch" "Dispatch on XML tag names" +"Two parsing words define a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" +{ $subsection POSTPONE: PROCESS: } +"and to define a new 'method' for this word, use" +{ $subsection POSTPONE: TAG: } ; + +HELP: PROCESS: +{ $syntax "PROCESS: word" } +{ $values { "word" "a new word to define" } } +{ $description "creates a new word to process XML tags" } +{ $see-also POSTPONE: TAG: } ; + +HELP: TAG: +{ $syntax "TAG: tag word definition... ;" } +{ $values { "tag" "an xml tag name" } { "word" "an XML process" } } +{ $description "defines what a process should do when it encounters a specific tag" } +{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } +{ $see-also POSTPONE: PROCESS: } ; diff --git a/basis/xml/tests/arithmetic.factor b/basis/xml/dispatch/dispatch-tests.factor similarity index 80% rename from basis/xml/tests/arithmetic.factor rename to basis/xml/dispatch/dispatch-tests.factor index 98facfcac2..6f3179bc02 100644 --- a/basis/xml/tests/arithmetic.factor +++ b/basis/xml/dispatch/dispatch-tests.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2005, 2006 Daniel Ehrenberg +! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -IN: xml.tests -USING: xml io kernel math sequences strings xml.utilities tools.test math.parser ; +USING: xml io kernel math sequences strings xml.utilities +tools.test math.parser xml.dispatch ; +IN: xml.dispatch.tests PROCESS: calculate ( tag -- n ) diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor new file mode 100644 index 0000000000..23cb43cc47 --- /dev/null +++ b/basis/xml/dispatch/dispatch.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: words assocs kernel accessors parser sequences summary +lexer splitting fry ; +IN: xml.dispatch + +TUPLE: process-missing process tag ; +M: process-missing summary + drop "Tag not implemented on process" ; + +: run-process ( tag word -- ) + 2dup "xtable" word-prop + [ dup main>> ] dip at* [ 2nip call ] [ + drop \ process-missing boa throw + ] if ; + +: PROCESS: + CREATE + dup H{ } clone "xtable" set-word-prop + dup '[ _ run-process ] define ; parsing + +: TAG: + scan scan-word + parse-definition + swap "xtable" word-prop + rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ; + parsing diff --git a/basis/xml/dispatch/summary.txt b/basis/xml/dispatch/summary.txt new file mode 100644 index 0000000000..6751e55e63 --- /dev/null +++ b/basis/xml/dispatch/summary.txt @@ -0,0 +1 @@ +'Generic words' that dispatch on XML tag names diff --git a/basis/xml/dispatch/tags.txt b/basis/xml/dispatch/tags.txt new file mode 100644 index 0000000000..71c0ff7282 --- /dev/null +++ b/basis/xml/dispatch/tags.txt @@ -0,0 +1 @@ +syntax diff --git a/basis/xml/dtd/dtd.factor b/basis/xml/dtd/dtd.factor index a1b90a60d7..50de78ec11 100644 --- a/basis/xml/dtd/dtd.factor +++ b/basis/xml/dtd/dtd.factor @@ -2,12 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: xml.tokenize xml.data xml.state kernel sequences ascii fry xml.errors combinators hashtables namespaces xml.entities -strings ; +strings xml.name ; IN: xml.dtd -: take-word ( -- string ) - [ get-char blank? ] take-until ; - : take-decl-contents ( -- first second ) pass-blank take-word pass-blank ">" take-string ; @@ -20,36 +17,15 @@ IN: xml.dtd : take-notation-decl ( -- notation-decl ) take-decl-contents ; -: take-until-one-of ( seps -- str sep ) - '[ get-char _ member? ] take-until get-char ; - -: take-system-id ( -- system-id ) - parse-quote close ; - -: take-public-id ( -- public-id ) - parse-quote parse-quote close ; - UNION: dtd-acceptable directive comment instruction ; -: (take-external-id) ( token -- external-id ) - pass-blank { - { "SYSTEM" [ take-system-id ] } - { "PUBLIC" [ take-public-id ] } - [ bad-external-id ] - } case ; - -: take-external-id ( -- external-id ) - take-word (take-external-id) ; - -: only-blanks ( str -- ) - [ blank? ] all? [ bad-decl ] unless ; : take-entity-def ( var -- entity-name entity-def ) [ take-word pass-blank get-char { { CHAR: ' [ parse-quote ] } { CHAR: " [ parse-quote ] } - [ drop take-external-id ] + [ drop take-external-id close ] } case ] dip '[ swap _ [ ?set-at ] change ] 2keep ; @@ -57,5 +33,13 @@ UNION: dtd-acceptable pass-blank get-char { { CHAR: % [ next pass-blank pe-table take-entity-def t ] } [ drop extra-entities take-entity-def f ] - } case - close ; + } case close ; + +: take-inner-directive ( string -- directive ) + { + { "ELEMENT" [ take-element-decl ] } + { "ATTLIST" [ take-attlist-decl ] } + { "ENTITY" [ take-entity-decl ] } + { "NOTATION" [ take-notation-decl ] } + [ bad-directive ] + } case ; diff --git a/basis/xml/dtd/summary.txt b/basis/xml/dtd/summary.txt new file mode 100644 index 0000000000..8b0745fcf4 --- /dev/null +++ b/basis/xml/dtd/summary.txt @@ -0,0 +1 @@ +Implements the parsing of directives in DTDs diff --git a/basis/xml/elements/elements.factor b/basis/xml/elements/elements.factor index 65b8b66536..b927947329 100644 --- a/basis/xml/elements/elements.factor +++ b/basis/xml/elements/elements.factor @@ -3,12 +3,25 @@ USING: kernel namespaces xml.tokenize xml.state xml.name xml.data accessors arrays make xml.char-classes fry assocs sequences math xml.errors sets combinators io.encodings io.encodings.iana -unicode.case xml.dtd strings ; +unicode.case xml.dtd strings xml.entities unicode.categories ; IN: xml.elements +: take-interpolated ( quot -- interpolated ) + interpolating? get [ + drop get-char CHAR: > = + [ next f ] + [ "->" take-string [ blank? ] trim ] + if + ] [ call ] if ; inline + +: interpolate-quote ( -- interpolated ) + [ quoteless-attr ] take-interpolated ; + : parse-attr ( -- ) - parse-name pass-blank CHAR: = expect pass-blank - t parse-quote* 2array , ; + parse-name pass-blank "=" expect pass-blank + get-char CHAR: < = + [ "<-" expect interpolate-quote ] + [ t parse-quote* ] if 2array , ; : start-tag ( -- name ? ) #! Outputs the name and whether this is a closing tag @@ -16,7 +29,7 @@ IN: xml.elements parse-name swap ; : (middle-tag) ( -- ) - pass-blank version=1.0? get-char name-start? + pass-blank version-1.0? get-char name-start? [ parse-attr (middle-tag) ] when ; : assure-no-duplicates ( attrs-alist -- attrs-alist ) @@ -31,14 +44,14 @@ IN: xml.elements : end-tag ( name attrs-alist -- tag ) tag-ns pass-blank get-char CHAR: / = - [ pop-ns next CHAR: > expect ] + [ pop-ns next ">" expect ] [ depth inc close ] if ; : take-comment ( -- comment ) - "--" expect-string + "--" expect "--" take-string - CHAR: > expect ; + ">" expect ; : assure-no-extra ( seq -- ) [ first ] map { @@ -52,11 +65,13 @@ IN: xml.elements dup { "1.0" "1.1" } member? [ bad-version ] unless ; : prolog-version ( alist -- version ) - T{ name f "" "version" f } swap at - [ good-version ] [ versionless-prolog ] if* ; + T{ name { space "" } { main "version" } } swap at + [ good-version ] [ versionless-prolog ] if* + dup set-version ; : prolog-encoding ( alist -- encoding ) - T{ name f "" "encoding" f } swap at "UTF-8" or ; + T{ name { space "" } { main "encoding" } } swap at + "UTF-8" or ; : yes/no>bool ( string -- t/f ) { @@ -66,7 +81,7 @@ IN: xml.elements } case ; : prolog-standalone ( alist -- version ) - T{ name f "" "standalone" f } swap at + T{ name { space "" } { main "standalone" } } swap at [ yes/no>bool ] [ f ] if* ; : prolog-attrs ( alist -- prolog ) @@ -75,16 +90,9 @@ IN: xml.elements [ prolog-standalone ] tri ; -SYMBOL: string-input? -: decode-input-if ( encoding -- ) - string-input? get [ drop ] [ decode-input ] if ; - : parse-prolog ( -- prolog ) - pass-blank middle-tag "?>" expect-string - dup assure-no-extra prolog-attrs - dup encoding>> dup "UTF-16" = - [ drop ] [ name>encoding [ decode-input-if ] when* ] if - dup prolog-data set ; + pass-blank middle-tag "?>" expect + dup assure-no-extra prolog-attrs ; : instruct ( -- instruction ) take-name { @@ -96,56 +104,53 @@ SYMBOL: string-input? : take-cdata ( -- string ) depth get zero? [ bad-cdata ] when - "[CDATA[" expect-string "]]>" take-string ; + "[CDATA[" expect "]]>" take-string ; DEFER: make-tag ! Is this unavoidable? : expand-pe ( -- ) ; ! Make this run the contents of the pe within a DOCTYPE -: (take-internal-subset) ( -- ) +: dtd-loop ( -- ) pass-blank get-char { { CHAR: ] [ next ] } { CHAR: % [ expand-pe ] } { CHAR: < [ next make-tag dup dtd-acceptable? - [ bad-doctype ] unless , (take-internal-subset) + [ bad-doctype ] unless , dtd-loop ] } + { f [ ] } [ 1string bad-doctype ] } case ; -: take-internal-subset ( -- seq ) +: take-internal-subset ( -- dtd ) [ - H{ } pe-table set + H{ } clone pe-table set t in-dtd? set - (take-internal-subset) - ] { } make ; + dtd-loop + pe-table get + ] { } make swap extra-entities get swap ; -: nontrivial-doctype ( -- external-id internal-subset ) - pass-blank get-char CHAR: [ = [ - next take-internal-subset f swap close - ] [ - " >" take-until-one-of { - { CHAR: \s [ (take-external-id) ] } - { CHAR: > [ only-blanks f ] } - } case f - ] if ; +: take-optional-id ( -- id/f ) + get-char "SP" member? + [ take-external-id ] [ f ] if ; + +: take-internal ( -- dtd/f ) + get-char CHAR: [ = + [ next take-internal-subset ] [ f ] if ; : take-doctype-decl ( -- doctype-decl ) - pass-blank " >" take-until-one-of { - { CHAR: \s [ nontrivial-doctype ] } - { CHAR: > [ f f ] } - } case ; + pass-blank take-name + pass-blank take-optional-id + pass-blank take-internal + close ; - -: take-directive ( -- directive ) - take-name { - { "ELEMENT" [ take-element-decl ] } - { "ATTLIST" [ take-attlist-decl ] } - { "DOCTYPE" [ take-doctype-decl ] } - { "ENTITY" [ take-entity-decl ] } - { "NOTATION" [ take-notation-decl ] } - [ bad-directive ] - } case ; +: take-directive ( -- doctype ) + take-name dup "DOCTYPE" = + [ drop take-doctype-decl ] [ + in-dtd? get + [ take-inner-directive ] + [ misplaced-directive ] if + ] if ; : direct ( -- object ) get-char { @@ -154,12 +159,18 @@ DEFER: make-tag ! Is this unavoidable? [ drop take-directive ] } case ; +: normal-tag ( -- tag ) + start-tag + [ dup add-ns pop-ns depth dec close ] + [ middle-tag end-tag ] if ; + +: interpolate-tag ( -- interpolated ) + [ "-" bad-name ] take-interpolated ; + : make-tag ( -- tag ) { { [ get-char dup CHAR: ! = ] [ drop next direct ] } - { [ CHAR: ? = ] [ next instruct ] } - [ - start-tag [ dup add-ns pop-ns depth dec close ] - [ middle-tag end-tag ] if - ] + { [ dup CHAR: ? = ] [ drop next instruct ] } + { [ dup CHAR: - = ] [ drop next interpolate-tag ] } + [ drop normal-tag ] } cond ; diff --git a/basis/xml/elements/summary.txt b/basis/xml/elements/summary.txt new file mode 100644 index 0000000000..c85b023211 --- /dev/null +++ b/basis/xml/elements/summary.txt @@ -0,0 +1 @@ +Implements the parsing of XML tags diff --git a/basis/xml/entities/entities-docs.factor b/basis/xml/entities/entities-docs.factor index ab105300e1..2fccb500a4 100644 --- a/basis/xml/entities/entities-docs.factor +++ b/basis/xml/entities/entities-docs.factor @@ -12,11 +12,10 @@ ARTICLE: "xml.entities" "XML entities" "For entities used in HTML/XHTML, see " { $vocab-link "xml.entities.html" } ; HELP: entities -{ $description "a hash table from default XML entity names (like & and <) to the characters they represent. This is automatically included when parsing any XML document." } +{ $description "A hash table from default XML entity names (like " { $snippet "&" } " and " { $snippet "<" } ") to the characters they represent. This is automatically included when parsing any XML document." } { $see-also with-entities } ; HELP: with-entities -{ $values { "entities" "a hash table of strings to chars" } - { "quot" "a quotation ( -- )" } } -{ $description "calls the quotation using the given table of entity values (symbolizing, eg, that &foo; represents CHAR: a) on top of the default XML entities" } ; +{ $values { "entities" "a hash table of strings to strings" } { "quot" "a quotation ( -- )" } } +{ $description "Calls the quotation using the given table of entity values (symbolizing, eg, that " { $snippet "&foo;" } " represents " { $snippet "\"a\"" } ") on top of the default XML entities" } ; diff --git a/basis/xml/entities/entities.factor b/basis/xml/entities/entities.factor index a3812c7723..3e768b1b88 100644 --- a/basis/xml/entities/entities.factor +++ b/basis/xml/entities/entities.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make kernel assocs sequences fry values -io.files io.encodings.binary ; +io.files io.encodings.binary xml.state ; IN: xml.entities : entities-out @@ -16,6 +16,7 @@ IN: xml.entities { CHAR: & "&" } { CHAR: ' "'" } { CHAR: " """ } + { CHAR: < "<" } } ; : escape-string-by ( str table -- escaped ) @@ -37,7 +38,5 @@ IN: xml.entities { "quot" CHAR: " } } ; -SYMBOL: extra-entities - : with-entities ( entities quot -- ) [ swap extra-entities set call ] with-scope ; inline diff --git a/basis/xml/entities/html/html-docs.factor b/basis/xml/entities/html/html-docs.factor index 2e1b67a100..f436944954 100644 --- a/basis/xml/entities/html/html-docs.factor +++ b/basis/xml/entities/html/html-docs.factor @@ -5,14 +5,14 @@ IN: xml.entities.html ARTICLE: "xml.entities.html" "HTML entities" { $vocab-link "xml.entities.html" } " defines words for using entities defined in HTML/XHTML." - { $subsection html-entities } - { $subsection with-html-entities } ; +{ $subsection html-entities } +{ $subsection with-html-entities } ; HELP: html-entities -{ $description "a hash table from HTML entity names to their character values" } +{ $description "A hash table from HTML entity names to their character values." } { $see-also entities with-html-entities } ; HELP: with-html-entities { $values { "quot" "a quotation ( -- )" } } -{ $description "calls the given quotation using HTML entity values" } +{ $description "Calls the given quotation using HTML entity values." } { $see-also html-entities with-entities } ; diff --git a/basis/xml/entities/html/html.factor b/basis/xml/entities/html/html.factor index 601b95a596..f1e52319f1 100644 --- a/basis/xml/entities/html/html.factor +++ b/basis/xml/entities/html/html.factor @@ -1,16 +1,13 @@ ! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: assocs io.encodings.binary io.files kernel namespaces sequences -values xml xml.entities ; +values xml xml.entities accessors xml.state ; IN: xml.entities.html VALUE: html-entities : read-entities-file ( file -- table ) - H{ } clone [ extra-entities [ - binary - [ drop ] sax - ] with-variable ] keep ; + file>dtd entities>> ; : get-html ( -- table ) { "lat1" "special" "symbol" } [ diff --git a/basis/xml/entities/summary.txt b/basis/xml/entities/summary.txt new file mode 100644 index 0000000000..4ff3e75e6c --- /dev/null +++ b/basis/xml/entities/summary.txt @@ -0,0 +1 @@ +Contains built-in XML entities diff --git a/basis/xml/errors/errors-docs.factor b/basis/xml/errors/errors-docs.factor index b95aecc47a..01a943eab7 100644 --- a/basis/xml/errors/errors-docs.factor +++ b/basis/xml/errors/errors-docs.factor @@ -3,51 +3,95 @@ USING: help.markup help.syntax ; IN: xml.errors + + HELP: multitags -{ $class-description "XML parsing error describing the case where there is more than one main tag in a document. Contains no slots" } ; +{ $class-description "XML parsing error describing the case where there is more than one main tag in a document." } +{ $xml-error "\n" } ; HELP: notags -{ $class-description "XML parsing error describing the case where an XML document contains no main tag, or any tags at all" } ; +{ $class-description "XML parsing error describing the case where an XML document contains no main tag, or any tags at all" } +{ $xml-error "" } ; HELP: extra-attrs -{ $class-description "XML parsing error describing the case where the XML prolog () contains attributes other than the three allowed ones, standalone, version and encoding. Contains one slot, attrs, which is a hashtable of all the extra attributes' names. Delegates to " { $link parsing-error } "." } ; +{ $class-description "XML parsing error describing the case where the XML prolog (" { $snippet "" } ") contains attributes other than the three allowed ones, " { $snippet "standalone" } ", " { $snippet "version" } " and " { $snippet "encoding" } ". Contains one slot, " { $snippet "attrs" } ", which is a hashtable of all the extra attributes' names. This is a subclass of " { $link xml-error-at } "." } +{ $xml-error "\n" } ; HELP: nonexist-ns -{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, name, which contains the name of the undeclared namespace, and delegates to " { $link parsing-error } "." } ; +{ $class-description "XML parsing error describing the case where a namespace doesn't exist but it is used in a tag. Contains one slot, " { $snippet "name" } ", which contains the name of the undeclared namespace, and is a subclass of " { $link xml-error-at } "." } +{ $xml-error "c" } ; HELP: not-yes/no -{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than 'yes' or 'no'. Delegates to " { $link parsing-error } " and contains one slot, text, which contains offending value." } ; +{ $class-description "XML parsing error used to describe the case where standalone is set in the XML prolog to something other than " { $snippet "yes" } " or " { $snippet "no" } ". This is a subclass of " { $link xml-error-at } " and contains one slot, text, which contains offending value." } +{ $xml-error "\n" } ; HELP: unclosed -{ $class-description "XML parsing error used to describe the case where the XML document contains classes which are not closed by the end of the document. Contains one slot, tags, a sequence of names." } ; +{ $class-description "XML parsing error used to describe the case where the XML document contains classes which are not closed by the end of the document. Contains one slot, " { $snippet "tags" } ", a sequence of names." } +{ $xml-error "some text" } ; HELP: mismatched -{ $class-description "XML parsing error describing mismatched tags, eg . Contains two slots: open is the name of the opening tag and close is the name of the closing tag. Delegates to " { $link parsing-error } " showing the location of the closing tag" } ; +{ $class-description "XML parsing error describing mismatched tags. Contains two slots: " { $snippet "open" } " is the name of the opening tag and " { $snippet "close" } " is the name of the closing tag. This is a subclass of " { $link xml-error-at } " showing the location of the closing tag" } +{ $xml-error "" } ; HELP: expected -{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link parsing-error } ". Contains two slots, should-be, which has the expected string, and was, which has the actual string." } ; +{ $class-description "XML parsing error describing when an expected token was not present. Delegates to " { $link xml-error-at } ". Contains two slots, " { $snippet "should-be" } ", which has the expected string, and " { $snippet "was" } ", which has the actual string." } ; HELP: no-entity -{ $class-description "XML parsing error describing the use of an undefined entity in a case where standalone is marked yes. Delegates to " { $link parsing-error } ". Contains one slot, thing, containing a string representing the entity." } ; +{ $class-description "XML parsing error describing the use of an undefined entity. This is a subclass of " { $link xml-error-at } ". Contains one slot, thing, containing a string representing the entity." } +{ $xml-error "&foo;" } ; HELP: pre/post-content -{ $class-description "describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: string contains the offending string, and pre? is t if it occured before the main tag and f if it occured after" } ; - -HELP: unclosed-quote -{ $class-description "describes the error where a quotation for an attribute value is opened but not closed before the end of the document." } ; +{ $class-description "Describes the error where a non-whitespace string is used before or after the main tag in an XML document. Contains two slots: " { $snippet "string" } " contains the offending string, and " { $snippet "pre?" } " is " { $snippet "t" } " if it occured before the main tag and " { $snippet "f" } " if it occured after." } +{ $xml-error "hello\n" } ; HELP: bad-name -{ $class-description "describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } ; +{ $class-description "Describes the error where a name is used, for example in an XML tag or attribute key, which is invalid." } +{ $xml-error "<%>\n" } ; HELP: quoteless-attr -{ $class-description "describes the error where an attribute of an XML tag is missing quotes around a value." } ; +{ $class-description "Describes the error where an attribute of an XML tag is missing quotes around a value." } +{ $xml-error "" } ; -HELP: xml-parse-error -{ $class-description "the exception class that all parsing errors in XML documents are in." } ; +HELP: disallowed-char +{ $class-description "Describes the error where a disallowed character occurs in an XML document." } ; + +HELP: missing-close +{ $class-description "Describes the error where a particular closing token is missing." } ; + +HELP: unexpected-end +{ $class-description "Describes the error where a document unexpectedly ends, and the XML parser expected it to continue." } ; + +HELP: duplicate-attr +{ $class-description "Describes the error where there is more than one attribute of the same key." } +{ $xml-error "" } ; + +HELP: bad-cdata +{ $class-description "Describes the error where CDATA is used outside of the main tag of an XML document." } +{ $xml-error "y\n" } ; + +HELP: text-w/]]> +{ $class-description "Describes the error where a text node contains the literal string " { $snippet "]]>" } " which is disallowed." } +{ $xml-error "Here's some text: ]]> there it was" } ; + +HELP: attr-w/< +{ $class-description "Describes the error where an attribute value contains the literal character " { $snippet "<" } " which is disallowed." } +{ $xml-error "" } ; + +HELP: misplaced-directive +{ $class-description "Describes the error where an internal DTD directive is used outside of a DOCTYPE or DTD file, or where a DOCTYPE occurs somewhere other than before the main tag of an XML document." } +{ $xml-error "" } ; + +HELP: xml-error +{ $class-description "The exception class that all parsing errors in XML documents are in." } ; ARTICLE: "xml.errors" "XML parsing errors" - { $vocab-link "xml.errors" } " provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-parse-error } " but there are many classes contained in that:" +"The " { $vocab-link "xml.errors" } " vocabulary provides a rich and highly inspectable set of parsing errors. All XML errors are described by the union class " { $link xml-error } "." { $subsection multitags } { $subsection notags } { $subsection extra-attrs } @@ -61,7 +105,15 @@ ARTICLE: "xml.errors" "XML parsing errors" { $subsection unclosed-quote } { $subsection bad-name } { $subsection quoteless-attr } - "Additionally, most of these errors are a kind of " { $link parsing-error } " which provides more information" + { $subsection disallowed-char } + { $subsection missing-close } + { $subsection unexpected-end } + { $subsection duplicate-attr } + { $subsection bad-cdata } + { $subsection text-w/]]> } + { $subsection attr-w/< } + { $subsection misplaced-directive } + "Additionally, most of these errors are a kind of " { $link xml-error-at } " which provides more information about where the error occurred." $nl "Note that, in parsing an XML document, only the first error is reported." ; diff --git a/basis/xml/errors/errors-tests.factor b/basis/xml/errors/errors-tests.factor index bf02f4b6ca..8a469bc08f 100644 --- a/basis/xml/errors/errors-tests.factor +++ b/basis/xml/errors/errors-tests.factor @@ -6,11 +6,11 @@ IN: xml.errors.tests '[ _ string>xml ] swap '[ _ = ] must-fail-with ; T{ no-entity f 1 10 "nbsp" } " " xml-error-test -T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" } } +T{ mismatched f 1 7 T{ name f "" "x" "" } T{ name f "" "y" "" } } "" xml-error-test -T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "" xml-error-test +T{ unclosed f 1 3 V{ T{ name f "" "x" "" } } } "" xml-error-test T{ nonexist-ns f 1 5 "x" } "" xml-error-test -T{ unopened f 1 5 } "" xml-error-test +T{ unopened f 1 4 } "" xml-error-test T{ not-yes/no f 1 41 "maybe" } "" xml-error-test T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } } @@ -19,20 +19,24 @@ T{ bad-version f 1 28 "5 million" } "" xml-error-test T{ notags f } "" xml-error-test T{ multitags } "" xml-error-test -T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f } } +T{ bad-prolog f 1 25 T{ prolog f "1.0" "UTF-8" f } } "" xml-error-test T{ capitalized-prolog f 1 6 "XmL" } "" xml-error-test T{ pre/post-content f "x" t } "x" xml-error-test T{ versionless-prolog f 1 8 } "" xml-error-test -T{ unclosed-quote f 1 13 } "" xml-error-test T{ bad-name f 1 3 "-" } "<-/>" xml-error-test +T{ quoteless-attr f 1 12 } "/>" xml-error-test T{ quoteless-attr f 1 10 } "" xml-error-test T{ attr-w/< f 1 11 } "" xml-error-test T{ text-w/]]> f 1 6 } "]]>" xml-error-test T{ duplicate-attr f 1 21 T{ name { space "" } { main "this" } } V{ "a" "b" } } "" xml-error-test T{ bad-cdata f 1 3 } "" xml-error-test T{ bad-cdata f 1 7 } "" xml-error-test -T{ pre/post-content f "&" t } "&32;" xml-error-test +T{ pre/post-content f "&" t } " " xml-error-test T{ bad-doctype f 1 17 "a" } "" xml-error-test T{ bad-doctype f 1 22 T{ opener { name T{ name f "" "foo" "" } } { attrs T{ attrs } } } } " ]>" xml-error-test +T{ disallowed-char f 1 4 1 } "\u000001" xml-error-test +T{ missing-close f 1 8 } "" string>xml ] must-fail [ ] [ "" string>xml drop ] unit-test -[ T{ element-decl f "br" "EMPTY" } ] [ "" string>xml-chunk first ] unit-test -[ T{ element-decl f "p" "(#PCDATA|emph)*" } ] [ "" string>xml-chunk first ] unit-test -[ T{ element-decl f "%name.para;" "%content.para;" } ] [ "" string>xml-chunk first ] unit-test -[ T{ element-decl f "container" "ANY" } ] [ "" string>xml-chunk first ] unit-test -[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk first ] unit-test -[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk first ] unit-test -[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first ] unit-test -[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first ] unit-test + +: first-thing ( seq -- elt ) + [ "" = not ] filter first ; + +[ T{ element-decl f "br" "EMPTY" } ] [ "" string>dtd directives>> first-thing ] unit-test +[ T{ element-decl f "p" "(#PCDATA|emph)*" } ] [ "" string>dtd directives>> first-thing ] unit-test +[ T{ element-decl f "%name.para;" "%content.para;" } ] [ "" string>dtd directives>> first-thing ] unit-test +[ T{ element-decl f "container" "ANY" } ] [ "" string>dtd directives>> first-thing ] unit-test +[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk first-thing ] unit-test +[ T{ doctype-decl f "foo" } ] [ "" string>xml-chunk first-thing ] unit-test +[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first-thing ] unit-test +[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "" string>xml-chunk first-thing ] unit-test [ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test -[ "x" "<" ] [ "" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test +[ "x" "<" ] [ "" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test +[ "foo" ] [ "]>&bar;" string>xml children>string ] unit-test +[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index 8caa5e8a75..a8024ce151 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -1,17 +1,17 @@ USING: accessors assocs combinators continuations fry generalizations io.pathnames kernel macros sequences stack-checker tools.test xml -xml.utilities xml.writer arrays ; +xml.utilities xml.writer arrays xml.data ; IN: xml.tests.suite TUPLE: xml-test id uri sections description type ; : >xml-test ( tag -- test ) xml-test new swap { - [ "TYPE" swap at >>type ] - [ "ID" swap at >>id ] - [ "URI" swap at >>uri ] - [ "SECTIONS" swap at >>sections ] - [ children>> xml-chunk>string >>description ] + [ "TYPE" attr >>type ] + [ "ID" attr >>id ] + [ "URI" attr >>uri ] + [ "SECTIONS" attr >>sections ] + [ children>> xml>string >>description ] } cleave ; : parse-tests ( xml -- tests ) @@ -51,3 +51,5 @@ MACRO: drop-input ( quot -- newquot ) : failing-valids ( -- tests ) partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ; + +[ ] [ partition-xml-tests 2drop ] unit-test diff --git a/basis/xml/tests/xmode-dtd.factor b/basis/xml/tests/xmode-dtd.factor index c15d3a462e..4408655d9c 100644 --- a/basis/xml/tests/xmode-dtd.factor +++ b/basis/xml/tests/xmode-dtd.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: xml io.encodings.utf8 io.files kernel tools.test ; +USING: xml xml.data kernel tools.test ; IN: xml.tests -[ ] [ - "resource:basis/xmode/xmode.dtd" utf8 - read-xml-chunk drop +[ t ] [ + "resource:basis/xmode/xmode.dtd" file>dtd dtd? ] unit-test diff --git a/basis/xml/tokenize/summary.txt b/basis/xml/tokenize/summary.txt new file mode 100644 index 0000000000..cc5361aaae --- /dev/null +++ b/basis/xml/tokenize/summary.txt @@ -0,0 +1 @@ +Basic tools for parsing XML diff --git a/basis/xml/tokenize/tokenize.factor b/basis/xml/tokenize/tokenize.factor index 7a26385332..052cab15c2 100644 --- a/basis/xml/tokenize/tokenize.factor +++ b/basis/xml/tokenize/tokenize.factor @@ -2,123 +2,144 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces xml.state kernel sequences accessors xml.char-classes xml.errors math io sbufs fry strings ascii -circular xml.entities assocs make splitting math.parser -locals combinators arrays ; +circular xml.entities assocs splitting math.parser +locals combinators arrays hints ; IN: xml.tokenize -SYMBOL: prolog-data - -SYMBOL: depth - -: version=1.0? ( -- ? ) - prolog-data get [ version>> "1.0" = ] [ t ] if* ; - -: assure-good-char ( ch -- ch ) - [ - version=1.0? over text? not get-check and - [ disallowed-char ] when - ] [ f ] if* ; - ! * Basic utility words -: record ( char -- ) - CHAR: \n = - [ 0 get-line 1+ set-line ] [ get-column 1+ ] if - set-column ; +: assure-good-char ( spot ch -- ) + [ + swap + [ version-1.0?>> over text? not ] + [ check>> ] bi and [ + spot get [ 1+ ] change-column drop + disallowed-char + ] [ drop ] if + ] [ drop ] if* ; -! (next) normalizes \r\n and \r -: (next) ( -- char ) - get-next read1 - 2dup swap CHAR: \r = [ +HINTS: assure-good-char { spot fixnum } ; + +: record ( spot char -- spot ) + over char>> [ CHAR: \n = - [ nip read1 ] [ nip CHAR: \n swap ] if - ] [ drop ] if - set-next dup set-char assure-good-char ; + [ [ 1+ ] change-line -1 ] [ dup column>> 1+ ] if + >>column + ] [ drop ] if ; + +HINTS: record { spot fixnum } ; + +:: (next) ( spot -- spot char ) + spot next>> :> old-next + spot stream>> stream-read1 :> new-next + old-next CHAR: \r = [ + spot CHAR: \n >>char + new-next CHAR: \n = + [ spot stream>> stream-read1 >>next ] + [ new-next >>next ] if + ] [ spot old-next >>char new-next >>next ] if + spot next>> ; inline + +: next* ( spot -- ) + dup char>> [ unexpected-end ] unless + (next) [ record ] keep assure-good-char ; + +HINTS: next* { spot } ; : next ( -- ) - #! Increment spot. - get-char [ unexpected-end ] unless (next) record ; + spot get next* ; : init-parser ( -- ) - 0 1 0 f f spot set + 0 1 0 0 f t f + input-stream get >>stream + spot set read1 set-next next ; : with-state ( stream quot -- ) ! with-input-stream implicitly creates a new scope which we use swap [ init-parser call ] with-input-stream ; inline +:: (skip-until) ( quot: ( -- ? ) spot -- ) + spot char>> [ + quot call [ + spot next* quot spot (skip-until) + ] unless + ] when ; inline recursive + : skip-until ( quot: ( -- ? ) -- ) - get-char [ - [ call ] keep swap [ drop ] [ - next skip-until - ] if - ] [ drop ] if ; inline recursive + spot get (skip-until) ; inline : take-until ( quot -- string ) #! Take the substring of a string starting at spot #! from code until the quotation given is true and #! advance spot to after the substring. 10 [ - '[ @ [ t ] [ get-char _ push f ] if ] skip-until + spot get swap + '[ @ [ t ] [ _ char>> _ push f ] if ] skip-until ] keep >string ; inline -: take-char ( ch -- string ) - [ dup get-char = ] take-until nip ; +: take-to ( seq -- string ) + spot get swap '[ _ char>> _ member? ] take-until ; : pass-blank ( -- ) #! Advance code past any whitespace, including newlines - [ get-char blank? not ] skip-until ; + spot get '[ _ char>> blank? not ] skip-until ; -: string-matches? ( string circular -- ? ) - get-char over push-circular - sequence= ; +: string-matches? ( string circular spot -- ? ) + char>> over push-circular sequence= ; : take-string ( match -- string ) dup length - [ 2dup string-matches? ] take-until nip + spot get '[ 2dup _ string-matches? ] take-until nip dup length rot length 1- - head get-char [ missing-close ] unless next ; -: expect ( ch -- ) - get-char 2dup = [ 2drop ] [ - [ 1string ] bi@ expected - ] if next ; +: expect ( string -- ) + dup spot get '[ _ [ char>> ] keep next* ] replicate + 2dup = [ 2drop ] [ expected ] if ; -: expect-string ( string -- ) - dup [ get-char next ] replicate 2dup = - [ 2drop ] [ expected ] if ; +! Suddenly XML-specific -: parse-named-entity ( string -- ) - dup entities at [ , ] [ +: parse-named-entity ( accum string -- ) + dup entities at [ swap push ] [ dup extra-entities get at - [ % ] [ no-entity ] ?if + [ swap push-all ] [ no-entity ] ?if ] ?if ; -: parse-entity ( -- ) - next CHAR: ; take-char next - "#" ?head [ - "x" ?head 16 10 ? base> , +: take-; ( -- string ) + next ";" take-to next ; + +: parse-entity ( accum -- ) + take-; "#" ?head [ + "x" ?head 16 10 ? base> swap push ] [ parse-named-entity ] if ; -SYMBOL: pe-table -SYMBOL: in-dtd? +: parse-pe ( accum -- ) + take-; dup pe-table get at + [ swap push-all ] [ no-entity ] ?if ; -: parse-pe ( -- ) - next CHAR: ; take-char dup next - pe-table get at [ % ] [ no-entity ] ?if ; - -:: (parse-char) ( quot: ( ch -- ? ) -- ) - get-char :> char +:: (parse-char) ( quot: ( ch -- ? ) accum spot -- ) + spot char>> :> char { { [ char not ] [ ] } - { [ char quot call ] [ next ] } - { [ char CHAR: & = ] [ parse-entity quot (parse-char) ] } - { [ in-dtd? get char CHAR: % = and ] [ parse-pe quot (parse-char) ] } - [ char , next quot (parse-char) ] + { [ char quot call ] [ spot next* ] } + { [ char CHAR: & = ] [ + accum parse-entity + quot accum spot (parse-char) + ] } + { [ in-dtd? get char CHAR: % = and ] [ + accum parse-pe + quot accum spot (parse-char) + ] } + [ + char accum push + spot next* + quot accum spot (parse-char) + ] } cond ; inline recursive : parse-char ( quot: ( ch -- ? ) -- seq ) - [ (parse-char) ] "" make ; inline + 1024 [ spot get (parse-char) ] keep >string ; inline : assure-no-]]> ( circular -- ) "]]>" sequence= [ text-w/]]> ] when ; @@ -135,7 +156,7 @@ SYMBOL: in-dtd? ] parse-char ; : close ( -- ) - pass-blank CHAR: > expect ; + pass-blank ">" expect ; : normalize-quote ( str -- str ) [ dup "\t\r\n" member? [ drop CHAR: \s ] when ] map ; diff --git a/basis/xml/utilities/summary.txt b/basis/xml/utilities/summary.txt new file mode 100644 index 0000000000..a671132945 --- /dev/null +++ b/basis/xml/utilities/summary.txt @@ -0,0 +1 @@ +Utilities for manipulating an XML DOM tree diff --git a/basis/xml/utilities/tags.txt b/basis/xml/utilities/tags.txt new file mode 100644 index 0000000000..71c0ff7282 --- /dev/null +++ b/basis/xml/utilities/tags.txt @@ -0,0 +1 @@ +syntax diff --git a/basis/xml/utilities/utilities-docs.factor b/basis/xml/utilities/utilities-docs.factor index 5e391832dd..161ca824c3 100644 --- a/basis/xml/utilities/utilities-docs.factor +++ b/basis/xml/utilities/utilities-docs.factor @@ -6,11 +6,6 @@ IN: xml.utilities ABOUT: "xml.utilities" ARTICLE: "xml.utilities" "Utilities for processing XML" - "Utilities for processing XML include..." - $nl - "System sfor creating words which dispatch on XML tags:" - { $subsection POSTPONE: PROCESS: } - { $subsection POSTPONE: TAG: } "Getting parts of an XML document or tag:" $nl "Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient." @@ -19,11 +14,7 @@ ARTICLE: "xml.utilities" "Utilities for processing XML" { $subsection deep-tag-named } { $subsection deep-tags-named } { $subsection get-id } - "Words for simplified generation of XML:" - { $subsection build-tag* } - { $subsection build-tag } - { $subsection build-xml } - "Other relevant words:" + "To get at the contents of a single tag, use" { $subsection children>string } { $subsection children-tags } { $subsection first-child-tag } @@ -31,71 +22,42 @@ ARTICLE: "xml.utilities" "Utilities for processing XML" HELP: deep-tag-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } } -{ $description "finds an XML tag with a matching name, recursively searching children and children of children" } +{ $description "Finds an XML tag with a matching name, recursively searching children and children of children." } { $see-also tags-named tag-named deep-tags-named } ; HELP: deep-tags-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "tags-seq" "a sequence of tags" } } -{ $description "returns a sequence of all tags of a matching name, recursively searching children and children of children" } +{ $description "Returns a sequence of all tags of a matching name, recursively searching children and children of children." } { $see-also tag-named deep-tag-named tags-named } ; HELP: children>string { $values { "tag" "an XML tag or document" } { "string" "a string" } } -{ $description "concatenates the children of the tag, ignoring everything that's not a string" } ; +{ $description "Concatenates the children of the tag, throwing an exception when there is a non-string child." } ; HELP: children-tags { $values { "tag" "an XML tag or document" } { "sequence" sequence } } -{ $description "gets the children of the tag that are themselves tags" } +{ $description "Gets the children of the tag that are themselves tags." } { $see-also first-child-tag } ; HELP: first-child-tag { $values { "tag" "an XML tag or document" } { "tag" tag } } -{ $description "returns the first child of the given tag that is a tag" } +{ $description "Returns the first child of the given tag that is a tag." } { $see-also children-tags } ; HELP: tag-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing the name" } { "matching-tag" tag } } -{ $description "finds the first tag with matching name which is the direct child of the given tag" } +{ $description "Finds the first tag with matching name which is the direct child of the given tag." } { $see-also deep-tags-named deep-tag-named tags-named } ; HELP: tags-named { $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing the name" } { "tags-seq" "a sequence of tags" } } -{ $description "finds all tags with matching name that are the direct children of the given tag" } +{ $description "Finds all tags with matching name that are the direct children of the given tag." } { $see-also deep-tag-named deep-tags-named tag-named } ; HELP: get-id { $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } } -{ $description "finds the XML tag with the specified id, ignoring the namespace" } ; - -HELP: PROCESS: -{ $syntax "PROCESS: word" } -{ $values { "word" "a new word to define" } } -{ $description "creates a new word to process XML tags" } -{ $see-also POSTPONE: TAG: } ; - -HELP: TAG: -{ $syntax "TAG: tag word definition... ;" } -{ $values { "tag" "an xml tag name" } { "word" "an XML process" } } -{ $description "defines what a process should do when it encounters a specific tag" } -{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } -{ $see-also POSTPONE: PROCESS: } ; - -HELP: build-tag* -{ $values { "items" "sequence of elements" } { "name" "string" } - { "tag" tag } } -{ $description "builds a " { $link tag } " with the specified name, in the namespace \"\" and URL \"\" containing the children listed in item" } -{ $see-also build-tag build-xml } ; - -HELP: build-tag -{ $values { "item" "an element" } { "name" string } { "tag" tag } } -{ $description "builds a " { $link tag } " with the specified name containing the single child item" } -{ $see-also build-tag* build-xml } ; - -HELP: build-xml -{ $values { "tag" tag } { "xml" "an XML document" } } -{ $description "builds an XML document out of a tag" } -{ $see-also build-tag* build-tag } ; +{ $description "Finds the XML tag with the specified id, ignoring the namespace." } ; diff --git a/basis/xml/utilities/utilities-tests.factor b/basis/xml/utilities/utilities-tests.factor index c150c7133d..673bf47f6e 100644 --- a/basis/xml/utilities/utilities-tests.factor +++ b/basis/xml/utilities/utilities-tests.factor @@ -1,8 +1,22 @@ +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: xml xml.utilities tools.test xml.data sequences ; IN: xml.utilities.tests -USING: xml xml.utilities tools.test ; [ "bar" ] [ "bar" string>xml children>string ] unit-test [ "" ] [ "" string>xml children>string ] unit-test [ "" ] [ "" string>xml children>string ] unit-test + +XML-NS: foo http://blah.com + +[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test + +[ "blah" ] [ "" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test + +[ { "blah" } ] [ "" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test + +[ "blah" ] [ "" string>xml "foo" deep-tag-named "attr" attr ] unit-test + +[ { "blah" } ] [ "" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test \ No newline at end of file diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/utilities/utilities.factor old mode 100644 new mode 100755 index e104142a76..1249da8c36 --- a/basis/xml/utilities/utilities.factor +++ b/basis/xml/utilities/utilities.factor @@ -1,57 +1,17 @@ -! Copyright (C) 2005, 2006 Daniel Ehrenberg +! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces sequences words io assocs quotations strings parser lexer arrays xml.data xml.writer debugger -splitting vectors sequences.deep combinators fry ; +splitting vectors sequences.deep combinators fry memoize ; IN: xml.utilities -! * System for words specialized on tag names - -TUPLE: process-missing process tag ; -M: process-missing error. - "Tag <" write - dup tag>> print-name - "> not implemented on process process " write - name>> print ; - -: run-process ( tag word -- ) - 2dup "xtable" word-prop - [ dup main>> ] dip at* [ 2nip call ] [ - drop \ process-missing boa throw - ] if ; - -: PROCESS: - CREATE - dup H{ } clone "xtable" set-word-prop - dup '[ _ run-process ] define ; parsing - -: TAG: - scan scan-word - parse-definition - swap "xtable" word-prop - rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ; - parsing - - -! * Common utility functions - -: build-tag* ( items name -- tag ) - assure-name swap f swap ; - -: build-tag ( item name -- tag ) - [ 1array ] dip build-tag* ; - -: standard-prolog ( -- prolog ) - T{ prolog f "1.0" "UTF-8" f } ; - -: build-xml ( tag -- xml ) - standard-prolog { } rot { } ; - : children>string ( tag -- string ) children>> { { [ dup empty? ] [ drop "" ] } - { [ dup [ string? not ] contains? ] - [ "XML tag unexpectedly contains non-text children" throw ] } + { + [ dup [ string? not ] any? ] + [ "XML tag unexpectedly contains non-text children" throw ] + } [ concat ] } cond ; @@ -61,46 +21,44 @@ M: process-missing error. : first-child-tag ( tag -- tag ) children>> [ tag? ] find nip ; -! * Accessing part of an XML document -! for tag- words, a start means that it searches all children -! and no star searches only direct children - : tag-named? ( name elem -- ? ) dup tag? [ names-match? ] [ 2drop f ] if ; -: tags@ ( tag name -- children name ) - [ { } like ] dip assure-name ; - -: deep-tag-named ( tag name/string -- matching-tag ) - assure-name '[ _ swap tag-named? ] deep-find ; - -: deep-tags-named ( tag name/string -- tags-seq ) - tags@ '[ _ swap tag-named? ] deep-filter ; - : tag-named ( tag name/string -- matching-tag ) - ! like get-name-tag but only looks at direct children, - ! not all the children down the tree. - assure-name swap [ tag-named? ] with find nip ; + assure-name '[ _ swap tag-named? ] find nip ; : tags-named ( tag name/string -- tags-seq ) - tags@ swap [ tag-named? ] with filter ; + assure-name '[ _ swap tag-named? ] filter { } like ; + +> ] when ] [ assure-name ] bi* ; + +PRIVATE> + +: deep-tag-named ( tag name/string -- matching-tag ) + prepare-deep '[ _ swap tag-named? ] deep-find ; + +: deep-tags-named ( tag name/string -- tags-seq ) + prepare-deep '[ _ swap tag-named? ] deep-filter { } like ; : tag-with-attr? ( elem attr-value attr-name -- ? ) - rot dup tag? [ at = ] [ 3drop f ] if ; + rot dup tag? [ swap attr = ] [ 3drop f ] if ; : tag-with-attr ( tag attr-value attr-name -- matching-tag ) assure-name '[ _ _ tag-with-attr? ] find nip ; : tags-with-attr ( tag attr-value attr-name -- tags-seq ) - tags@ '[ _ _ tag-with-attr? ] filter children>> ; + assure-name '[ _ _ tag-with-attr? ] filter children>> ; : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag ) assure-name '[ _ _ tag-with-attr? ] deep-find ; : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq ) - tags@ '[ _ _ tag-with-attr? ] deep-filter ; + assure-name '[ _ _ tag-with-attr? ] deep-filter ; -: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) +: get-id ( tag id -- elem ) "id" deep-tag-with-attr ; : deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags ) @@ -115,3 +73,7 @@ M: process-missing error. : insert-child ( child tag -- ) [ 1vector ] dip insert-children ; + +: XML-NS: + CREATE-WORD (( string -- name )) over set-stack-effect + scan '[ f swap _ ] define-memoized ; parsing diff --git a/basis/xml/writer/summary.txt b/basis/xml/writer/summary.txt new file mode 100644 index 0000000000..04d0471969 --- /dev/null +++ b/basis/xml/writer/summary.txt @@ -0,0 +1 @@ +Tools for printing XML, including prettyprinting diff --git a/basis/xml/writer/writer-docs.factor b/basis/xml/writer/writer-docs.factor index b470403e84..cc45528cec 100644 --- a/basis/xml/writer/writer-docs.factor +++ b/basis/xml/writer/writer-docs.factor @@ -1,56 +1,67 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup io strings ; +USING: help.syntax help.markup io strings xml.data multiline ; IN: xml.writer ABOUT: "xml.writer" ARTICLE: "xml.writer" "Writing XML" - "These words are used in implementing prettyprint" - { $subsection write-xml-chunk } - "These words are used to print XML normally" - { $subsection xml>string } + "These words are used to print XML preserving whitespace in text nodes" { $subsection write-xml } + { $subsection xml>string } "These words are used to prettyprint XML" { $subsection pprint-xml>string } - { $subsection pprint-xml>string-but } { $subsection pprint-xml } - { $subsection pprint-xml-but } ; - -HELP: write-xml-chunk -{ $values { "object" "an XML element" } } -{ $description "writes an XML element to " { $link output-stream } "." } -{ $see-also write-xml-chunk write-xml } ; + "Certain variables can be changed to mainpulate prettyprinting" + { $subsection sensitive-tags } + { $subsection indenter } + "All of these words operate on arbitrary pieces of XML: they can take, as in put, XML documents, comments, tags, strings (text nodes), XML chunks, etc." ; HELP: xml>string -{ $values { "xml" "an xml document" } { "string" "a string" } } -{ $description "converts an XML document into a string" } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; +{ $values { "xml" "an XML document" } { "string" "a string" } } +{ $description "This converts an XML document " { $link xml } " into a string. It can also be used to convert any piece of XML to a string, eg an " { $link xml-chunk } " or " { $link comment } "." } +{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ; HELP: pprint-xml>string -{ $values { "xml" "an xml document" } { "string" "a string" } } +{ $values { "xml" "an XML document" } { "string" "a string" } } { $description "converts an XML document into a string in a prettyprinted form." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; +{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ; HELP: write-xml { $values { "xml" "an XML document" } } { $description "prints the contents of an XML document to " { $link output-stream } "." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; +{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. The whitespace in the text nodes of the original document is preserved." } ; HELP: pprint-xml { $values { "xml" "an XML document" } } { $description "prints the contents of an XML document to " { $link output-stream } " in a prettyprinted form." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; +{ $notes "This does not preserve what type of quotes were used or what data was omitted from version declaration, as that information isn't present in the XML data representation. Whitespace is also not preserved." } ; -HELP: pprint-xml-but -{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } } -{ $description "Prettyprints an XML document, leaving the whitespace of the tags with names in sensitive-tags intact." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; +{ xml>string write-xml pprint-xml pprint-xml>string } related-words -HELP: pprint-xml>string-but -{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } { "string" string } } -{ $description "Prettyprints an XML document, returning the result as a string and leaving the whitespace of the tags with names in sensitive-tags intact." } -{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ; - -{ xml>string write-xml pprint-xml pprint-xml>string pprint-xml>string-but pprint-xml-but } related-words +HELP: indenter +{ $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" } +{ $example {" USING: xml.literals xml.writer namespaces ; +[XML bar XML] "%%%%" indenter [ pprint-xml ] with-variable "} {" + +%%%%bar +"} } ; +HELP: sensitive-tags +{ $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" } +{ $example {" USING: xml.literals xml.writer namespaces ; +[XML something
    bing
+bang
+   bong
    XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {" + + + + something + + + + 
    bing
+bang
+   bong
    + +"} } ; diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index 2b00c90344..d09ae08b3f 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -7,7 +7,7 @@ IN: xml.writer.tests \ write-xml must-infer \ xml>string must-infer \ pprint-xml must-infer -\ pprint-xml-but must-infer +! Add a test for pprint-xml with sensitive-tags [ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test [ "foo" ] [ T{ name { space "" } { main "foo" } } name>string ] unit-test @@ -51,12 +51,11 @@ IN: xml.writer.tests ]> &foo;"} pprint-reprints-as -[ t ] [ "" dup string>xml-chunk xml-chunk>string = ] unit-test -[ "foo" ] [ "&bar;" string>xml children>string ] unit-test -[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test +[ t ] [ "" dup string>xml-chunk xml>string = ] unit-test [ "    " ] [ "" string>xml xml>string ] unit-test [ "bar baz" ] [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test [ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test +[ "" ] [ "" xml>string ] unit-test diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor old mode 100644 new mode 100755 index 3a274d7135..146e67e70f --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -5,16 +5,17 @@ assocs combinators io io.streams.string accessors xml.data wrap xml.entities unicode.categories fry ; IN: xml.writer -SYMBOL: xml-pprint? SYMBOL: sensitive-tags -SYMBOL: indentation SYMBOL: indenter " " indenter set-global + : name>string ( name -- string ) [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ; -PRIVATE> - : print-name ( name -- ) name>string write ; " write ; -M: contained-tag write-xml-chunk +M: contained-tag write-xml write-tag "/>" write ; : write-children ( tag -- ) indent children>> ?filter-children - [ write-xml-chunk ] each unindent ; + [ write-xml ] each unindent ; : write-end-tag ( tag -- ) ?indent " write1 ; -M: open-tag write-xml-chunk +M: open-tag write-xml xml-pprint? get [ { - [ sensitive? not xml-pprint? get and xml-pprint? set ] [ write-start-tag ] + [ sensitive? not xml-pprint? get and xml-pprint? set ] [ write-children ] [ write-end-tag ] } cleave ] dip xml-pprint? set ; -M: comment write-xml-chunk +M: unescaped write-xml + string>> write ; + +M: comment write-xml "" write ; -M: element-decl write-xml-chunk - "> write " " write ] - [ content-spec>> write ">" write ] - bi ; +: write-decl ( decl name quot: ( decl -- slot ) -- ) + "> write bl ] + swap '[ @ write ">" write ] bi ; inline -M: attlist-decl write-xml-chunk - "> write " " write ] - [ att-defs>> write ">" write ] - bi ; +M: element-decl write-xml + "ELEMENT" [ content-spec>> ] write-decl ; -M: notation-decl write-xml-chunk - "> write " " write ] - [ id>> write ">" write ] - bi ; +M: attlist-decl write-xml + "ATTLIST" [ att-defs>> ] write-decl ; -M: entity-decl write-xml-chunk +M: notation-decl write-xml + "NOTATION" [ id>> ] write-decl ; + +M: entity-decl write-xml "> [ " % " write ] when ] [ name>> write " \"" write ] [ def>> f xml-pprint? - [ write-xml-chunk ] with-variable + [ write-xml ] with-variable "\">" write ] tri ; -M: system-id write-xml-chunk - "SYSTEM '" write system-literal>> write "'" write ; +M: system-id write-xml + "SYSTEM" write bl system-literal>> write-quoted ; -M: public-id write-xml-chunk - "PUBLIC '" write - [ pubid-literal>> write "' '" write ] - [ system-literal>> write "'" write ] bi ; +M: public-id write-xml + "PUBLIC" write bl + [ pubid-literal>> write-quoted bl ] + [ system-literal>> write-quoted ] bi ; -: write-internal-subset ( seq -- ) +: write-internal-subset ( dtd -- ) [ "[" write indent - [ ?indent write-xml-chunk ] each + directives>> [ ?indent write-xml ] each unindent ?indent "]" write ] when* ; -M: doctype-decl write-xml-chunk +M: doctype-decl write-xml ?indent "> write " " write ] - [ external-id>> [ write-xml-chunk " " write ] when* ] + [ external-id>> [ write-xml " " write ] when* ] [ internal-subset>> write-internal-subset ">" write ] tri ; -M: directive write-xml-chunk +M: directive write-xml "> write CHAR: > write1 nl ; -M: instruction write-xml-chunk +M: instruction write-xml "> write "?>" write ; -M: sequence write-xml-chunk - [ write-xml-chunk ] each ; +M: number write-xml + "Numbers are not allowed in XML" throw ; -: write-prolog ( xml -- ) - "> write - "\" encoding=\"" write dup encoding>> write - standalone>> [ "\" standalone=\"yes" write ] when - "\"?>" write ; +M: sequence write-xml + [ write-xml ] each ; -PRIVATE> +M: prolog write-xml + "> write-quoted ] + [ " encoding=" write encoding>> write-quoted ] + [ standalone>> [ " standalone=\"yes\"" write ] when ] tri + "?>" write ; -: write-xml ( xml -- ) +M: xml write-xml { - [ prolog>> write-prolog ] - [ before>> write-xml-chunk ] - [ body>> write-xml-chunk ] - [ after>> write-xml-chunk ] + [ prolog>> write-xml ] + [ before>> write-xml ] + [ body>> write-xml ] + [ after>> write-xml ] } cleave ; -M: xml write-xml-chunk - body>> write-xml-chunk ; +PRIVATE> : xml>string ( xml -- string ) [ write-xml ] with-string-writer ; -: xml-chunk>string ( object -- string ) - [ write-xml-chunk ] with-string-writer ; - -: pprint-xml-but ( xml sensitive-tags -- ) +: pprint-xml ( xml -- ) [ - [ assure-name ] map sensitive-tags set + sensitive-tags [ [ assure-name ] map ] change 0 indentation set xml-pprint? on write-xml ] with-scope ; -: pprint-xml ( xml -- ) - f pprint-xml-but ; - -: pprint-xml>string-but ( xml sensitive-tags -- string ) - [ pprint-xml-but ] with-string-writer ; - : pprint-xml>string ( xml -- string ) - f pprint-xml>string-but ; + [ pprint-xml ] with-string-writer ; diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor index 60bc88bad6..901fce2dd4 100644 --- a/basis/xml/xml-docs.factor +++ b/basis/xml/xml-docs.factor @@ -1,66 +1,81 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax xml.data io ; +USING: help.markup help.syntax xml.data io strings ; IN: xml HELP: string>xml -{ $values { "string" "a string" } { "xml" "an xml document" } } -{ $description "converts a string into an " { $link xml } - " datatype for further processing" } ; +{ $values { "string" string } { "xml" xml } } +{ $description "Converts a string into an " { $link xml } + " tree for further processing." } ; HELP: read-xml -{ $values { "stream" "a stream that supports readln" } - { "xml" "an XML document" } } -{ $description "exausts the given stream, reading an XML document from it. A binary stream, one without encoding, should be used as input, and the encoding is automatically detected." } ; +{ $values { "stream" "an input stream" } { "xml" xml } } +{ $description "Exausts the given stream, reading an XML document from it. A binary stream, one without encoding, should be used as input, and the encoding is automatically detected." } ; HELP: file>xml -{ $values { "filename" "a string representing a filename" } - { "xml" "an XML document" } } -{ $description "opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree" } ; +{ $values { "filename" string } { "xml" xml } } +{ $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ; { string>xml read-xml file>xml } related-words HELP: read-xml-chunk { $values { "stream" "an input stream" } { "seq" "a sequence of elements" } } -{ $description "rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag." } +{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag. The encoding is not automatically detected, and a stream with an encoding (ie. one which returns strings from " { $link read } ") should be used as input." } { $see-also read-xml } ; -HELP: sax +HELP: each-element { $values { "stream" "an input stream" } { "quot" "a quotation ( xml-elem -- )" } } -{ $description "parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly, and it is advised that generic words be used in dispatching on the event class." } -{ $notes "It is important to note that this is not SAX, merely an event-based XML view" } +{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly. The encoding of the stream is automatically detected, so a binary input stream should be used." } { $see-also read-xml } ; HELP: pull-xml -{ $class-description "represents the state of a pull-parser for XML. Has one slot, scope, which is a namespace which contains all relevant state information." } +{ $class-description "Represents the state of a pull-parser for XML. Has one slot, " { $snippet "scope" } ", which is a namespace which contains all relevant state information." } { $see-also pull-event pull-elem } ; HELP: -{ $values { "pull-xml" "a pull-xml tuple" } } -{ $description "creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." } +{ $values { "pull-xml" pull-xml } } +{ $description "Creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." } { $see-also pull-xml pull-elem pull-event } ; HELP: pull-elem { $values { "pull" "an XML pull parser" } { "xml-elem/f" "an XML tag, string, or f" } } -{ $description "gets the next XML element from the given XML pull parser. Returns f upon exhaustion." } +{ $description "Gets the next XML element from the given XML pull parser. Returns f upon exhaustion." } { $see-also pull-xml pull-event } ; HELP: pull-event { $values { "pull" "an XML pull parser" } { "xml-event/f" "an XML tag event, string, or f" } } -{ $description "gets the next XML event from the given XML pull parser. Returns f upon exhaustion." } +{ $description "Gets the next XML event from the given XML pull parser. Returns f upon exhaustion." } { $see-also pull-xml pull-elem } ; +HELP: read-dtd +{ $values { "stream" "an input stream" } { "dtd" dtd } } +{ $description "Exhausts a stream, producing a " { $link dtd } " from the contents." } ; + +HELP: file>dtd +{ $values { "filename" string } { "dtd" dtd } } +{ $description "Reads a file in UTF-8, converting it into an XML " { $link dtd } "." } ; + +HELP: string>dtd +{ $values { "string" string } { "dtd" dtd } } +{ $description "Interprets a string as an XML " { $link dtd } "." } ; + +{ read-dtd file>dtd string>dtd } related-words + ARTICLE: { "xml" "reading" } "Reading XML" "The following words are used to read something into an XML document" { $subsection string>xml } { $subsection read-xml } { $subsection read-xml-chunk } { $subsection string>xml-chunk } - { $subsection file>xml } ; + { $subsection file>xml } + "To read a DTD:" + { $subsection read-dtd } + { $subsection file>dtd } + { $subsection string>dtd } ; ARTICLE: { "xml" "events" } "Event-based XML parsing" "In addition to DOM-style parsing based around " { $link read-xml } ", the XML module also provides SAX-style event-based parsing. This uses much of the same data structures as normal XML, with the exception of the classes " { $link xml } " and " { $link tag } " and as such, the article " { $vocab-link "xml.data" } " may be useful in learning how to process documents in this way. Other useful words are:" - { $subsection sax } + { $subsection each-element } { $subsection opener } { $subsection closer } { $subsection contained } @@ -71,13 +86,14 @@ ARTICLE: { "xml" "events" } "Event-based XML parsing" { $subsection pull-elem } ; ARTICLE: "xml" "XML parser" -"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa." +"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa. The parser checks for well-formedness but is not validating. There is only partial support for processing DTDs." { $subsection { "xml" "reading" } } { $subsection { "xml" "events" } } - { $vocab-subsection "Utilities for processing XML" "xml.utilities" } { $vocab-subsection "Writing XML" "xml.writer" } { $vocab-subsection "XML parsing errors" "xml.errors" } { $vocab-subsection "XML entities" "xml.entities" } - { $vocab-subsection "XML data types" "xml.data" } ; + { $vocab-subsection "XML data types" "xml.data" } + { $vocab-subsection "Utilities for processing XML" "xml.utilities" } + { $vocab-subsection "Dispatch on XML tag names" "xml.dispatch" } ; ABOUT: "xml" diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor old mode 100644 new mode 100755 index 636aa288b5..5ca486a57f --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays io io.encodings.binary io.files -io.streams.string kernel namespaces sequences strings -xml.backend xml.data xml.errors xml.elements ascii xml.entities -xml.writer xml.state xml.autoencoding assocs xml.tokenize xml.name ; +io.streams.string kernel namespaces sequences strings io.encodings.utf8 +xml.data xml.errors xml.elements ascii xml.entities +xml.writer xml.state xml.autoencoding assocs xml.tokenize +combinators.short-circuit xml.name ; IN: xml -! -- Overall parser with data tree +> ] [ attrs>> ] bi @@ -49,17 +54,14 @@ M: closer process : init-xml-stack ( -- ) V{ } clone xml-stack set - extra-entities [ H{ } assoc-like ] change f push-xml ; : default-prolog ( -- prolog ) "1.0" "UTF-8" f ; -: reset-prolog ( -- ) - default-prolog prolog-data set ; - : init-xml ( -- ) - reset-prolog init-xml-stack init-ns-stack ; + init-ns-stack + extra-entities [ H{ } assoc-like ] change ; : assert-blanks ( seq pre? -- ) swap [ string? ] filter @@ -74,13 +76,17 @@ M: closer process : no-post-tags ( post -- post/* ) ! this does *not* affect the contents of the stack - dup [ tag? ] contains? [ multitags ] when ; + dup [ tag? ] any? [ multitags ] when ; : assure-tags ( seq -- seq ) ! this does *not* affect the contents of the stack [ notags ] unless* ; -: make-xml-doc ( prolog seq -- xml-doc ) +: get-prolog ( seq -- prolog ) + first dup prolog? [ drop default-prolog ] unless ; + +: make-xml-doc ( seq -- xml-doc ) + [ get-prolog ] keep dup [ tag? ] find [ assure-tags cut rest no-pre/post no-post-tags ] dip swap ; @@ -89,12 +95,13 @@ M: closer process SYMBOL: text-now? +PRIVATE> + TUPLE: pull-xml scope ; : ( -- pull-xml ) [ input-stream [ ] change ! bring var in this scope - init-parser reset-prolog init-ns-stack - text-now? on + init-xml text-now? on ] H{ } make-assoc pull-xml boa ; ! pull-xml needs to call start-document somewhere @@ -106,6 +113,8 @@ TUPLE: pull-xml scope ; ] if text-now? set ] bind ; + + : pull-elem ( pull -- xml-elem/f ) [ init-xml-stack (pull-elem) ] with-scope ; + + +: each-element ( stream quot: ( xml-elem -- ) -- ) + swap [ + init-xml + start-document [ call-under ] when* + xml-loop + ] with-state ; inline : read-xml ( stream -- xml ) - 0 depth - [ (read-xml-chunk) make-xml-doc ] with-variable ; + [ start-document [ process ] when* ] + 0 read-seq make-xml-doc ; : read-xml-chunk ( stream -- seq ) - 1 depth - [ (read-xml-chunk) nip ] with-variable ; + [ check ] 1 read-seq ; : string>xml ( string -- xml ) - read-xml ; + [ check ] 0 read-seq make-xml-doc ; : string>xml-chunk ( string -- xml ) - t string-input? - [ read-xml-chunk ] with-variable ; + read-xml-chunk ; : file>xml ( filename -- xml ) binary read-xml ; + +: read-dtd ( stream -- dtd ) + [ + H{ } clone extra-entities set + take-internal-subset + ] with-state ; + +: file>dtd ( filename -- dtd ) + utf8 read-dtd ; + +: string>dtd ( string -- dtd ) + read-dtd ; diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index f8f1788bcf..4e3af0af56 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -1,6 +1,6 @@ USING: xmode.loader xmode.utilities xmode.rules namespaces strings splitting assocs sequences kernel io.files xml memoize -words globs combinators io.encodings.utf8 sorting accessors ; +words globs combinators io.encodings.utf8 sorting accessors xml.data ; IN: xmode.catalog TUPLE: mode file file-name-glob first-line-glob ; @@ -8,7 +8,7 @@ TUPLE: mode file file-name-glob first-line-glob ; >file) } { "FILE_NAME_GLOB" f (>>file-name-glob) } @@ -52,9 +52,15 @@ SYMBOL: rule-sets dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if* dup -roll at* [ nip ] [ drop no-such-rule-set ] if ; +DEFER: finalize-rule-set + : resolve-delegate ( rule -- ) - dup delegate>> dup string? - [ get-rule-set nip swap (>>delegate) ] [ 2drop ] if ; + dup delegate>> dup string? [ + get-rule-set + dup rule-set? [ "not a rule set" throw ] unless + swap rule-sets [ dup finalize-rule-set ] with-variable + >>delegate drop + ] [ 2drop ] if ; : each-rule ( rule-set quot -- ) [ rules>> values concat ] dip each ; inline @@ -74,26 +80,22 @@ SYMBOL: rule-sets : resolve-imports ( ruleset -- ) dup imports>> [ get-rule-set swap rule-sets [ - dup resolve-delegates - 2dup import-keywords - import-rules + [ nip resolve-delegates ] + [ import-keywords ] + [ import-rules ] + 2tri ] with-variable ] with each ; ERROR: mutually-recursive-rulesets ruleset ; + : finalize-rule-set ( ruleset -- ) - dup finalized?>> { - { f [ - { - [ 1 >>finalized? drop ] - [ resolve-imports ] - [ resolve-delegates ] - [ t >>finalized? drop ] - } cleave - ] } - { t [ drop ] } - { 1 [ mutually-recursive-rulesets ] } - } case ; + dup finalized?>> [ drop ] [ + t >>finalized? + [ resolve-imports ] + [ resolve-delegates ] + bi + ] if ; : finalize-mode ( rulesets -- ) rule-sets [ diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor new file mode 100644 index 0000000000..c0b8a1b560 --- /dev/null +++ b/basis/xmode/code2html/code2html-tests.factor @@ -0,0 +1,19 @@ +IN: xmode.code2html.tests +USING: xmode.code2html xmode.catalog +tools.test multiline splitting memoize +kernel io.streams.string xml.writer ; + +[ ] [ \ (load-mode) reset-memoized ] unit-test + +[ ] [ + <" ; +: default-stylesheet ( -- xml ) + "resource:basis/xmode/code2html/stylesheet.css" + utf8 file-contents + [XML XML] ; -: htmlize-stream ( path stream -- ) - lines swap - +:: htmlize-stream ( path stream -- xml ) + stream lines + [ "" ] [ path over first find-mode htmlize-lines ] + if-empty :> input + default-stylesheet :> stylesheet + - default-stylesheet - dup escape-string write + <-stylesheet-> + <-path-> - 
    -                over empty?
-                [ 2drop ]
-                [ over first find-mode htmlize-lines ] if
-
    + 
    <-input->
    - ; + XML> ; : htmlize-file ( path -- ) dup utf8 [ dup ".html" append utf8 [ - input-stream get htmlize-stream + input-stream get htmlize-stream write-xml ] with-file-writer ] with-file-reader ; diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor index 8639c93e71..b661f4eb3f 100644 --- a/basis/xmode/loader/loader.factor +++ b/basis/xmode/loader/loader.factor @@ -13,10 +13,10 @@ TAG: PROPS parse-props-tag >>props drop ; TAG: IMPORT - "DELEGATE" swap at swap import-rule-set ; + "DELEGATE" attr swap import-rule-set ; TAG: TERMINATE - "AT_CHAR" swap at string>number >>terminate-char drop ; + "AT_CHAR" attr string>number >>terminate-char drop ; RULE: SEQ seq-rule shared-tag-attrs delegate-attr literal-start ; @@ -43,17 +43,17 @@ RULE: MARK_PREVIOUS mark-previous-rule shared-tag-attrs match-type-attr literal-start ; TAG: KEYWORDS ( rule-set tag -- key value ) - ignore-case? get + rule-set get ignore-case?>> swap child-tags [ over parse-keyword-tag ] each swap (>>keywords) ; TAGS> : ? ( string/f -- regexp/f ) - dup [ ignore-case? get ] when ; + dup [ rule-set get ignore-case?>> ] when ; : (parse-rules-tag) ( tag -- rule-set ) - + dup rule-set set { { "SET" string>rule-set-name (>>name) } { "IGNORE_CASE" string>boolean (>>ignore-case?) } @@ -65,11 +65,11 @@ TAGS> } init-from-tag ; : parse-rules-tag ( tag -- rule-set ) - dup (parse-rules-tag) [ - dup ignore-case?>> ignore-case? [ - swap child-tags [ parse-rule-tag ] with each - ] with-variable - ] keep ; + [ + [ (parse-rules-tag) ] [ child-tags ] bi + [ parse-rule-tag ] with each + rule-set get + ] with-scope ; : merge-rule-set-props ( props rule-set -- ) [ assoc-union ] change-props drop ; diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index 9b53000e02..b546969a37 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -1,13 +1,11 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors xmode.tokens xmode.rules xmode.keyword-map xml.data xml.utilities xml assocs kernel combinators sequences math.parser namespaces make parser lexer xmode.utilities -parser-combinators.regexp io.files ; +parser-combinators.regexp io.files splitting arrays ; IN: xmode.loader.syntax -SYMBOL: ignore-case? - ! Rule tag parsing utilities : (parse-rule-tag) ( rule-set tag specs class -- ) new swap init-from-tag swap add-rule ; inline @@ -31,7 +29,7 @@ SYMBOL: ignore-case? ! PROP, PROPS : parse-prop-tag ( tag -- key value ) - "NAME" over at "VALUE" rot at ; + [ "NAME" attr ] [ "VALUE" attr ] bi ; : parse-props-tag ( tag -- assoc ) child-tags @@ -40,20 +38,23 @@ SYMBOL: ignore-case? : position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? ) ! XXX Wrong logic! { "AT_LINE_START" "AT_WHITESPACE_END" "AT_WORD_START" } - swap [ at string>boolean ] curry map first3 ; + [ attr string>boolean ] with map first3 ; : parse-literal-matcher ( tag -- matcher ) dup children>string - ignore-case? get + rule-set get ignore-case?>> swap position-attrs ; : parse-regexp-matcher ( tag -- matcher ) - dup children>string ignore-case? get + dup children>string rule-set get ignore-case?>> swap position-attrs ; : shared-tag-attrs ( -- ) { "TYPE" string>token (>>body-token) } , ; inline +: parse-delegate ( string -- pair ) + "::" split1 [ rule-set get swap ] unless* 2array ; + : delegate-attr ( -- ) { "DELEGATE" f (>>delegate) } , ; diff --git a/basis/xmode/marker/context/context.factor b/basis/xmode/marker/context/context.factor index da20503fcb..cc3b5096e8 100644 --- a/basis/xmode/marker/context/context.factor +++ b/basis/xmode/marker/context/context.factor @@ -1,4 +1,4 @@ -USING: accessors kernel ; +USING: accessors kernel xmode.rules ; IN: xmode.marker.context ! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext @@ -10,7 +10,7 @@ end ; : ( ruleset parent -- line-context ) - over [ "no context" throw ] unless + over rule-set? [ "not a rule-set" throw ] unless line-context new swap >>parent swap >>in-rule-set ; diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor old mode 100644 new mode 100755 index 3e632cc5af..cff0af2a98 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -15,7 +15,7 @@ ascii combinators.short-circuit accessors ; : keyword-number? ( keyword -- ? ) { [ current-rule-set highlight-digits?>> ] - [ dup [ digit? ] contains? ] + [ dup [ digit? ] any? ] [ dup [ digit? ] all? [ current-rule-set digit-re>> @@ -100,7 +100,7 @@ DEFER: get-rules [ ch>upper ] dip rules>> at ?push-all ; : get-rules ( char ruleset -- seq ) - f -rot [ get-char-rules ] keep get-always-rules ; + [ f ] 2dip [ get-char-rules ] keep get-always-rules ; GENERIC: handle-rule-start ( match-count rule -- ) diff --git a/basis/xmode/utilities/utilities.factor b/basis/xmode/utilities/utilities.factor index b5a2f6eb98..d6407d8180 100644 --- a/basis/xmode/utilities/utilities.factor +++ b/basis/xmode/utilities/utilities.factor @@ -7,7 +7,7 @@ IN: xmode.utilities : child-tags ( tag -- seq ) children>> [ tag? ] filter ; : map-find ( seq quot -- result elt ) - f -rot + [ f ] 2dip '[ nip @ dup ] find [ [ drop f ] unless ] dip ; inline @@ -22,7 +22,7 @@ IN: xmode.utilities ] } { [ dup length 3 = ] [ first3 '[ - _ tag get at + tag get _ attr _ [ execute ] when* object get _ execute ] ] } diff --git a/build-support/factor.sh b/build-support/factor.sh index b2b6ad1ff9..44c047155d 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -236,7 +236,7 @@ find_word_size() { set_factor_binary() { case $OS in - winnt) FACTOR_BINARY=factor.exe;; + winnt) FACTOR_BINARY=factor-console.exe;; *) FACTOR_BINARY=factor;; esac } diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor old mode 100644 new mode 100755 index 627d4aeb80..e5c43f3ed6 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2007 Daniel Ehrenberg, Slava Pestov, and Doug Coleman +! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov, and Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences -sequences.private namespaces math quotations ; +sequences.private namespaces math quotations assocs.private ; IN: assocs ARTICLE: "alists" "Association lists" @@ -21,7 +21,7 @@ ARTICLE: "enums" "Enumerations" { $subsection enum } { $subsection } "Inverting a permutation using enumerations:" -{ $example "USING: assocs sorting prettyprint ;" ": invert >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ; +{ $example "USING: assocs sorting prettyprint ;" "IN: scratchpad" ": invert ( perm -- perm' )" " >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ; HELP: enum { $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence." @@ -82,7 +82,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" { $subsection substitute } { $subsection substitute-here } { $subsection extract-keys } -{ $see-also key? assoc-contains? assoc-all? "sets" } ; +{ $see-also key? assoc-any? assoc-all? "sets" } ; ARTICLE: "assocs-mutation" "Storing keys and values in assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" @@ -113,19 +113,15 @@ $nl { $subsection assoc-each } { $subsection assoc-find } { $subsection assoc-map } -{ $subsection assoc-push-if } { $subsection assoc-filter } { $subsection assoc-filter-as } -{ $subsection assoc-contains? } +{ $subsection assoc-any? } { $subsection assoc-all? } "Additional combinators:" { $subsection cache } { $subsection map>assoc } { $subsection assoc>map } -{ $subsection assoc-map-as } -{ $subsection search-alist } -"Utility word:" -{ $subsection assoc-pusher } ; +{ $subsection assoc-map-as } ; ARTICLE: "assocs" "Associative mapping operations" "An " { $emphasis "associative mapping" } ", abbreviated " { $emphasis "assoc" } ", is a collection of key/value pairs which provides efficient lookup and storage indexed by key." @@ -225,10 +221,6 @@ HELP: assoc-map { assoc-map assoc-map-as } related-words -HELP: assoc-push-if -{ $values { "accum" "a resizable mutable sequence" } { "quot" { $quotation "( key value -- ? )" } } { "key" object } { "value" object } } -{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ; - HELP: assoc-filter { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } } { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ; @@ -239,7 +231,7 @@ HELP: assoc-filter-as { assoc-filter assoc-filter-as } related-words -HELP: assoc-contains? +HELP: assoc-any? { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } } { $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ; @@ -388,18 +380,6 @@ HELP: assoc-map-as { $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." } { $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ; -HELP: assoc-pusher -{ $values - { "quot" "a predicate quotation" } - { "quot'" quotation } { "accum" assoc } } -{ $description "Creates a new " { $snippet "assoc" } " to accumulate the key/value pairs which return true for a predicate. Returns a new quotation which accepts a pair of object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." } -{ $example "! Find only the pairs that sum to 5:" "USING: prettyprint assocs math kernel ;" - "{ { 1 2 } { 2 3 } { 3 4 } } [ + 5 = ] assoc-pusher [ assoc-each ] dip ." - "V{ { 2 3 } }" -} -{ $notes "Used to implement the " { $link assoc-filter } " word." } ; - - HELP: extract-keys { $values { "seq" sequence } { "assoc" assoc } @@ -425,11 +405,12 @@ HELP: search-alist { $values { "key" object } { "alist" "an array of key/value pairs" } { "pair/f" "a key/value pair" } { "i/f" integer } } -{ $description "Performs an in-order traversal of a " { $snippet "alist" } " and stops when the key is matched or the end of the " { $snippet "alist" } " has been reached. If there is no match, both outputs are " { $link f } "." } -{ $examples { $example "USING: prettyprint assocs kernel ;" +{ $description "Iterates over " { $snippet "alist" } " and stops when the key is matched or the end of the " { $snippet "alist" } " has been reached. If there is no match, both outputs are " { $link f } "." } +{ $notes "This word is used to implement " { $link at* } " and " { $link set-at } " on sequences, and should not be called direclty." } +{ $examples { $example "USING: prettyprint assocs.private kernel ;" "3 { { 1 2 } { 3 4 } } search-alist [ . ] bi@" "{ 3 4 }\n1" - } { $example "USING: prettyprint assocs kernel ;" + } { $example "USING: prettyprint assocs.private kernel ;" "6 { { 1 2 } { 3 4 } } search-alist [ . ] bi@" "f\nf" } diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor index ac82da7b9b..5617888148 100644 --- a/core/assocs/assocs-tests.factor +++ b/core/assocs/assocs-tests.factor @@ -129,4 +129,13 @@ unit-test [ "x" ] [ "a" H{ { "a" "x" } } at-default +] unit-test + +[ H{ { "b" [ 2 ] } { "d" [ 4 ] } } H{ { "a" [ 1 ] } { "c" [ 3 ] } } ] [ + H{ + { "a" [ 1 ] } + { "b" [ 2 ] } + { "c" [ 3 ] } + { "d" [ 4 ] } + } [ nip first even? ] assoc-partition ] unit-test \ No newline at end of file diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor old mode 100644 new mode 100755 index 7f34c3b19d..e46bb7abb6 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -7,22 +7,42 @@ IN: assocs MIXIN: assoc GENERIC: at* ( key assoc -- value/f ? ) +GENERIC: value-at* ( value assoc -- key/f ? ) GENERIC: set-at ( value key assoc -- ) GENERIC: new-assoc ( capacity exemplar -- newassoc ) GENERIC: delete-at ( key assoc -- ) GENERIC: clear-assoc ( assoc -- ) GENERIC: assoc-size ( assoc -- n ) GENERIC: assoc-like ( assoc exemplar -- newassoc ) +GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) +GENERIC: >alist ( assoc -- newassoc ) M: assoc assoc-like drop ; -GENERIC: assoc-clone-like ( assoc exemplar -- newassoc ) - -GENERIC: >alist ( assoc -- newassoc ) +alist ] dip [ first2 ] prepose ; inline +: (assoc-stack) ( key i seq -- value ) + over 0 < [ + 3drop f + ] [ + 3dup nth-unsafe at* + [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if + ] if ; inline recursive + +: search-alist ( key alist -- pair/f i/f ) + [ first = ] with find swap ; inline + +: substituter ( assoc -- quot ) + [ dupd at* [ nip ] [ drop ] if ] curry ; inline + +: with-assoc ( assoc quot: ( value key -- assoc ) -- quot: ( key value -- ) ) + curry [ swap ] prepose ; inline + +PRIVATE> + : assoc-find ( assoc quot -- key value ? ) (assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline @@ -40,23 +60,21 @@ GENERIC: >alist ( assoc -- newassoc ) : assoc-map ( assoc quot -- newassoc ) over assoc-map-as ; inline -: assoc-push-if ( key value quot accum -- ) - [ 2keep ] dip [ [ 2array ] dip push ] 3curry when ; inline - -: assoc-pusher ( quot -- quot' accum ) - V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline - : assoc-filter-as ( assoc quot exemplar -- subassoc ) - [ assoc-pusher [ assoc-each ] dip ] dip assoc-like ; inline + [ (assoc-each) filter ] dip assoc-like ; inline : assoc-filter ( assoc quot -- subassoc ) over assoc-filter-as ; inline -: assoc-contains? ( assoc quot -- ? ) +: assoc-partition ( assoc quot -- true-assoc false-assoc ) + [ (assoc-each) partition ] [ drop ] 2bi + tuck [ assoc-like ] 2bi@ ; inline + +: assoc-any? ( assoc quot -- ? ) assoc-find 2nip ; inline : assoc-all? ( assoc quot -- ? ) - [ not ] compose assoc-contains? not ; inline + [ not ] compose assoc-any? not ; inline : at ( key assoc -- value/f ) at* drop ; inline @@ -65,8 +83,8 @@ GENERIC: >alist ( assoc -- newassoc ) 2dup at* [ 2nip ] [ 2drop ] if ; inline M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) - over assoc-size swap new-assoc - [ [ swapd set-at ] curry assoc-each ] keep ; + [ dup assoc-size ] dip new-assoc + [ [ set-at ] with-assoc assoc-each ] keep ; : keys ( assoc -- keys ) [ drop ] { } assoc>map ; @@ -78,38 +96,28 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) [ at* ] 2keep delete-at ; : rename-at ( newkey key assoc -- ) - [ delete-at* ] keep [ swapd set-at ] curry [ 2drop ] if ; + [ delete-at* ] keep [ set-at ] with-assoc [ 2drop ] if ; : assoc-empty? ( assoc -- ? ) - assoc-size zero? ; - -: (assoc-stack) ( key i seq -- value ) - over 0 < [ - 3drop f - ] [ - 3dup nth-unsafe at* - [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if - ] if ; inline recursive + assoc-size 0 = ; : assoc-stack ( key seq -- value ) [ length 1- ] keep (assoc-stack) ; flushable : assoc-subset? ( assoc1 assoc2 -- ? ) - [ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ; + [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ; : assoc= ( assoc1 assoc2 -- ? ) [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ; : assoc-hashcode ( n assoc -- code ) - [ - [ over ] dip hashcode* 2/ [ dupd hashcode* ] dip bitxor - ] { } assoc>map hashcode* ; + >alist hashcode* ; : assoc-intersect ( assoc1 assoc2 -- intersection ) swap [ nip key? ] curry assoc-filter ; : update ( assoc1 assoc2 -- ) - swap [ swapd set-at ] curry assoc-each ; + swap [ set-at ] with-assoc assoc-each ; : assoc-union ( assoc1 assoc2 -- union ) [ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep @@ -124,9 +132,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : remove-all ( assoc seq -- subseq ) swap [ key? not ] curry filter ; -: substituter ( assoc -- quot ) - [ dupd at* [ nip ] [ drop ] if ] curry ; inline - : substitute-here ( seq assoc -- ) substituter change-each ; @@ -155,8 +160,6 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : extract-keys ( seq assoc -- subassoc ) [ [ dupd at ] curry ] keep map>assoc ; -GENERIC: value-at* ( value assoc -- key/f ? ) - M: assoc value-at* swap [ = nip ] curry assoc-find nip ; : value-at ( value assoc -- key/f ) value-at* drop ; @@ -172,9 +175,6 @@ M: assoc value-at* swap [ = nip ] curry assoc-find nip ; : unzip ( assoc -- keys values ) dup assoc-empty? [ drop { } { } ] [ >alist flip first2 ] if ; -: search-alist ( key alist -- pair/f i/f ) - [ first = ] with find swap ; inline - M: sequence at* search-alist [ second t ] [ f ] if ; @@ -188,7 +188,7 @@ M: sequence new-assoc drop ; M: sequence clear-assoc delete-all ; M: sequence delete-at - tuck search-alist nip + [ nip ] [ search-alist nip ] 2bi [ swap delete-nth ] [ drop ] if* ; M: sequence assoc-size length ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 61d178ccf8..f1e8b8b65e 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -32,17 +32,14 @@ H{ } clone sub-primitives set ! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack ! Bring up a bare cross-compiling vocabulary. -"syntax" vocab vocab-words bootstrap-syntax set -H{ } clone dictionary set -H{ } clone new-classes set -H{ } clone changed-definitions set -H{ } clone changed-generics set -H{ } clone remake-generics set -H{ } clone forgotten-definitions set -H{ } clone root-cache set -H{ } clone source-files set -H{ } clone update-map set -H{ } clone implementors-map set +"syntax" vocab vocab-words bootstrap-syntax set { + dictionary + new-classes + changed-definitions changed-generics + remake-generics forgotten-definitions + root-cache source-files update-map implementors-map +} [ H{ } clone swap set ] each + init-caches ! Vocabulary for slot accessors @@ -264,7 +261,7 @@ bi "vocabulary" { "def" { "quotation" "quotations" } initial: [ ] } "props" - { "compiled" read-only } + { "optimized" read-only } { "counter" { "fixnum" "math" } } { "sub-primitive" read-only } } define-builtin diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 874a9dd0d2..9a40796bda 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -21,6 +21,7 @@ load-help? off ! using the host image's hashing algorithms. We don't ! use each-object here since the catch stack isn't yet ! set up. + gc begin-scan [ hashtable? ] pusher [ (each-object) ] dip end-scan diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index a3662fcaa6..98d36b21c3 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -25,4 +25,4 @@ M: checksum checksum-lines [ normalize-path (file-reader) ] dip checksum-stream ; : hex-string ( seq -- str ) - [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ; + [ >hex 2 CHAR: 0 pad-head ] { } map-as concat ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor old mode 100644 new mode 100755 index 4625c665bf..825cd67a4d --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -66,10 +66,10 @@ DEFER: (class-or) [ members>> ] dip [ class<= ] curry all? ; : right-anonymous-union<= ( first second -- ? ) - members>> [ class<= ] with contains? ; + members>> [ class<= ] with any? ; : left-anonymous-intersection<= ( first second -- ? ) - [ participants>> ] dip [ class<= ] curry contains? ; + [ participants>> ] dip [ class<= ] curry any? ; : right-anonymous-intersection<= ( first second -- ? ) participants>> [ class<= ] with all? ; @@ -125,7 +125,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; ] if ; M: anonymous-union (classes-intersect?) - members>> [ classes-intersect? ] with contains? ; + members>> [ classes-intersect? ] with any? ; M: anonymous-intersection (classes-intersect?) participants>> [ classes-intersect? ] with all? ; @@ -203,7 +203,7 @@ M: anonymous-complement (classes-intersect?) [ class<= ] [ swap class<= ] 2bi and ; : largest-class ( seq -- n elt ) - dup [ [ class< ] with contains? not ] curry find-last + dup [ [ class< ] with any? not ] curry find-last [ "Topological sort failed" throw ] unless* ; : sort-classes ( seq -- newseq ) @@ -215,7 +215,7 @@ M: anonymous-complement (classes-intersect?) : min-class ( class seq -- class/f ) over [ classes-intersect? ] curry filter [ drop f ] [ - tuck [ class<= ] with all? [ peek ] [ drop f ] if + [ nip ] [ [ class<= ] with all? ] 2bi [ peek ] [ drop f ] if ] if-empty ; GENERIC: (flatten-class) ( class -- ) diff --git a/core/classes/builtin/builtin-tests.factor b/core/classes/builtin/builtin-tests.factor old mode 100644 new mode 100755 index 32db9a3d6e..6f990d0d62 --- a/core/classes/builtin/builtin-tests.factor +++ b/core/classes/builtin/builtin-tests.factor @@ -6,5 +6,5 @@ USING: tools.test words sequences kernel memory accessors ; [ [ name>> "f?" = ] [ vocabulary>> "syntax" = ] bi and - ] contains? + ] any? ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index acff3d57e5..8145730f40 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -162,7 +162,7 @@ GENERIC: update-methods ( class seq -- ) dup "predicate" word-prop dup length 1 = [ first - tuck "predicating" word-prop = + [ nip ] [ "predicating" word-prop = ] 2bi [ forget ] [ drop ] if ] [ 2drop ] if ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 2470c00875..1261d44a69 100644 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -54,7 +54,7 @@ TUPLE: check-mixin-class class ; #! class-usages of the member, now that it's been added. [ 2drop ] [ [ [ suffix ] change-mixin-class ] 2keep - tuck [ new-class? ] either? [ + [ nip ] [ [ new-class? ] either? ] 2bi [ update-classes/new ] [ update-classes diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor index d6911576dd..bd2a2ae6a6 100644 --- a/core/classes/singleton/singleton-docs.factor +++ b/core/classes/singleton/singleton-docs.factor @@ -10,18 +10,6 @@ ARTICLE: "singletons" "Singleton classes" { $subsection singleton-class? } { $subsection singleton-class } ; -HELP: SINGLETON: -{ $syntax "SINGLETON: class" } -{ $values - { "class" "a new singleton to define" } -} -{ $description - "Defines a new singleton class. The class word itself is the sole instance of the singleton class." -} -{ $examples - { $example "USING: classes.singleton kernel io ;" "IN: scratchpad" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } -} ; - HELP: define-singleton-class { $values { "word" "a new word" } } { $description diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 5b1844b78b..561d0962ff 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -172,7 +172,7 @@ $nl $nl "The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes." { $heading "Anti-pattern #3: subclassing to override a method definition" } -"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor." +"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of “monkey patching†methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor." { $see-also "parametrized-constructors" } ; ARTICLE: "tuple-subclassing" "Tuple subclassing" @@ -428,5 +428,5 @@ HELP: new HELP: boa { $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } } { $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." } -{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } +{ $notes "The name " { $snippet "boa" } " is shorthand for “by order of argumentsâ€, and “BOA constructor†is a pun on “boa constrictorâ€." } { $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor old mode 100644 new mode 100755 index 3ee9b8e40b..6147dcfbdc --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -79,16 +79,16 @@ M: tuple-class slots>tuple ERROR: bad-superclass class ; -tuple ] [ 2drop f ] if ; + over [ ] any? [ slots>tuple ] [ 2drop f ] if ; : define-tuple-prototype ( class -- ) dup tuple-prototype "prototype" set-word-prop ; @@ -328,7 +328,9 @@ M: tuple clone (clone) ; M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ; -M: tuple hashcode* +GENERIC: tuple-hashcode ( n tuple -- x ) + +M: tuple tuple-hashcode [ [ class hashcode ] [ tuple-size ] [ ] tri [ rot ] dip [ @@ -336,6 +338,8 @@ M: tuple hashcode* ] 2curry each ] recursive-hashcode ; +M: tuple hashcode* tuple-hashcode ; + M: tuple-class new dup "prototype" word-prop [ (clone) ] [ tuple-layout ] ?if ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor old mode 100644 new mode 100755 index 81a0db52be..e0e86e40c0 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -31,7 +31,7 @@ M: union-class update-class define-union-predicate ; M: union-class rank-class drop 2 ; M: union-class instance? - "members" word-prop [ instance? ] with contains? ; + "members" word-prop [ instance? ] with any? ; M: union-class (flatten-class) members (flatten-class) ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor old mode 100644 new mode 100755 index 29a2e7a8bd..c4c18c1c62 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -127,9 +127,9 @@ ERROR: no-case ; : case>quot ( default assoc -- quot ) dup keys { { [ dup empty? ] [ 2drop ] } - { [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] } + { [ dup [ length 4 <= ] [ [ word? ] any? ] bi or ] [ drop linear-case-quot ] } { [ dup contiguous-range? ] [ drop dispatch-case-quot ] } - { [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] } + { [ dup [ wrapper? ] any? not ] [ drop hash-case-quot ] } { [ dup [ wrapper? ] all? ] [ drop [ [ wrapped>> ] dip ] assoc-map hash-case-quot ] } [ drop linear-case-quot ] } cond ; diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index b30e92bbfd..5eafcef94e 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -1,5 +1,6 @@ IN: compiler.units.tests -USING: definitions compiler.units tools.test arrays sequences ; +USING: definitions compiler.units tools.test arrays sequences words kernel +accessors namespaces fry ; [ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test [ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test @@ -7,3 +8,23 @@ USING: definitions compiler.units tools.test arrays sequences ; [ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test [ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test [ called-dependency ] [ called-dependency f strongest-dependency ] unit-test + +! Non-optimizing compiler bugs +[ 1 1 ] [ + "A" "B" [ [ 1 ] dip ] >>def dup f 2array 1array modify-code-heap + 1 swap execute +] unit-test + +[ "A" "B" ] [ + gensym "a" set + gensym "b" set + [ + "a" get [ "A" ] define + "b" get "a" get '[ _ execute ] define + ] with-compilation-unit + "b" get execute + [ + "a" get [ "B" ] define + ] with-compilation-unit + "b" get execute +] unit-test \ No newline at end of file diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 72496a5f76..999b783c48 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -66,9 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- ) dup dup changed-vocabs update ; : compile ( words -- ) - recompile-hook get call - dup [ drop crossref? ] assoc-contains? - modify-code-heap ; + recompile-hook get call modify-code-heap ; SYMBOL: outdated-tuples SYMBOL: update-tuples-hook @@ -145,7 +143,7 @@ SYMBOL: remake-generics-hook call-recompile-hook call-update-tuples-hook unxref-forgotten-definitions - dup [ drop crossref? ] assoc-contains? modify-code-heap ; + modify-code-heap ; : with-nested-compilation-unit ( quot -- ) [ diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index ea3470feb3..2cc44bee1b 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private continuations.private vectors arrays namespaces -assocs words quotations lexer sequences ; +assocs words quotations lexer sequences math ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -26,7 +26,7 @@ ARTICLE: "errors-anti-examples" "Common error handling pitfalls" $nl "In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically." { $heading "Anti-pattern #3: Dropping and rethrowing" } -"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught." +"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught." { $heading "Anti-pattern #4: Logging and rethrowing" } "If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ; @@ -241,12 +241,13 @@ HELP: attempt-all HELP: retry { $values - { "quot" quotation } { "n" null } + { "quot" quotation } { "n" integer } } { $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." } { $examples + "Try to get a 0 as a random number:" { $unchecked-example "USING: continuations math prettyprint ;" - "[ 5 random 0 = ] retry t" + "[ 5 random 0 = ] 5 retry t" "t" } } ; diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 77bcd7cad6..6b7e953b6c 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -9,7 +9,7 @@ DEFER: parse-effect ERROR: bad-effect ; : parse-effect-token ( end -- token/f ) - scan tuck = [ drop f ] [ + scan [ nip ] [ = ] 2bi [ drop f ] [ dup { f "(" "((" } member? [ bad-effect ] [ ":" ?tail [ scan-word { diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor old mode 100644 new mode 100755 index aae76184ff..5465ee1b27 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -141,7 +141,7 @@ M: integer generic-forget-test-1 / ; [ t ] [ \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] contains? + [ name>> "integer=>generic-forget-test-1" = ] any? ] unit-test [ ] [ @@ -150,7 +150,7 @@ M: integer generic-forget-test-1 / ; [ f ] [ \ / usage [ word? ] filter - [ name>> "integer=>generic-forget-test-1" = ] contains? + [ name>> "integer=>generic-forget-test-1" = ] any? ] unit-test GENERIC: generic-forget-test-2 ( a b -- c ) @@ -159,7 +159,7 @@ M: sequence generic-forget-test-2 = ; [ t ] [ \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] contains? + [ name>> "sequence=>generic-forget-test-2" = ] any? ] unit-test [ ] [ @@ -168,7 +168,7 @@ M: sequence generic-forget-test-2 = ; [ f ] [ \ = usage [ word? ] filter - [ name>> "sequence=>generic-forget-test-2" = ] contains? + [ name>> "sequence=>generic-forget-test-2" = ] any? ] unit-test GENERIC: generic-forget-test-3 ( a -- b ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 4eb39291a0..c16b6a52a1 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -36,7 +36,8 @@ PREDICATE: method-spec < pair "methods" word-prop keys sort-classes ; : specific-method ( class generic -- method/f ) - tuck order min-class dup [ swap method ] [ 2drop f ] if ; + [ nip ] [ order min-class ] 2bi + dup [ swap method ] [ 2drop f ] if ; GENERIC: effective-method ( generic -- method ) diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 9268340c79..8aa13a5f5e 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -104,7 +104,7 @@ M: hashtable clear-assoc ( hash -- ) [ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ; M: hashtable delete-at ( key hash -- ) - tuck key@ [ + [ nip ] [ key@ ] 2bi [ [ ((tombstone)) dup ] 2dip set-nth-pair hash-deleted+ ] [ diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index e2c6c3d464..fd5567cfa2 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init kernel system namespaces io io.encodings -io.encodings.utf8 init assocs splitting alien ; +io.encodings.utf8 init assocs splitting alien io.streams.null ; IN: io.backend SYMBOL: io-backend @@ -12,13 +12,22 @@ io-backend global [ c-io-backend or ] change-at HOOK: init-io io-backend ( -- ) -HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ) +HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ? ) + +: set-stdio ( input-handle output-handle error-handle -- ) + [ input-stream set-global ] + [ output-stream set-global ] + [ error-stream set-global ] tri* ; : init-stdio ( -- ) - (init-stdio) - [ utf8 input-stream set-global ] - [ utf8 output-stream set-global ] - [ utf8 error-stream set-global ] tri* ; + (init-stdio) [ + [ utf8 ] + [ utf8 ] + [ utf8 ] tri* + ] [ + 3drop + null-reader null-writer null-writer + ] if set-stdio ; HOOK: io-multiplex io-backend ( us -- ) diff --git a/core/io/encodings/binary/binary-docs.factor b/core/io/encodings/binary/binary-docs.factor deleted file mode 100644 index 4da1e0811f..0000000000 --- a/core/io/encodings/binary/binary-docs.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: help.syntax help.markup ; -IN: io.encodings.binary - -HELP: binary -{ $class-description "Encoding descriptor for binary I/O." } ; - -ARTICLE: "io.encodings.binary" "Binary encoding" -"Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." -{ $subsection binary } ; - -ABOUT: "io.encodings.binary" diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor deleted file mode 100644 index e54163f632..0000000000 --- a/core/io/encodings/binary/binary.factor +++ /dev/null @@ -1,8 +0,0 @@ -! Copyright (C) 2008 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: io.encodings kernel ; -IN: io.encodings.binary - -SINGLETON: binary -M: binary drop ; -M: binary drop ; diff --git a/core/io/encodings/binary/summary.txt b/core/io/encodings/binary/summary.txt deleted file mode 100644 index a1eb4bc664..0000000000 --- a/core/io/encodings/binary/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Dummy encoding for binary I/O diff --git a/core/io/encodings/binary/tags.txt b/core/io/encodings/binary/tags.txt deleted file mode 100644 index 8e27be7d61..0000000000 --- a/core/io/encodings/binary/tags.txt +++ /dev/null @@ -1 +0,0 @@ -text diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index b893e7f717..ed39e74878 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -74,7 +74,7 @@ HELP: replacement-char { $description "A code point that replaces input that could not be decoded. The presence of this character in the decoded data usually signifies an error." } ; ARTICLE: "encodings-descriptors" "Encoding descriptors" -"An encoding descriptor is something which can be used for input or output streams to encode or decode bytes stored in a certain representation. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" +"An encoding descriptor is something which can be used with binary input or output streams to encode or decode bytes stored in a certain representation. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" { $subsection "io.encodings.binary" } { $subsection "io.encodings.utf8" } { $subsection "io.encodings.utf16" } @@ -99,7 +99,13 @@ ARTICLE: "encodings-constructors" "Manually constructing an encoded stream" { $subsection } ; ARTICLE: "io.encodings" "I/O encodings" -"The " { $vocab-link "io.encodings" } " vocabulary provides utilities for encoding and decoding bytes that represent text. Both strings and streams may be encoded." +"The " { $vocab-link "io.encodings" } " vocabulary provides utilities for encoding and decoding bytes that represent text. Encodings can be used in the following situations:" +{ $list + "With binary input streams, to convert bytes to characters" + "With binary output streams, to convert characters to bytes" + "With byte arrays, to convert bytes to characters" + "With strings, to convert characters to bytes" +} { $subsection "encodings-descriptors" } { $subsection "encodings-constructors" } { $subsection "io.encodings.string" } @@ -113,6 +119,7 @@ ARTICLE: "io.encodings" "I/O encodings" { $subsection re-decode } "Combinators to change the encoding:" { $subsection with-encoded-output } -{ $subsection with-decoded-input } ; +{ $subsection with-decoded-input } +{ $see-also "encodings-introduction" "stream-elements" } ; ABOUT: "io.encodings" diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 7948a2e912..cf0aea787b 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io strings arrays io.backend -io.files.private quotations ; +io.files.private quotations sequences ; IN: io.files ARTICLE: "io.files" "Reading and writing files" @@ -22,16 +22,19 @@ ABOUT: "io.files" HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an input stream" } } { $description "Outputs an input stream for reading from the specified pathname using the given encoding." } +{ $notes "Most code should use " { $link with-file-reader } " instead, to ensure the stream is properly disposed of after." } { $errors "Throws an error if the file is unreadable." } ; HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } { $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." } +{ $notes "Most code should use " { $link with-file-writer } " instead, to ensure the stream is properly disposed of after." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } } { $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." } +{ $notes "Most code should use " { $link with-file-appender } " instead, to ensure the stream is properly disposed of after." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: with-file-reader @@ -60,13 +63,13 @@ HELP: file-lines { $errors "Throws an error if the file cannot be opened for reading." } ; HELP: set-file-contents -{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } } -{ $description "Sets the contents of a file to a string with the given encoding." } +{ $values { "seq" sequence } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } } +{ $description "Sets the contents of a file to a sequence with the given encoding." } { $errors "Throws an error if the file cannot be opened for writing." } ; HELP: file-contents -{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } } -{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." } +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" sequence } } +{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a sequence." } { $errors "Throws an error if the file cannot be opened for reading." } ; { set-file-lines file-lines set-file-contents file-contents } related-words diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index d2611d73a9..f9702fd133 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,9 +1,8 @@ USING: tools.test io.files io.files.private io.files.temp io.directories io.encodings.8-bit arrays make system -io.encodings.binary io -threads kernel continuations io.encodings.ascii sequences -strings accessors io.encodings.utf8 math destructors namespaces -; +io.encodings.binary io threads kernel continuations +io.encodings.ascii sequences strings accessors +io.encodings.utf8 math destructors namespaces ; IN: io.files.tests \ exists? must-infer diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 19659ee5bb..1bc282e956 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -25,7 +25,7 @@ HOOK: (file-appender) io-backend ( path -- stream ) : with-file-reader ( path encoding quot -- ) [ ] dip with-input-stream ; inline -: file-contents ( path encoding -- str ) +: file-contents ( path encoding -- seq ) contents ; : with-file-writer ( path encoding quot -- ) @@ -34,7 +34,7 @@ HOOK: (file-appender) io-backend ( path -- stream ) : set-file-lines ( seq path encoding -- ) [ [ print ] each ] with-file-writer ; -: set-file-contents ( str path encoding -- ) +: set-file-contents ( seq path encoding -- ) [ write ] with-file-writer ; : with-file-appender ( path encoding quot -- ) @@ -58,4 +58,4 @@ PRIVATE> 13 getenv cwd prepend-path \ image set-global 14 getenv cwd prepend-path \ vm set-global image parent-directory "resource-path" set-global -] "io.files" add-init-hook \ No newline at end of file +] "io.files" add-init-hook diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index a77031fdd0..d7534ddb50 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax quotations hashtables kernel -classes strings continuations destructors math ; +classes strings continuations destructors math byte-arrays ; IN: io HELP: stream-readln @@ -9,38 +9,38 @@ HELP: stream-readln $io-error ; HELP: stream-read1 -{ $values { "stream" "an input stream" } { "ch/f" "a character or " { $link f } } } -{ $contract "Reads a character of input from the stream. Outputs " { $link f } " on stream exhaustion." } +{ $values { "stream" "an input stream" } { "elt" "an element or " { $link f } } } +{ $contract "Reads an element from the stream. Outputs " { $link f } " on stream exhaustion." } { $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read -{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } } -{ $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } +{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "seq" { $or byte-array string f } } } +{ $contract "Reads " { $snippet "n" } " elements from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } { $notes "Most code only works on one stream at a time and should instead use " { $link read } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read-until -{ $values { "seps" string } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } } -{ $contract "Reads characters from the stream, until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } +{ $values { "seps" string } { "stream" "an input stream" } { "seq" { $or byte-array string f } } { "sep/f" "a character or " { $link f } } } +{ $contract "Reads elements from the stream, until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } { $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read-partial { $values - { "n" integer } { "stream" "an input stream" } - { "str/f" "a string or " { $link f } } } -{ $description "Reads at most " { $snippet "n" } " characters from a stream and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ; + { "n" "a non-negative integer" } { "stream" "an input stream" } + { "seq" { $or byte-array string f } } } +{ $description "Reads at most " { $snippet "n" } " elements from a stream and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ; HELP: stream-write1 -{ $values { "ch" "a character" } { "stream" "an output stream" } } -{ $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $values { "elt" "an element" } { "stream" "an output stream" } } +{ $contract "Writes an element to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } { $notes "Most code only works on one stream at a time and should instead use " { $link write1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-write -{ $values { "str" string } { "stream" "an output stream" } } -{ $contract "Writes a string of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $values { "seq" "a byte array or string" } { "stream" "an output stream" } } +{ $contract "Writes a sequence of elements to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } { $notes "Most code only works on one stream at a time and should instead use " { $link write } "; see " { $link "stdio" } "." } $io-error ; @@ -57,7 +57,6 @@ HELP: stream-nl { $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." } $io-error ; - HELP: stream-print { $values { "str" string } { "stream" "an output stream" } } { $description "Writes a newline-terminated string." } @@ -84,34 +83,32 @@ HELP: readln $io-error ; HELP: read1 -{ $values { "ch/f" "a character or " { $link f } } } -{ $description "Reads a character of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." } +{ $values { "elt" "an element or " { $link f } } } +{ $description "Reads an element from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." } $io-error ; HELP: read -{ $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } } -{ $description "Reads " { $snippet "n" } " characters of input from " { $link input-stream } ". Outputs a truncated string or " { $link f } " on stream exhaustion." } +{ $values { "n" "a non-negative integer" } { "seq" { $or byte-array string f } } } +{ $description "Reads " { $snippet "n" } " elements from " { $link input-stream } ". If there is no input available, outputs " { $link f } ". If there are less than " { $snippet "n" } " elements available, outputs a sequence shorter than " { $snippet "n" } " in length." } $io-error ; HELP: read-until -{ $values { "seps" string } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } } -{ $contract "Reads characters from " { $link input-stream } ". until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } +{ $values { "seps" string } { "seq" { $or byte-array string f } } { "sep/f" "a character or " { $link f } } } +{ $contract "Reads elements from " { $link input-stream } ". until the first occurrence of a separator, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output. In the latter case, the entire stream contents are output, along with " { $link f } "." } $io-error ; HELP: read-partial -{ $values - { "n" null } - { "str/f" null } } -{ $description "Reads at most " { $snippet "n" } " characters from " { $link input-stream } " and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ; +{ $values { "n" integer } { "seq" { $or byte-array string f } } } +{ $description "Reads at most " { $snippet "n" } " elements from " { $link input-stream } " and returns them in a sequence. This word should be used instead of " { $link read } " when processing the entire element a chunk at a time, since on some stream implementations it may be slightly faster." } ; HELP: write1 -{ $values { "ch" "a character" } } -{ $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $values { "elt" "an element" } } +{ $contract "Writes an element to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; HELP: write -{ $values { "str" string } } -{ $description "Writes a string of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $values { "seq" { $or byte-array string f } } } +{ $description "Writes a sequence of elements to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; HELP: flush @@ -123,7 +120,7 @@ HELP: nl $io-error ; HELP: print -{ $values { "string" string } } +{ $values { "str" string } } { $description "Writes a newline-terminated string to " { $link output-stream } "." } $io-error ; @@ -170,9 +167,13 @@ HELP: each-line { $values { "quot" { $quotation "( str -- )" } } } { $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ; +HELP: each-block +{ $values { "quot" { $quotation "( block -- )" } } } +{ $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ; + HELP: contents -{ $values { "stream" "an input stream" } { "str" string } } -{ $description "Reads the entire contents of a stream into a string." } +{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } } +{ $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." } $io-error ; ARTICLE: "stream-protocol" "Stream protocol" @@ -182,20 +183,23 @@ $nl $nl "All streams must implement the " { $link dispose } " word in addition to the stream protocol." $nl -"These words are required for input streams:" +"These words are required for binary and string input streams:" { $subsection stream-read1 } { $subsection stream-read } { $subsection stream-read-until } -{ $subsection stream-readln } { $subsection stream-read-partial } -"These words are required for output streams:" +"This word is only required for string input streams:" +{ $subsection stream-readln } +"These words are required for binary and string output streams:" { $subsection stream-flush } { $subsection stream-write1 } { $subsection stream-write } +"This word is only required for string output streams:" { $subsection stream-nl } +"For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "." { $see-also "io.timeouts" } ; -ARTICLE: "stdio" "Default input and output streams" +ARTICLE: "stdio-motivation" "Motivation for default streams" "Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:" { $list { "Code becomes simpler because there is no need to keep a stream around on the stack." } @@ -230,7 +234,10 @@ ARTICLE: "stdio" "Default input and output streams" "\"data.txt\" utf8 [" " readln number>string read 16 group" "] with-file-reader" -} +} ; + +ARTICLE: "stdio" "Default input and output streams" +{ $subsection "stdio-motivation" } "The default input stream is stored in a dynamically-scoped variable:" { $subsection input-stream } "Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user." @@ -239,8 +246,9 @@ $nl { $subsection read1 } { $subsection read } { $subsection read-until } -{ $subsection readln } { $subsection read-partial } +"If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:" +{ $subsection readln } "A pair of combinators for rebinding the " { $link input-stream } " variable:" { $subsection with-input-stream } { $subsection with-input-stream* } @@ -252,6 +260,8 @@ $nl { $subsection flush } { $subsection write1 } { $subsection write } +"If the default output stream is a string stream (" { $link "stream-elements" } "), lines of text can be written:" +{ $subsection readln } { $subsection print } { $subsection nl } { $subsection bl } @@ -268,17 +278,26 @@ $nl "First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":" { $subsection stream-print } "Processing lines one by one:" -{ $subsection each-line } -"Sluring an entire stream into memory all at once:" { $subsection lines } +{ $subsection each-line } +"Processing blocks of data:" { $subsection contents } +{ $subsection each-block } "Copying the contents of one stream to another:" { $subsection stream-copy } ; +ARTICLE: "stream-elements" "Stream elements" +"There are two types of streams:" +{ $list + { { $strong "Binary streams" } " - the elements are integers between 0 and 255, inclusive; they represent bytes. Reading a sequence of elements produces a " { $link byte-array } "." } + { { $strong "String streams" } " - the elements are non-negative integers, representing Unicode code points. Reading a sequence of elements produces a " { $link string } "." } +} +"Most external streams are binary streams, and can be wrapped in string streams once a suitable encoding has been provided; see " { $link "io.encodings" } "." ; + ARTICLE: "streams" "Streams" -"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium." -$nl -"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "." +"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of elements." +{ $subsection "stream-elements" } +"A stream can either be passed around on the stack or bound to a dynamic variable and used as one of the two implicit " { $emphasis "default streams" } "." { $subsection "stream-protocol" } { $subsection "stdio" } { $subsection "stream-utils" } diff --git a/core/io/io.factor b/core/io/io.factor index a2f6fbb58d..55cc336ef8 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -4,26 +4,18 @@ USING: hashtables generic kernel math namespaces make sequences continuations destructors assocs ; IN: io +GENERIC: stream-read1 ( stream -- elt ) +GENERIC: stream-read ( n stream -- seq ) +GENERIC: stream-read-until ( seps stream -- seq sep/f ) +GENERIC: stream-read-partial ( n stream -- seq ) GENERIC: stream-readln ( stream -- str/f ) -GENERIC: stream-read1 ( stream -- ch/f ) -GENERIC: stream-read ( n stream -- str/f ) -GENERIC: stream-read-until ( seps stream -- str/f sep/f ) -GENERIC: stream-read-partial ( n stream -- str/f ) -GENERIC: stream-write1 ( ch stream -- ) -GENERIC: stream-write ( str stream -- ) + +GENERIC: stream-write1 ( elt stream -- ) +GENERIC: stream-write ( seq stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) -: stream-print ( str stream -- ) - [ stream-write ] keep stream-nl ; - -: (stream-copy) ( in out -- ) - 64 1024 * pick stream-read-partial - [ over stream-write (stream-copy) ] [ 2drop ] if* ; - -: stream-copy ( in out -- ) - [ 2dup (stream-copy) ] [ dispose dispose ] [ ] - cleanup ; +: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; ! Default streams SYMBOL: input-stream @@ -31,13 +23,13 @@ SYMBOL: output-stream SYMBOL: error-stream : readln ( -- str/f ) input-stream get stream-readln ; -: read1 ( -- ch/f ) input-stream get stream-read1 ; -: read ( n -- str/f ) input-stream get stream-read ; -: read-until ( seps -- str/f sep/f ) input-stream get stream-read-until ; -: read-partial ( n -- str/f ) input-stream get stream-read-partial ; +: read1 ( -- elt ) input-stream get stream-read1 ; +: read ( n -- seq ) input-stream get stream-read ; +: read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; +: read-partial ( n -- seq ) input-stream get stream-read-partial ; -: write1 ( ch -- ) output-stream get stream-write1 ; -: write ( str -- ) output-stream get stream-write ; +: write1 ( elt -- ) output-stream get stream-write1 ; +: write ( seq -- ) output-stream get stream-write ; : flush ( -- ) output-stream get stream-flush ; : nl ( -- ) output-stream get stream-nl ; @@ -62,17 +54,32 @@ SYMBOL: error-stream [ [ drop dispose dispose ] 3curry ] 3bi [ ] cleanup ; inline -: print ( string -- ) output-stream get stream-print ; +: print ( str -- ) output-stream get stream-print ; : bl ( -- ) " " write ; : lines ( stream -- seq ) [ [ readln dup ] [ ] [ drop ] produce ] with-input-stream ; -: each-line ( quot -- ) - [ [ readln dup ] ] dip [ drop ] while ; inline + + +: each-line ( quot -- ) + [ readln ] each-morsel ; inline + +: contents ( stream -- seq ) [ - [ 65536 read dup ] [ ] [ drop ] produce concat f like + [ 65536 read-partial dup ] + [ ] [ drop ] produce concat f like ] with-input-stream ; + +: each-block ( quot: ( block -- ) -- ) + [ 8192 read-partial ] each-morsel ; inline + +: stream-copy ( in out -- ) + [ [ [ write ] each-block ] with-output-stream ] + curry with-input-stream ; \ No newline at end of file diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index e81d8c2bfd..1673e73083 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -10,11 +10,11 @@ SYMBOL: current-directory : path-separator ( -- string ) os windows? "\\" "/" ? ; -: trim-right-separators ( str -- newstr ) - [ path-separator? ] trim-right ; +: trim-tail-separators ( str -- newstr ) + [ path-separator? ] trim-tail ; -: trim-left-separators ( str -- newstr ) - [ path-separator? ] trim-left ; +: trim-head-separators ( str -- newstr ) + [ path-separator? ] trim-head ; : last-path-separator ( path -- n ? ) [ length 1- ] keep [ path-separator? ] find-last-from ; @@ -28,7 +28,7 @@ ERROR: no-parent-directory path ; : parent-directory ( path -- parent ) dup root-directory? [ - trim-right-separators + trim-tail-separators dup last-path-separator [ 1+ cut ] [ @@ -55,7 +55,7 @@ ERROR: no-parent-directory path ; : append-path-empty ( path1 path2 -- path' ) { { [ dup head.? ] [ - rest trim-left-separators append-path-empty + rest trim-head-separators append-path-empty ] } { [ dup head..? ] [ drop no-parent-directory ] } [ nip ] @@ -84,19 +84,19 @@ PRIVATE> { { [ over empty? ] [ append-path-empty ] } { [ dup empty? ] [ drop ] } - { [ over trim-right-separators "." = ] [ nip ] } + { [ over trim-tail-separators "." = ] [ nip ] } { [ dup absolute-path? ] [ nip ] } - { [ dup head.? ] [ rest trim-left-separators append-path ] } + { [ dup head.? ] [ rest trim-head-separators append-path ] } { [ dup head..? ] [ - 2 tail trim-left-separators + 2 tail trim-head-separators [ parent-directory ] dip append-path ] } { [ over absolute-path? over first path-separator? and ] [ [ 2 head ] dip append ] } [ - [ trim-right-separators "/" ] dip - trim-left-separators 3append + [ trim-tail-separators "/" ] dip + trim-head-separators 3append ] } cond ; @@ -105,7 +105,7 @@ PRIVATE> : file-name ( path -- string ) dup root-directory? [ - trim-right-separators + trim-tail-separators dup last-path-separator [ 1+ tail ] [ drop "resource:" ?head [ file-name ] when ] if @@ -121,7 +121,7 @@ GENERIC: (normalize-path) ( path -- path' ) M: string (normalize-path) "resource:" ?head [ - trim-left-separators resource-path + trim-head-separators resource-path (normalize-path) ] [ current-directory get prepend-path @@ -140,4 +140,4 @@ M: pathname <=> [ string>> ] compare ; HOOK: home io-backend ( -- dir ) -M: object home "" resource-path ; \ No newline at end of file +M: object home "" resource-path ; diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 71c9ffd7d9..a93602533d 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -65,7 +65,7 @@ M: c-io-backend init-io ; stdout-handle stderr-handle ; -M: c-io-backend (init-stdio) init-c-stdio ; +M: c-io-backend (init-stdio) init-c-stdio t ; M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ; diff --git a/basis/io/streams/null/authors.txt b/core/io/streams/null/authors.txt similarity index 100% rename from basis/io/streams/null/authors.txt rename to core/io/streams/null/authors.txt diff --git a/basis/io/streams/null/null-docs.factor b/core/io/streams/null/null-docs.factor similarity index 100% rename from basis/io/streams/null/null-docs.factor rename to core/io/streams/null/null-docs.factor diff --git a/basis/io/streams/null/null-tests.factor b/core/io/streams/null/null-tests.factor similarity index 100% rename from basis/io/streams/null/null-tests.factor rename to core/io/streams/null/null-tests.factor diff --git a/basis/io/streams/null/null.factor b/core/io/streams/null/null.factor similarity index 62% rename from basis/io/streams/null/null.factor rename to core/io/streams/null/null.factor index a2224ef306..98729c7abd 100644 --- a/basis/io/streams/null/null.factor +++ b/core/io/streams/null/null.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io io.timeouts io.styles destructors ; +USING: kernel io destructors io.streams.plain ; IN: io.streams.null SINGLETONS: null-reader null-writer ; UNION: null-stream null-reader null-writer ; +INSTANCE: null-writer plain-writer M: null-stream dispose drop ; -M: null-stream set-timeout 2drop ; M: null-reader stream-readln drop f ; M: null-reader stream-read1 drop f ; @@ -16,16 +16,10 @@ M: null-reader stream-read 2drop f ; M: null-writer stream-write1 2drop ; M: null-writer stream-write 2drop ; -M: null-writer stream-nl drop ; M: null-writer stream-flush drop ; -M: null-writer stream-format 3drop ; -M: null-writer make-span-stream nip ; -M: null-writer make-block-stream nip ; -M: null-writer make-cell-stream nip ; -M: null-writer stream-write-table 3drop ; : with-null-reader ( quot -- ) null-reader swap with-input-stream* ; inline : with-null-writer ( quot -- ) - null-writer swap with-output-stream* ; inline \ No newline at end of file + null-writer swap with-output-stream* ; inline diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 7a53ff5172..d85a51edff 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -888,9 +888,9 @@ $nl "Here is an array containing the " { $link f } " class:" { $example "{ POSTPONE: f } ." "{ POSTPONE: f }" } "The " { $link f } " object is an instance of the " { $link f } " class:" -{ $example "f class ." "POSTPONE: f" } +{ $example "USE: classes" "f class ." "POSTPONE: f" } "The " { $link f } " class is an instance of " { $link word } ":" -{ $example "\\ f class ." "word" } +{ $example "USE: classes" "\\ f class ." "word" } "On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of." { $example "t \\ t eq? ." "t" } "Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ; @@ -929,7 +929,7 @@ ARTICLE: "conditionals" "Conditionals and logic" { $see-also "booleans" "bitwise-arithmetic" both? either? } ; ARTICLE: "equality" "Equality" -"There are two distinct notions of ``sameness'' when it comes to objects." +"There are two distinct notions of “sameness†when it comes to objects." $nl "You can test if two references point to the same object (" { $emphasis "identity comparison" } "). This is rarely used; it is mostly useful with large, mutable objects where the object identity matters but the value is transient:" { $subsection eq? } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index a8f9281760..be1de76650 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel.private slots.private classes.tuple.private ; +USING: kernel.private slots.private math.private +classes.tuple.private ; IN: kernel DEFER: dip @@ -154,7 +155,6 @@ TUPLE: identity-tuple ; M: identity-tuple equal? 2drop f ; -USE: math.private : = ( obj1 obj2 -- ? ) 2dup eq? [ 2drop t ] [ 2dup both-fixnums? [ 2drop f ] [ equal? ] if diff --git a/core/math/integers/integers-docs.factor b/core/math/integers/integers-docs.factor index c75040b6bb..26c7e03fba 100644 --- a/core/math/integers/integers-docs.factor +++ b/core/math/integers/integers-docs.factor @@ -4,10 +4,10 @@ IN: math.integers ARTICLE: "integers" "Integers" { $subsection integer } "Integers come in two varieties -- fixnums and bignums. Fixnums fit in a machine word and are faster to manipulate; if the result of a fixnum operation is too large to fit in a fixnum, the result is upgraded to a bignum. Here is an example where two fixnums are multiplied yielding a bignum:" -{ $example "134217728 class ." "fixnum" } -{ $example "128 class ." "fixnum" } +{ $example "USE: classes" "134217728 class ." "fixnum" } +{ $example "USE: classes" "128 class ." "fixnum" } { $example "134217728 128 * ." "17179869184" } -{ $example "134217728 128 * class ." "bignum" } +{ $example "USE: classes" "1 128 shift class ." "bignum" } "Integers can be entered using a different base; see " { $link "syntax-numbers" } "." $nl "Integers can be tested for, and real numbers can be converted to integers:" diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 348d27ba0f..7d0666328f 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -143,7 +143,7 @@ HELP: bitxor HELP: shift { $values { "x" integer } { "n" integer } { "y" integer } } -{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." } +{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits “falling off†the right hand side and being discarded." } { $examples { $example "USING: math prettyprint ;" "BIN: 101 5 shift .b" "10100000" } { $example "USING: math prettyprint ;" "BIN: 11111 -2 shift .b" "111" } } ; HELP: bitnot @@ -321,8 +321,8 @@ ARTICLE: "number-protocol" "Number protocol" "Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float." $nl "Two examples where you should note the types of the inputs and outputs:" -{ $example "3 >fixnum 6 >bignum * class ." "bignum" } -{ $example "1/2 2.0 + ." "4.5" } +{ $example "USE: classes" "3 >fixnum 6 >bignum * class ." "bignum" } +{ $example "1/2 2.0 + ." "2.5" } "The following usual operations are supported by all numbers." { $subsection + } { $subsection - } diff --git a/core/memory/memory-docs.factor b/core/memory/memory-docs.factor index bfe26823be..eb2968ece7 100644 --- a/core/memory/memory-docs.factor +++ b/core/memory/memory-docs.factor @@ -3,7 +3,7 @@ quotations math ; IN: memory HELP: begin-scan ( -- ) -{ $description "Moves all objects to tenured space, disables the garbage collector, and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects." +{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects." $nl "This word must always be paired with a call to " { $link end-scan } "." } { $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ; diff --git a/core/memory/memory.factor b/core/memory/memory.factor index b67f7c94e8..4b873ef6ec 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -9,7 +9,7 @@ IN: memory ] [ 2drop ] if ; inline recursive : each-object ( quot -- ) - begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline + gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline : count-instances ( quot -- n ) 0 swap [ 1 0 ? + ] compose each-object ; inline diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 4da76468e8..23bc41a1bb 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -41,7 +41,7 @@ ARTICLE: "defining-words" "Defining words" { $subsection parse-definition } "The " { $link POSTPONE: ; } " word is just a delimiter; an unpaired occurrence throws a parse error:" { $see POSTPONE: ; } -"There are additional parsing words whose syntax is delimited by " { $link POSTPONE: ; } ", and they are all implemented by calling " { $link parse-definition } "." ; +"There are additional parsing words whose syntax is delimited by " { $link POSTPONE: ; } ", and they are all implemented by calling " { $link parse-definition } "." ; ARTICLE: "parsing-tokens" "Parsing raw tokens" "So far we have seen how to read individual tokens, or read a sequence of parsed objects until a delimiter. It is also possible to read raw tokens from the input and perform custom processing." diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 81ed91290c..4be7cfa891 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -57,7 +57,7 @@ SYMBOL: auto-use? dup vocabulary>> [ (use+) ] [ amended-use get dup [ push ] [ 2drop ] if ] - [ "Added ``" "'' vocabulary to search path" surround note. ] + [ "Added \"" "\" vocabulary to search path" surround note. ] tri ] [ create-in ] if ; @@ -160,6 +160,7 @@ SYMBOL: interactive-vocabs "definitions" "editors" "help" + "help.lint" "inspector" "io" "io.files" @@ -200,7 +201,7 @@ SYMBOL: interactive-vocabs SYMBOL: print-use-hook print-use-hook global [ [ ] or ] change-at -! + : parse-fresh ( lines -- quot ) [ V{ } clone amended-use set @@ -254,7 +255,7 @@ print-use-hook global [ [ ] or ] change-at [ [ lines dup parse-fresh - tuck finish-parsing + [ nip ] [ finish-parsing ] 2bi forget-smudged ] with-source-file ] with-compilation-unit ; diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 1a16d0f92a..f2629a36c4 100644 --- a/core/quotations/quotations-docs.factor +++ b/core/quotations/quotations-docs.factor @@ -14,6 +14,10 @@ $nl "Quotations implement the " { $link "sequence-protocol" } ", and existing sequences can be converted into quotations:" { $subsection >quotation } { $subsection 1quotation } +"Wrappers:" +{ $subsection "wrappers" } ; + +ARTICLE: "wrappers" "Wrappers" "Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:" { $subsection wrapper } { $subsection literalize } diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor old mode 100644 new mode 100755 index ea7cf829c4..f213be4fe7 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -393,7 +393,7 @@ HELP: find-last-from { $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } } { $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ; -HELP: contains? +HELP: any? { $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } } { $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ; @@ -575,15 +575,15 @@ HELP: padding { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" { $quotation "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } } { $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ; -HELP: pad-left +HELP: pad-head { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } } { $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the left with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." } -{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-left print ] each" "---ab\n-quux" } } ; +{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-head print ] each" "---ab\n-quux" } } ; -HELP: pad-right +HELP: pad-tail { $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } } { $description "Outputs a new sequence consisting of " { $snippet "seq" } " padded on the right with enough repetitions of " { $snippet "elt" } " to have the result be of length " { $snippet "n" } "." } -{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-right print ] each" "ab---\nquux-" } } ; +{ $examples { $example "USING: io sequences ;" "{ \"ab\" \"quux\" } [ 5 CHAR: - pad-tail print ] each" "ab---\nquux-" } } ; HELP: sequence= { $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } } @@ -960,43 +960,43 @@ HELP: pusher } { $notes "Used to implement the " { $link filter } " word." } ; -HELP: trim-left +HELP: trim-head { $values { "seq" sequence } { "quot" quotation } { "newseq" sequence } } { $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." } { $example "" "USING: prettyprint math sequences ;" - "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left ." + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-head ." "{ 1 2 3 0 0 }" } ; -HELP: trim-left-slice +HELP: trim-head-slice { $values { "seq" sequence } { "quot" quotation } { "slice" slice } } { $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice" } { $example "" "USING: prettyprint math sequences ;" - "{ 0 0 1 2 3 0 0 } [ zero? ] trim-left-slice ." + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-head-slice ." "T{ slice { from 2 } { to 7 } { seq { 0 0 1 2 3 0 0 } } }" } ; -HELP: trim-right +HELP: trim-tail { $values { "seq" sequence } { "quot" quotation } { "newseq" sequence } } { $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." } { $example "" "USING: prettyprint math sequences ;" - "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right ." + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail ." "{ 0 0 1 2 3 }" } ; -HELP: trim-right-slice +HELP: trim-tail-slice { $values { "seq" sequence } { "quot" quotation } { "slice" slice } } { $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a slice." } { $example "" "USING: prettyprint math sequences ;" - "{ 0 0 1 2 3 0 0 } [ zero? ] trim-right-slice ." + "{ 0 0 1 2 3 0 0 } [ zero? ] trim-tail-slice ." "T{ slice { from 0 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }" } ; @@ -1020,7 +1020,7 @@ HELP: trim-slice "T{ slice { from 2 } { to 5 } { seq { 0 0 1 2 3 0 0 } } }" } ; -{ trim trim-slice trim-left trim-left-slice trim-right trim-right-slice } related-words +{ trim trim-slice trim-head trim-head-slice trim-tail trim-tail-slice } related-words HELP: sift { $values @@ -1407,8 +1407,8 @@ ARTICLE: "sequences-appending" "Appending sequences" { $subsection concat } { $subsection join } "A pair of words useful for aligning strings:" -{ $subsection pad-left } -{ $subsection pad-right } ; +{ $subsection pad-head } +{ $subsection pad-tail } ; ARTICLE: "sequences-slices" "Subsequences and slices" "Extracting a subsequence:" @@ -1463,7 +1463,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators" { $subsection push-if } { $subsection filter } "Testing if a sequence contains elements satisfying a predicate:" -{ $subsection contains? } +{ $subsection any? } { $subsection all? } { $subsection "sequence-2combinators" } { $subsection "sequence-3combinators" } ; @@ -1513,12 +1513,12 @@ ARTICLE: "sequences-search" "Searching sequences" ARTICLE: "sequences-trimming" "Trimming sequences" "Trimming words:" { $subsection trim } -{ $subsection trim-left } -{ $subsection trim-right } +{ $subsection trim-head } +{ $subsection trim-tail } "Potentially more efficient trim:" { $subsection trim-slice } -{ $subsection trim-left-slice } -{ $subsection trim-right-slice } ; +{ $subsection trim-head-slice } +{ $subsection trim-tail-slice } ; ARTICLE: "sequences-destructive-discussion" "When to use destructive operations" "Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:" diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 85c4636822..4ee860f384 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -225,13 +225,13 @@ unit-test [ -1./0. 0 delete-nth ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test -[ "" ] [ "" [ CHAR: \s = ] trim-left ] unit-test -[ "" ] [ "" [ CHAR: \s = ] trim-right ] unit-test -[ "" ] [ " " [ CHAR: \s = ] trim-left ] unit-test -[ "" ] [ " " [ CHAR: \s = ] trim-right ] unit-test +[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test +[ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test +[ "" ] [ " " [ CHAR: \s = ] trim-head ] unit-test +[ "" ] [ " " [ CHAR: \s = ] trim-tail ] unit-test [ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test -[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-left ] unit-test -[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-right ] unit-test +[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test +[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test [ 328350 ] [ 100 [ sq ] sigma ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor old mode 100644 new mode 100755 index 061da05669..2c30a62fe3 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -138,15 +138,15 @@ INSTANCE: iota immutable-sequence : from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline : (2sequence) ( obj1 obj2 seq -- seq ) - tuck 1 swap set-nth-unsafe - tuck 0 swap set-nth-unsafe ; inline + [ 1 swap set-nth-unsafe ] keep + [ 0 swap set-nth-unsafe ] keep ; inline : (3sequence) ( obj1 obj2 obj3 seq -- seq ) - tuck 2 swap set-nth-unsafe + [ 2 swap set-nth-unsafe ] keep (2sequence) ; inline : (4sequence) ( obj1 obj2 obj3 obj4 seq -- seq ) - tuck 3 swap set-nth-unsafe + [ 3 swap set-nth-unsafe ] keep (3sequence) ; inline PRIVATE> @@ -524,14 +524,14 @@ PRIVATE> : nths ( indices seq -- seq' ) [ nth ] curry map ; -: contains? ( seq quot -- ? ) +: any? ( seq quot -- ? ) find drop >boolean ; inline : member? ( elt seq -- ? ) - [ = ] with contains? ; + [ = ] with any? ; : memq? ( elt seq -- ? ) - [ eq? ] with contains? ; + [ eq? ] with any? ; : remove ( elt seq -- newseq ) [ = not ] with filter ; @@ -711,10 +711,10 @@ PRIVATE> [ ] curry ] dip compose if ; inline -: pad-left ( seq n elt -- padded ) +: pad-head ( seq n elt -- padded ) [ swap dup append-as ] padding ; -: pad-right ( seq n elt -- padded ) +: pad-tail ( seq n elt -- padded ) [ append ] padding ; : shorter? ( seq1 seq2 -- ? ) [ length ] bi@ < ; @@ -723,14 +723,14 @@ PRIVATE> 2dup shorter? [ 2drop f ] [ - tuck length head-slice sequence= + [ nip ] [ length head-slice ] 2bi sequence= ] if ; : tail? ( seq end -- ? ) 2dup shorter? [ 2drop f ] [ - tuck length tail-slice* sequence= + [ nip ] [ length tail-slice* ] 2bi sequence= ] if ; : cut-slice ( seq n -- before-slice after-slice ) @@ -816,22 +816,22 @@ PRIVATE> dup slice? [ { } like ] when 0 over length rot ; inline -: trim-left-slice ( seq quot -- slice ) +: trim-head-slice ( seq quot -- slice ) over [ [ not ] compose find drop ] dip swap [ tail-slice ] [ dup length tail-slice ] if* ; inline -: trim-left ( seq quot -- newseq ) - over [ trim-left-slice ] dip like ; inline +: trim-head ( seq quot -- newseq ) + over [ trim-head-slice ] dip like ; inline -: trim-right-slice ( seq quot -- slice ) +: trim-tail-slice ( seq quot -- slice ) over [ [ not ] compose find-last drop ] dip swap [ 1+ head-slice ] [ 0 head-slice ] if* ; inline -: trim-right ( seq quot -- newseq ) - over [ trim-right-slice ] dip like ; inline +: trim-tail ( seq quot -- newseq ) + over [ trim-tail-slice ] dip like ; inline : trim-slice ( seq quot -- slice ) - [ trim-left-slice ] [ trim-right-slice ] bi ; inline + [ trim-head-slice ] [ trim-tail-slice ] bi ; inline : trim ( seq quot -- newseq ) over [ trim-slice ] dip like ; inline diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor old mode 100644 new mode 100755 index 428bf10401..a122aa1240 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -22,7 +22,7 @@ $nl "Adding elements to sets:" { $subsection adjoin } { $subsection conjoin } -{ $see-also member? memq? contains? all? "assocs-sets" } ; +{ $see-also member? memq? any? all? "assocs-sets" } ; ABOUT: "sets" diff --git a/core/sets/sets.factor b/core/sets/sets.factor old mode 100644 new mode 100755 index 3435298f6e..062b624e8f --- a/core/sets/sets.factor +++ b/core/sets/sets.factor @@ -41,7 +41,7 @@ PRIVATE> tester filter ; : intersects? ( seq1 seq2 -- ? ) - tester contains? ; + tester any? ; : diff ( seq1 seq2 -- newseq ) tester [ not ] compose filter ; diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index c9ce334388..bdc5a5ba07 100644 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -84,10 +84,9 @@ $nl { $subsection initial-value } ; ARTICLE: "slots" "Slots" -"A " { $emphasis "slot" } " is a component of an object which can store a value." +"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object. A " { $emphasis "slot" } " is a component of an object which can store a value." $nl { $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data." -"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object." $nl "The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance." { $subsection slot-spec } diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index 88e47d5309..d40cd982d8 100644 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -4,7 +4,7 @@ sbufs math ; IN: strings ARTICLE: "strings" "Strings" -"A string is a fixed-size mutable sequence of Unicode 5.0 code points." +"A string is a fixed-size mutable sequence of Unicode 5.1 code points." $nl "Characters are not a first-class type; they are simply represented as integers between 0 and 16777216 (2^24). Only characters up to 2097152 (2^21) have a defined meaning in Unicode." $nl @@ -22,9 +22,8 @@ $nl { $subsection 1string } "Since strings are sequences, basic string manipulation can be performed using sequence operations (" { $link "sequences" } "). More advanced functionality can be found in other vocabularies, including but not limited to:" { $list - { { $vocab-link "ascii" } " - traditional ASCII character classes" } - { { $vocab-link "unicode.categories" } " - Unicode character classes" } - { { $vocab-link "unicode.case" } " - Unicode case conversion" } + { { $link "ascii" } " - ASCII algorithms for interoperability with legacy applications" } + { { $link "unicode" } " - Unicode algorithms for modern multilingual applications" } { { $vocab-link "regexp" } " - regular expressions" } { { $vocab-link "peg" } " - parser expression grammars" } } ; diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 810e9051d8..5b71b13552 100644 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -43,8 +43,8 @@ IN: strings.tests ] unit-test -[ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test -[ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test +[ "05" ] [ "5" 2 CHAR: 0 pad-head ] unit-test +[ "666" ] [ "666" 2 CHAR: 0 pad-head ] unit-test [ 1 "" nth ] must-fail [ -6 "hello" nth ] must-fail diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 36f427d5ad..e08821bddd 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -5,7 +5,7 @@ assocs words.symbol words.alias words.constant ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" -"At the most abstract level, Factor syntax consists of whitespace-separated tokens. The parser tokenizes the input on whitespace boundaries. The parser is case-sensitive and whitespace between tokens is significant, so the following three expressions tokenize differently:" +"At the most abstract level, Factor syntax consists of whitespace-separated tokens. The parser tokenizes the input on whitespace boundaries. The parser is case-sensitive and whitespace between tokens is significant, so the following three expressions tokenize differently:" { $code "2X+\n2 X +\n2 x +" } "As the parser reads tokens it makes a distinction between numbers, ordinary words, and parsing words. Tokens are appended to the parse tree, the top level of which is a quotation returned by the original parser invocation. Nested levels of the parse tree are created by parsing words." $nl @@ -69,7 +69,7 @@ ARTICLE: "syntax-floats" "Float syntax" "More information on floats can be found in " { $link "floats" } "." ; ARTICLE: "syntax-complex-numbers" "Complex number syntax" -"A complex number is given by two components, a ``real'' part and ''imaginary'' part. The components must either be integers, ratios or floats." +"A complex number is given by two components, a “real†part and “imaginary†part. The components must either be integers, ratios or floats." { $code "C{ 1/2 1/3 } ! the complex number 1/2+1/3i" "C{ 0 1 } ! the imaginary unit" @@ -149,7 +149,7 @@ ARTICLE: "syntax-pathnames" "Pathname syntax" ARTICLE: "syntax-literals" "Literals" "Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words." $nl -"If a quotation contains a literal object, the same literal object instance is used each time the quotation executes; that is, literals are ``live''." +"If a quotation contains a literal object, the same literal object instance is used each time the quotation executes; that is, literals are “liveâ€." $nl "Using mutable object literals in word definitions requires care, since if those objects are mutated, the actual word definition will be changed, which is in most cases not what you would expect. Literals should be " { $link clone } "d before being passed to word which may potentially mutate them." { $subsection "syntax-numbers" } @@ -352,6 +352,18 @@ HELP: SYMBOLS: { $description "Creates a new symbol for every token until the " { $snippet ";" } "." } { $examples { $example "USING: prettyprint ;" "IN: scratchpad" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } ; +HELP: SINGLETON: +{ $syntax "SINGLETON: class" } +{ $values + { "class" "a new singleton to define" } +} +{ $description + "Defines a new singleton class. The class word itself is the sole instance of the singleton class." +} +{ $examples + { $example "USING: classes.singleton kernel io ;" "IN: singleton-demo" "USE: prettyprint SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" } +} ; + HELP: SINGLETONS: { $syntax "SINGLETONS: words... ;" } { $values { "words" "a sequence of new words to define" } } @@ -545,7 +557,7 @@ HELP: GENERIC: HELP: GENERIC# { $syntax "GENERIC# word n" } -{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on, either 0, 1 or 2" } } +{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } } { $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } { $notes "The following two definitions are equivalent:" @@ -604,7 +616,7 @@ HELP: MIXIN: HELP: INSTANCE: { $syntax "INSTANCE: instance mixin" } -{ $values { "instance" "a class word" } { "instance" "a class word" } } +{ $values { "instance" "a class word" } { "mixin" "a mixin class word" } } { $description "Makes " { $snippet "instance" } " an instance of " { $snippet "mixin" } "." } ; HELP: PREDICATE: diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index c81fc9201e..af5fa38aeb 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -103,7 +103,7 @@ IN: bootstrap.syntax "W{" [ \ } [ first ] parse-literal ] define-syntax "POSTPONE:" [ scan-word parsed ] define-syntax - "\\" [ scan-word literalize parsed ] define-syntax + "\\" [ scan-word parsed ] define-syntax "inline" [ word make-inline ] define-syntax "recursive" [ word make-recursive ] define-syntax "foldable" [ word make-foldable ] define-syntax diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 13f79b04ec..fb9ce54672 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -11,7 +11,7 @@ name words main help source-loaded? docs-loaded? ; -! sources-loaded? slot is one of these two +! sources-loaded? slot is one of these three SYMBOL: +parsing+ SYMBOL: +running+ SYMBOL: +done+ diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor old mode 100644 new mode 100755 index 10c17a0e79..a22b6a5b97 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -188,7 +188,7 @@ SYMBOL: quot-uses-b [ all-words [ "compiled-uses" word-prop - keys [ "forgotten" word-prop ] contains? + keys [ "forgotten" word-prop ] any? ] filter ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor old mode 100644 new mode 100755 index 6a3b63ab8a..3197d0a6f6 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -144,7 +144,7 @@ SYMBOL: visited crossref get at keys [ word? ] filter [ - [ reset-on-redefine [ word-prop ] with contains? ] + [ reset-on-redefine [ word-prop ] with any? ] [ inline? ] bi or ] filter diff --git a/extra/4DNav/4DNav-docs.factor b/extra/4DNav/4DNav-docs.factor index d4bf1db87d..6d7ebe4cfc 100755 --- a/extra/4DNav/4DNav-docs.factor +++ b/extra/4DNav/4DNav-docs.factor @@ -1,212 +1,64 @@ ! Copyright (C) 2008 Jean-François Bigot. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel quotations strings ; +USING: help.markup help.syntax kernel quotations strings multiline ; IN: 4DNav -HELP: (mvt-4D) -{ $values - { "quot" quotation } -} -{ $description "" } ; - -HELP: 4D-Rxw -{ $values - { "angle" null } - { "Rz" null } -} -{ $description "" } ; - -HELP: 4D-Rxy -{ $values - { "angle" null } - { "Rx" null } -} -{ $description "" } ; - -HELP: 4D-Rxz -{ $values - { "angle" null } - { "Ry" null } -} -{ $description "" } ; - -HELP: 4D-Ryw -{ $values - { "angle" null } - { "Ry" null } -} -{ $description "" } ; - -HELP: 4D-Ryz -{ $values - { "angle" null } - { "Rx" null } -} -{ $description "" } ; - -HELP: 4D-Rzw -{ $values - { "angle" null } - { "Rz" null } -} -{ $description "" } ; - -HELP: 4DNav -{ $description "" } ; - -HELP: >observer3d -{ $values - { "value" null } -} -{ $description "" } ; - -HELP: >present-space -{ $values - { "value" null } -} -{ $description "" } ; - - -HELP: >view1 -{ $values - { "value" null } -} -{ $description "" } ; - -HELP: >view2 -{ $values - { "value" null } -} -{ $description "" } ; - -HELP: >view3 -{ $values - { "value" null } -} -{ $description "" } ; - -HELP: >view4 -{ $values - { "value" null } -} -{ $description "" } ; - -HELP: add-keyboard-delegate -{ $values - { "obj" object } - { "obj" object } -} -{ $description "" } ; - -HELP: button* -{ $values - { "string" string } { "quot" quotation } - { "button" null } -} -{ $description "" } ; - -HELP: camera-action -{ $values - { "quot" quotation } - { "quot" quotation } -} -{ $description "" } ; - -HELP: camera-button -{ $values - { "string" string } { "quot" quotation } - { "button" null } -} -{ $description "" } ; - -HELP: controller-window* -{ $values - { "gadget" "a gadget" } -} -{ $description "" } ; - - -HELP: init-models -{ $description "" } ; - -HELP: init-variables -{ $description "" } ; HELP: menu-3D { $values - { "gadget" null } + { "gadget" "gadget" } } { $description "The menu dedicated to 3D movements of the camera" } ; HELP: menu-4D { $values - { "gadget" null } + { "gadget" "gadget" } } { $description "The menu dedicated to 4D movements of space" } ; HELP: menu-bar { $values - { "gadget" null } + { "gadget" "gadget" } } { $description "return gadget containing menu buttons" } ; HELP: model-projection { $values - { "x" null } - { "space" null } + { "x" "interger" } + { "space" "space" } } { $description "Project space following coordinate x" } ; HELP: mvt-3D-1 { $values - { "quot" quotation } + { "quot" "quotation" } } { $description "return a quotation to orientate space to see it from first point of view" } ; HELP: mvt-3D-2 { $values - { "quot" quotation } + { "quot" "quotation" } } { $description "return a quotation to orientate space to see it from second point of view" } ; HELP: mvt-3D-3 { $values - { "quot" quotation } + { "quot" "quotation" } } { $description "return a quotation to orientate space to see it from third point of view" } ; HELP: mvt-3D-4 { $values - { "quot" quotation } + { "quot" "quotation" } } { $description "return a quotation to orientate space to see it from first point of view" } ; -HELP: observer3d -{ $description "" } ; - -HELP: observer3d> -{ $values - - { "value" null } -} -{ $description "" } ; - -HELP: present-space -{ $description "" } ; - -HELP: present-space> -{ $values - - { "value" null } -} -{ $description "" } ; - HELP: load-model-file { $description "load space from file" } ; @@ -218,128 +70,76 @@ HELP: rotation-4D HELP: translation-4D { $values - { "v" null } + { "v" "vector" } } -{ $description "" } ; +{ $description "Apply a 4D translation" } ; -HELP: update-model-projections -{ $description "" } ; -HELP: update-observer-projections -{ $description "" } ; +ARTICLE: "implementation details" "How 4DNav is done" +"4DNav is build using :" -HELP: view1 -{ $description "" } ; - -HELP: view1> -{ $values - - { "value" null } -} -{ $description "" } ; - -HELP: view2 -{ $description "" } ; - -HELP: view2> -{ $values - - { "value" null } -} -{ $description "" } ; - -HELP: view3 -{ $description "" } ; - -HELP: view3> -{ $values - - { "value" null } -} -{ $description "" } ; - -HELP: view4 -{ $description "" } ; - -HELP: view4> -{ $values - - { "value" null } -} -{ $description "" } ; - -HELP: viewer-windows* -{ $description "" } ; - -HELP: win3D -{ $values - { "text" null } { "gadget" null } -} -{ $description "" } ; - -HELP: windows -{ $description "" } ; +{ $subsection "4DNav.camera" } +{ $subsection "adsoda-main-page" } +; ARTICLE: "Space file" "Create a new space file" -"\nTo build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. \nAn example is:" +"To build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. A solid is not caracterized by its corners but is defined as the intersection of hyperplanes." + $nl - -"\n" -"\n" -"\n 4" -"\n " -"\n 4cube1" -"\n 4" -"\n 1,0,0,0,100" -"\n -1,0,0,0,-150" -"\n 0,1,0,0,100" -"\n 0,-1,0,0,-150" -"\n 0,0,1,0,100" -"\n 0,0,-1,0,-150" -"\n 0,0,0,1,100" -"\n 0,0,0,-1,-150" -"\n 1,0,0" -"\n " -"\n " -"\n 4triancube" -"\n 4" -"\n 1,0,0,0,160" -"\n -0.4999999999999998,-0.8660254037844387,0,0,-130" -"\n -0.5000000000000004,0.8660254037844384,0,0,-130" -"\n 0,0,1,0,140" -"\n 0,0,-1,0,-180" -"\n 0,0,0,1,110" -"\n 0,0,0,-1,-180" -"\n 0,1,0" -"\n " -"\n " -"\n triangone" -"\n 4" -"\n 1,0,0,0,60" -"\n 0.5,0.8660254037844386,0,0,60" -"\n -0.5,0.8660254037844387,0,0,-20" -"\n -1.0,0,0,0,-100" -"\n -0.5,-0.8660254037844384,0,0,-100" -"\n 0.5,-0.8660254037844387,0,0,-20" -"\n 0,0,1,0,120" -"\n 0,0,-0.4999999999999998,-0.8660254037844387,-120" -"\n 0,0,-0.5000000000000004,0.8660254037844384,-120" -"\n 0,1,1" -"\n " -"\n " -"\n 1,1,1,1" -"\n 0.2,0.2,0.6" -"\n " -"\n 0.8,0.9,0.9" -"\n" -"\n" - - -; +"An example is:" +{ $code <" + + + 4 + + 4cube1 + 4 + 1,0,0,0,100 + -1,0,0,0,-150 + 0,1,0,0,100 + 0,-1,0,0,-150 + 0,0,1,0,100 + 0,0,-1,0,-150 + 0,0,0,1,100 + 0,0,0,-1,-150 + 1,0,0 + + + 4triancube + 4 + 1,0,0,0,160 + -0.4999999999999998,-0.8660254037844387,0,0,-130 + -0.5000000000000004,0.8660254037844384,0,0,-130 + 0,0,1,0,140 + 0,0,-1,0,-180 + 0,0,0,1,110 + 0,0,0,-1,-180 + 0,1,0 + + + triangone + 4 + 1,0,0,0,60 + 0.5,0.8660254037844386,0,0,60 + -0.5,0.8660254037844387,0,0,-20 + -1.0,0,0,0,-100 + -0.5,-0.8660254037844384,0,0,-100 + 0.5,-0.8660254037844387,0,0,-20 + 0,0,1,0,120 + 0,0,-0.4999999999999998,-0.8660254037844387,-120 + 0,0,-0.5000000000000004,0.8660254037844384,-120 + 0,1,1 + + + 1,1,1,1 + 0.2,0.2,0.6 + + 0.8,0.9,0.9 + + "> } ; ARTICLE: "TODO" "Todo" { $list - "A file chooser" "A vocab to initialize parameters" "an editor mode" { $list "add a face to a solid" @@ -357,43 +157,41 @@ ARTICLE: "TODO" "Todo" "add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } " "decorrelate 3D camera and activate them with select buttons" - - } ; -ARTICLE: "4DNav" "4DNav" +ARTICLE: "4DNav" "The 4DNav app" { $vocab-link "4DNav" } $nl { $heading "4D Navigator" } "4DNav is a simple tool to visualize 4 dimensionnal objects." -"\n" +$nl "It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it." - +$nl "It will display:" { $list { "a menu window" } { "4 visualization windows" } } -"Each window represents the projection of the 4D space on a particular 3D space." -$nl +"Each visualization window represents the projection of the 4D space on a particular 3D space." + +{ $heading "Start" } +"type:" { $code "\"4DNav\" run" } -{ $heading "Initialization" } -"put the space file " { $strong "space-exemple.xml" } " in temp directory" -" and then type:" { $code "\"4DNav\" run" } { $heading "Navigation" } -"4D submenu move the space in translations and rotation." -"\n3D submenu move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" -$nl - - - +"Menu window is divided in 4 areas" +{ $list + { "a space-file chooser to select the file to display" } + { "a parametrization area to select the projection mode" } + { "4D submenu to translate and rotate the 4D space" } + { "3D submenu to move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" } + } { $heading "Links" } { $subsection "Space file" } { $subsection "TODO" } - +{ $subsection "implementation details" } ; diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor index 3a0543df1a..91c1c94b35 100755 --- a/extra/4DNav/4DNav.factor +++ b/extra/4DNav/4DNav.factor @@ -109,34 +109,36 @@ VAR: present-space [ dup cos , 0.0 , dup sin neg , 0.0 , 0.0 , 1.0 , 0.0 , 0.0 , dup sin , 0.0 , dup cos , 0.0 , - 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ; + 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ; : 4D-Rzw ( angle -- Rz ) deg>rad [ dup cos , dup sin neg , 0.0 , 0.0 , dup sin , dup cos , 0.0 , 0.0 , 0.0 , 0.0 , 1.0 , 0.0 , - 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ; + 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! UI -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: button* ( string quot -- button ) closed-quot ; +: button* ( string quot -- button ) + closed-quot ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : model-projection-chooser ( -- gadget ) observer3d> projection-mode>> - { { 1 "perspective" } { 0 "orthogonal" } } ; + { { 1 "perspective" } { 0 "orthogonal" } } + ; : collision-detection-chooser ( -- gadget ) observer3d> collision-mode>> - { { t "on" } { f "off" } } -; + { { t "on" } { f "off" } } ; -: model-projection ( x -- space ) present-space> swap space-project ; +: model-projection ( x -- space ) + present-space> swap space-project ; : update-observer-projections ( -- ) view1> relayout-1 @@ -151,14 +153,16 @@ VAR: present-space 3 model-projection view4> (>>model) ; : camera-action ( quot -- quot ) - [ drop [ ] observer3d> with-self update-observer-projections ] + [ drop [ ] observer3d> + with-self update-observer-projections ] make* closed-quot ; -: win3D ( text gadget -- ) "navigateur 4D : " rot append open-window ; +: win3D ( text gadget -- ) + "navigateur 4D : " rot append open-window ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 4D object manipulation -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : (mvt-4D) ( quot -- ) present-space> @@ -168,42 +172,55 @@ VAR: present-space update-observer-projections ; : rotation-4D ( m -- ) - '[ _ [ [ middle-of-space dup vneg ] keep swap space-translate ] dip + '[ _ [ [ middle-of-space dup vneg ] keep + swap space-translate ] dip space-transform swap space-translate ] (mvt-4D) ; : translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! menu -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : menu-rotations-4D ( -- gadget ) 1 >>fill - "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] button* add-gadget - "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] button* add-gadget + "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] + button* add-gadget + "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] + button* add-gadget @top-left grid-add 1 >>fill - "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] button* add-gadget - "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] button* add-gadget + "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] + button* add-gadget + "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] + button* add-gadget @top grid-add 1 >>fill - "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] button* add-gadget - "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] button* add-gadget + "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] + button* add-gadget + "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] + button* add-gadget @center grid-add 1 >>fill - "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] button* add-gadget - "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] button* add-gadget + "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] + button* add-gadget + "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] + button* add-gadget @top-right grid-add 1 >>fill - "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] button* add-gadget - "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] button* add-gadget + "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] + button* add-gadget + "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] + button* add-gadget @right grid-add 1 >>fill - "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] button* add-gadget - "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] button* add-gadget + "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] + button* add-gadget + "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] + button* add-gadget @bottom-right grid-add ; @@ -211,9 +228,11 @@ VAR: present-space 1 >>fill 1 >>fill - "X+" [ drop { 1 0 0 0 } translation-step v*n translation-4D ] + "X+" [ drop { 1 0 0 0 } translation-step v*n + translation-4D ] button* add-gadget - "X-" [ drop { -1 0 0 0 } translation-step v*n translation-4D ] + "X-" [ drop { -1 0 0 0 } translation-step v*n + translation-4D ] button* add-gadget add-gadget "YZW"