steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-01-28 10:29:40 -06:00
parent 8bb9429589 9a504b5cd8
commit a3ee1d9488
930 changed files with 8924 additions and 5058 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
Makefile
View File

@ -25,23 +25,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)

4
basis/alien/c-types/c-types-tests.factor
View File

@ -8,10 +8,6 @@ sequences system libc alien.strings io.encodings.utf8 ;
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
: foo ( -- n ) &: fdafd [ 123 ] unless* ;
[ 123 ] [ foo ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test
[ -1 ] [ -1 <int> *int ] unit-test

2
basis/alien/remote-control/remote-control.factor
View File

@ -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

11
basis/alien/syntax/syntax.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
fry vocabs.parser ;
fry vocabs.parser words.constant ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@ -31,10 +31,11 @@ IN: alien.syntax
: C-ENUM:
";" parse-tokens
dup length
[ [ create-in ] dip 1quotation define ] 2each ;
[ [ create-in ] dip define-constant ] each-index ;
parsing
: address-of ( name library -- value )
load-library dlsym [ "No such symbol" throw ] unless* ;
: &:
scan "c-library" get
'[ _ _ load-library dlsym ] over push-all ; parsing
scan "c-library" get '[ _ _ address-of ] over push-all ; parsing

11
basis/ascii/ascii-docs.factor
View File

@ -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"

44
basis/ascii/ascii.factor
View File

@ -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 ;

32
basis/bootstrap/compiler/compiler.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler cpu.architecture vocabs.loader system
sequences namespaces parser kernel kernel.private classes
@ -25,8 +25,8 @@ IN: bootstrap.compiler
enable-compiler
: compile-uncompiled ( words -- )
[ compiled>> 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

52
basis/bootstrap/image/image.factor
View File

@ -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 <groups>
big-endian get [ [ be> ] map ] [ [ le> ] map ] if
emit-seq ;
bootstrap-cell <groups> native> emit-seq ;
: pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ;
: 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

2
basis/bootstrap/stage2.factor
View File

@ -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

1
basis/bootstrap/unicode/unicode.factor
View File

@ -0,0 +1 @@
USE: unicode

4
basis/compiler/compiler.factor
View File

@ -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 )
[

2
basis/compiler/tests/codegen.factor
View File

@ -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

12
basis/compiler/tests/optimizer.factor
View File

@ -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 <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression compiled>> ] unit-test
[ t ] [ \ <tuple>-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

4
basis/compiler/tests/peg-regression.factor
View File

@ -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

28
basis/compiler/tests/redefine1.factor
View File

@ -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

4
basis/compiler/tests/redefine3.factor
View File

@ -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

2
basis/compiler/tests/simple.factor
View File

@ -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

6
basis/compiler/tests/spilling.factor
View File

@ -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

3
basis/concurrency/messaging/messaging-docs.factor
View File

@ -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"

8
basis/cpu/ppc/assembler/assembler.factor
View File

@ -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

4
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -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 ;

6
basis/db/postgresql/postgresql.factor
View File

@ -55,8 +55,10 @@ M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] 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 )

7
basis/db/tuples/tuples.factor
View File

@ -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 -- )

4
basis/db/types/types.factor
View File

@ -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 ;

9
basis/deques/deques.factor
View File

@ -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

17
basis/dlists/dlists.factor
View File

@ -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
<PRIVATE
@ -64,7 +64,7 @@ M: dlist-node node-value obj>> ;
[ 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,8 +115,7 @@ 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-find nip ; inline
@ -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 ) <dlist> [ push-front ] keep ;
M: dlist clone
<dlist> [
[ push-back ] curry dlist-each
] keep ;
<dlist> [ '[ _ push-back ] dlist-each ] keep ;
INSTANCE: dlist deque

2
basis/eval/eval-docs.factor
View File

@ -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 } ;

4
basis/eval/eval-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: eval.tests
USING: eval tools.test ;
[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test

24
basis/eval/eval.factor
View File

@ -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 ;

4
basis/farkup/farkup-docs.factor
View File

@ -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 } "."

30
basis/farkup/farkup-tests.factor
View File

@ -92,22 +92,22 @@ link-no-follow? off
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
[ "<pre><span class=\"KEYWORD3\">int</span> <span class=\"FUNCTION\">main</span><span class=\"OPERATOR\">(</span><span class=\"OPERATOR\">)</span></pre>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src='lol.jpg'/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src='lol.jpg' alt='teh lol'/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href='http://lol.com'>http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
[ "<p><a href='http://lol.com'>haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
[ "<p><a href='Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
[ "<p><a href=\"Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
"/wiki/view/" relative-link-prefix [
[ "<p><a href='/wiki/view/Foo/Bar'>Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
[ "<p><a href=\"/wiki/view/Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
] with-variable
[ ] [ "[{}]" convert-farkup drop ] unit-test
[ "<pre>hello\n</pre>" ] [ "[{hello}]" convert-farkup ] unit-test
[ "<pre>hello</pre>" ] [ "[{hello}]" convert-farkup ] unit-test
[
"<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
@ -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
[
"<p>This wiki is written in <a href='Factor'>Factor</a> and is hosted on a <a href='http://linode.com'>http://linode.com</a> virtual server.</p>"
"<p>This wiki is written in <a href=\"Factor\">Factor</a> and is hosted on a <a href=\"http://linode.com\">http://linode.com</a> virtual server.</p>"
] [
"This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server."
convert-farkup
] unit-test
[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
[ "<p><a href=\"a\">a</a> <a href=\"b\">c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
[ "<p><a href=\"C%2b%2b\">C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
[ "<p>&lt;foo&gt;</p>" ] [ "<foo>" convert-farkup ] unit-test
@ -138,10 +138,10 @@ link-no-follow? off
[ "<hr/>" ] [ "___" convert-farkup ] unit-test
[ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
[ "<p>before:\n<pre><span class='OPERATOR'>{</span> <span class='DIGIT'>1</span> <span class='DIGIT'>2</span> <span class='DIGIT'>3</span> <span class='OPERATOR'>}</span> <span class='DIGIT'>1</span> tail\n</pre></p>" ]
[ "<p>before:\n<pre><span class=\"OPERATOR\">{</span> <span class=\"DIGIT\">1</span> <span class=\"DIGIT\">2</span> <span class=\"DIGIT\">3</span> <span class=\"OPERATOR\">}</span> <span class=\"DIGIT\">1</span> tail</pre></p>" ]
[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
[ "<p><a href='Factor'>Factor</a>-rific!</p>" ]
[ "<p><a href=\"Factor\">Factor</a>-rific!</p>" ]
[ "[[Factor]]-rific!" convert-farkup ] unit-test
[ "<p>[ factor { 1 2 3 }]</p>" ]
@ -163,7 +163,7 @@ link-no-follow? off
convert-farkup string>xml-chunk
"a" deep-tag-named "href" swap at url-decode ;
[ "Trader Joe's" ] [ "[[Trader Joe's]]" check-link-escaping ] unit-test
[ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test
[ "<foo>" ] [ "[[<foo>]]" check-link-escaping ] unit-test
[ "&blah;" ] [ "[[&blah;]]" check-link-escaping ] unit-test
[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test
[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test

122
basis/farkup/farkup.factor
View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators html.elements 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.interpolate
vectors splitting xmode.code2html urls.encoding xml.data
xml.writer ;
IN: farkup
SYMBOL: relative-link-prefix
@ -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
@ -163,66 +165,78 @@ stand-alone
{ [ dup [ 127 > ] contains? ] [ 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 <a href=<-> nofollow=<->><-></a> XML] ;
: write-link ( href text -- )
escape-link
[ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
[ write </a> ]
bi* ;
: write-image-link ( href text -- )
: write-image-link ( href text -- xml )
disable-images? get [
2drop
<strong> "Images are not allowed" write </strong>
[XML <strong>Images are not allowed</strong> XML]
] [
escape-link
[ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
[ check-url ] [ f like ] bi*
[XML <img src=<-> alt=<->/> XML]
] if ;
: render-code ( string mode -- string' )
[ string-lines ] dip
[
<pre>
htmlize-lines
</pre>
] with-string-writer write ;
: render-code ( string mode -- xml )
[ string-lines ] dip htmlize-lines
[XML <pre><-></pre> XML] ;
GENERIC: (write-farkup) ( farkup -- )
: <foo.> ( string -- ) <foo> write ;
: </foo.> ( string -- ) </foo> write ;
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; 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 <hr/> ;
M: line-break (write-farkup) drop <br/> 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 )
<simple-name> swap T{ attrs } swap
child>> (write-farkup) 1array <tag> ;
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 <hr/> XML] ;
M: line-break (write-farkup)
drop [XML <br/> XML] ;
M: table-row (write-farkup)
child>>
[ (write-farkup) [XML <td><-></td> XML] ] map
[XML <tr><-></tr> 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-chunk ;
: convert-farkup ( string -- string' )
parse-farkup [ (write-farkup) ] with-string-writer ;
[ write-farkup ] with-string-writer ;

12
basis/formatting/formatting-docs.factor
View File

@ -7,7 +7,7 @@ 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"
@ -24,10 +24,10 @@ HELP: printf
{ "%+Px" "Hexadecimal" "hex" }
{ "%+PX" "Hexadecimal uppercase" "hex" }
}
"\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,7 +38,7 @@ 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
@ -83,7 +83,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 +118,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 }

6
basis/fry/fry-docs.factor
View File

@ -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."

4
basis/furnace/auth/auth-docs.factor
View File

@ -121,7 +121,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 +148,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
<" <protected>
"view your todo list" >>description">

2
basis/furnace/auth/features/recover-password/recover-password.factor
View File

@ -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" %

2
basis/furnace/syndication/syndication-docs.factor
View File

@ -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." } ;

6
basis/furnace/utilities/utilities.factor
View File

@ -96,11 +96,7 @@ M: object modify-form drop ;
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
{ "POST" [
post-data>>
dup content-type>> "application/x-www-form-urlencoded" =
[ content>> ] [ drop f ] if
] }
{ "POST" [ post-data>> params>> ] }
} case ;
: referrer ( -- referrer/f )

4
basis/grouping/grouping.factor
View File

@ -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
<PRIVATE
@ -94,7 +94,7 @@ INSTANCE: sliced-clumps slice-chunking
[ first2-unsafe ] dip call
] [
[ 2 <sliced-clumps> ] dip
[ first2-unsafe ] prepose all?
'[ first2-unsafe @ ] all?
] if
] if ; inline

6
basis/heaps/heaps-tests.factor
View File

@ -32,10 +32,8 @@ IN: heaps.tests
: random-alist ( n -- alist )
[
[
32 random-bits dup number>string swap set
] times
] H{ } make-assoc ;
drop 32 random-bits dup number>string
] H{ } map>assoc ;
: test-heap-sort ( n -- ? )
random-alist dup >alist sort-keys swap heap-sort = ;

3
basis/help/handbook/handbook.factor
View File

@ -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" }

9
basis/help/help-docs.factor
View File

@ -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
"<element> ::== <string> | <simple-element> | <fancy-element>"
"<simple-element> ::== { <element>* }"
"<fancy-element> ::== { <type> <element> }"
}
{ $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

111
basis/help/lint/lint.factor
View File

@ -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? [
@ -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,78 @@ 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 contains?
[ "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 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
} cleave ;
: check-markup ( element -- )
{
[ check-elements ]
[ check-rendering ]
[ check-examples ]
[ check-modules ]
} cleave ;
: all-word-help ( words -- seq )
[ word-help ] filter ;
TUPLE: help-error topic error ;
TUPLE: help-error error topic ;
C: <help-error> 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 [ <help-error> , ] recover ; inline
flush '[ _ assert-depth ] swap '[ _ <help-error> , ] 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 +178,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

12
basis/help/markup/markup-tests.factor
View File

@ -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

28
basis/help/markup/markup.factor
View File

@ -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> ::== <string> | <simple-element> | <fancy-element>
! <simple-element> ::== { <element>* }
! <fancy-element> ::== { <type> <element> }
! 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

8
basis/help/tutorial/tutorial.factor
View File

@ -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:"

4
basis/html/components/components-docs.factor
View File

@ -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."

16
basis/html/components/components-tests.factor
View File

@ -31,7 +31,7 @@ TUPLE: color red green blue ;
] with-string-writer
] unit-test
[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
[
"red" hidden render
] with-string-writer
@ -39,13 +39,13 @@ TUPLE: color red green blue ;
[ ] [ "'jimmy'" "red" set-value ] unit-test
[ "<input type='text' size='5' name='red' value='&apos;jimmy&apos;'/>" ] [
[ "<input value=\"&apos;jimmy&apos;\" name=\"red\" size=\"5\" type=\"text\"/>" ] [
[
"red" <field> 5 >>size render
] with-string-writer
] unit-test
[ "<input type='password' size='5' name='red' value=''/>" ] [
[ "<input value=\"\" name=\"red\" size=\"5\" type=\"password\"/>" ] [
[
"red" <password> 5 >>size render
] with-string-writer
@ -105,7 +105,7 @@ TUPLE: color red green blue ;
[ ] [ t "delivery" set-value ] unit-test
[ "<input type='checkbox' name='delivery' checked='true'>Delivery</input>" ] [
[ "<input type=\"checkbox\" checked=\"true\" name=\"delivery\">Delivery</input>" ] [
[
"delivery"
<checkbox>
@ -116,7 +116,7 @@ TUPLE: color red green blue ;
[ ] [ f "delivery" set-value ] unit-test
[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
[ "<input type=\"checkbox\" name=\"delivery\">Delivery</input>" ] [
[
"delivery"
<checkbox>
@ -133,7 +133,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ link-test "link" set-value ] unit-test
[ "<a href='http://www.apple.com/foo&amp;bar'>&lt;Link Title&gt;</a>" ] [
[ "<a href=\"http://www.apple.com/foo&amp;bar\">&lt;Link Title&gt;</a>" ] [
[ "link" link new render ] with-string-writer
] unit-test
@ -149,7 +149,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ "java" "mode" set-value ] unit-test
[ "<span class='KEYWORD3'>int</span> x <span class='OPERATOR'>=</span> <span class='DIGIT'>4</span>;\n" ] [
[ "<span class=\"KEYWORD3\">int</span> x <span class=\"OPERATOR\">=</span> <span class=\"DIGIT\">4</span>;" ] [
[ "code" <code> "mode" >>mode render ] with-string-writer
] unit-test
@ -163,6 +163,8 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ t ] [
[ "object" inspector render ] with-string-writer
USING: splitting sequences ;
"\"" split "'" join ! replace " with ' for now
[ "object" value [ describe ] with-html-writer ] with-string-writer
=
] unit-test

106
basis/html/components/components.factor
View File

@ -3,13 +3,13 @@
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
fry locals calendar calendar.format xml.entities xml.data
validators urls present xml.writer xml.interpolate xml
xmode.code2html lcs.diff2html farkup io.streams.string
html.elements html.streams html.forms ;
IN: html.components
GENERIC: render* ( value name renderer -- )
GENERIC: render* ( value name renderer -- xml )
: render ( name renderer -- )
prepare-value
@ -19,38 +19,36 @@ GENERIC: render* ( value name renderer -- )
[ f swap ]
if
] 2dip
render*
render* write-xml-chunk
[ render-error ] when* ;
<PRIVATE
: render-input ( value name type -- )
<input =type =name present =value input/> ;
: render-input ( value name type -- xml )
[XML <input value=<-> name=<-> type=<->/> XML] ;
PRIVATE>
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 "hidden" render-input ;
: render-field ( value name size type -- )
<input
=type
[ present =size ] when*
=name
present =value
input/> ;
: render-field ( value name size type -- xml )
[XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
TUPLE: field size ;
: <field> ( -- field )
field new ;
M: field render* size>> "text" render-field ;
M: field render*
size>> "text" render-field ;
TUPLE: password size ;
@ -67,14 +65,15 @@ TUPLE: textarea rows cols ;
: <textarea> ( -- renderer )
textarea new ;
M: textarea render*
<textarea
[ rows>> [ present =rows ] when* ]
[ cols>> [ present =cols ] when* ] bi
=name
textarea>
present escape-string write
</textarea> ;
M:: textarea render* ( value name area -- xml )
area rows>> :> rows
area cols>> :> cols
[XML
<textarea
name=<-name->
rows=<-rows->
cols=<-cols->><-value-></textarea>
XML] ;
! Choice
TUPLE: choice size multiple choices ;
@ -82,24 +81,23 @@ TUPLE: choice size multiple choices ;
: <choice> ( -- choice )
choice new ;
: render-option ( text selected? -- )
<option [ "selected" =selected ] when option>
present escape-string write
</option> ;
: render-option ( text selected? -- xml )
"selected" and swap
[XML <option selected=<->><-></option> 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*
<select
swap =name
dup size>> [ present =size ] when*
dup multiple>> [ "true" =multiple ] when
select>
[ choices>> value ] [ multiple>> ] bi
[ swap ] [ swap 1array ] if
render-options
</select> ;
M:: choice render* ( value name choice -- xml )
choice size>> :> size
choice multiple>> "true" and :> multiple
value choice render-options :> contents
[XML <select
name=<-name->
size=<-size->
multiple=<-multiple->><-contents-></select> XML] ;
! Checkboxes
TUPLE: checkbox label ;
@ -108,13 +106,10 @@ TUPLE: checkbox label ;
checkbox new ;
M: checkbox render*
<input
"checkbox" =type
swap =name
swap [ "true" =checked ] when
input>
label>> escape-string write
</input> ;
[ "true" and ] [ ] [ label>> ] tri*
[XML <input
type="checkbox"
checked=<-> name=<->><-></input> XML] ;
! Link components
GENERIC: link-title ( obj -- string )
@ -129,10 +124,9 @@ M: url link-href ;
TUPLE: link target ;
M: link render*
nip
<a target>> [ =target ] when* dup link-href =href a>
link-title present escape-string write
</a> ;
nip swap
[ target>> ] [ [ link-href ] [ link-title ] bi ] bi*
[XML <a target=<-> href=<->><-></a> XML] ;
! XMode code component
TUPLE: code mode ;
@ -161,7 +155,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 ;
@ -169,7 +163,9 @@ M: farkup render*
SINGLETON: inspector
M: inspector render*
2drop [ describe ] with-html-writer ;
2drop [
[ describe ] with-html-writer
] with-string-writer <unescaped> ;
! Diff component
SINGLETON: comparison
@ -180,4 +176,4 @@ M: comparison render*
! HTML component
SINGLETON: html
M: html render* 2drop write ;
M: html render* 2drop string>xml-chunk ;

2
basis/html/elements/elements-docs.factor
View File

@ -14,7 +14,7 @@ $nl
{ $code "<a =href a> \"Click me\" write </a>" }
{ $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
{ $code "<a [ \"http://\" % % ] \"\" make =href a> \"click\" write </a>" }
"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 "<input \"text\" =type \"name\" =name 20 =size input/>" }
"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

2
basis/html/templates/chloe/chloe-tests.factor
View File

@ -159,7 +159,7 @@ TUPLE: person first-name last-name ;
"true" "b" set-value
] unit-test
[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
[ "<input type=\"checkbox\" name=\"a\">a</input><input type=\"checkbox\" checked=\"true\" name=\"b\">b</input>" ] [
[
"test12" test-template call-template
] run-template

47
basis/http/client/client-docs.factor
View File

@ -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 <post-request> }
"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 <file-reader>"
"[ 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 <post-request> }
"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 <post-request> }
"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 <request> } " and filling everything in by hand."
{ $subsection "http.client.encoding" }
{ $subsection "http.client.errors" }

79
basis/http/client/client.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math math.parser namespaces make
sequences strings splitting calendar continuations accessors vectors
@ -7,9 +7,15 @@ 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.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
<PRIVATE
: write-request-line ( request -- request )
dup
[ method>> write bl ]
@ -21,35 +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>> [
[ raw>> 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: post-data >post-data ;
M: string >post-data utf8 encode "application/octet-stream" <post-data> ;
M: byte-array >post-data "application/octet-stream" <post-data> ;
M: assoc >post-data assoc>query ascii encode "application/x-www-form-urlencoded" <post-data> ;
M: f >post-data ;
: unparse-post-data ( request -- request )
[ >post-data ] change-post-data ;
: write-post-data ( request -- request )
dup method>> [ "POST" = ] [ "PUT" = ] bi or [ dup post-data>> raw>> write ] when ;
: write-request ( request -- )
unparse-post-data
write-request-line
@ -77,12 +67,6 @@ M: f >post-data ;
read-response-line
read-response-header ;
: max-redirects 10 ;
ERROR: too-many-redirects ;
<PRIVATE
DEFER: (with-http-request)
SYMBOL: redirects
@ -112,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
: <request-socket> ( -- stream )
request get url>> url-addr ascii <client> drop
@ -148,6 +127,11 @@ SYMBOL: redirects
[ do-redirect ] [ nip ] if
] with-variable ; inline recursive
: <client-request> ( url method -- request )
<request>
swap >>method
swap >url ensure-port >>url ; inline
PRIVATE>
: success? ( code -- ? ) 200 299 between? ;
@ -158,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 ;
: <get-request> ( url -- request )
<request>
"GET" >>method
swap >url ensure-port >>url ;
"GET" <client-request> ;
: http-get ( url -- response data )
<get-request> http-request ;
@ -185,14 +167,19 @@ ERROR: download-failed response ;
dup download-name download-to ;
: <post-request> ( post-data url -- request )
<request>
"POST" >>method
swap >url ensure-port >>url
"POST" <client-request>
swap >>post-data ;
: http-post ( post-data url -- response data )
<post-request> http-request ;
: <put-request> ( post-data url -- request )
"PUT" <client-request>
swap >>post-data ;
: http-put ( post-data url -- response data )
<put-request> http-request ;
USING: vocabs vocabs.loader ;
"debugger" vocab [ "http.client.debugger" require ] when

1
basis/http/client/post-data/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/http/client/post-data/post-data-tests.factor Normal file
View File

@ -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

91
basis/http/client/post-data/post-data.factor Normal file
View File

@ -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> measured-stream
<PRIVATE
GENERIC: (set-post-data-headers) ( header data -- header )
M: sequence (set-post-data-headers)
length "content-length" pick set-at ;
M: measured-stream (set-post-data-headers)
size>> "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 ;
<PRIVATE
GENERIC: (write-post-data) ( data -- )
M: sequence (write-post-data) write ;
M: measured-stream (write-post-data)
stream>> [ [ 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" <post-data>
swap >>data ;
M: assoc >post-data
"application/x-www-form-urlencoded" <post-data>
swap >>params ;
M: object >post-data
"application/octet-stream" <post-data>
swap >>data ;
: pathname>measured-stream ( pathname -- stream )
string>>
[ binary <file-reader> &dispose ]
[ file-info size>> ] bi
<measured-stream> ;
: 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* ;

8
basis/http/http-docs.factor
View File

@ -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: <post-data>
{ $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"

4
basis/http/http-tests.factor
View File

@ -1,4 +1,4 @@
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
@ -35,7 +35,7 @@ blah
{ method "POST" }
{ version "1.1" }
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
{ post-data T{ post-data { content "blah" } { raw "blah" } { content-type "application/octet-stream" } } }
{ post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } }
{ cookies V{ } }
}
] [

9
basis/http/http.factor
View File

@ -213,14 +213,11 @@ body ;
raw-response new
"1.1" >>version ;
TUPLE: post-data raw content content-type form-variables uploaded-files ;
TUPLE: post-data data params content-type content-encoding ;
: <post-data> ( form-variables uploaded-files raw content-type -- post-data )
: <post-data> ( content-type -- post-data )
post-data new
swap >>content-type
swap >>raw
swap >>uploaded-files
swap >>form-variables ;
swap >>content-type ;
: parse-content-type-attributes ( string -- attributes )
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;

6
basis/http/server/cgi/cgi.factor
View File

@ -34,7 +34,7 @@ IN: http.server.cgi
request get "accept" header "HTTP_ACCEPT" set
post-request? [
request get post-data>> raw>>
request get post-data>> data>>
[ "CONTENT_TYPE" set ]
[ length number>string "CONTENT_LENGTH" set ]
bi
@ -54,8 +54,8 @@ IN: http.server.cgi
swap '[
binary encode-output
_ output-stream get swap <cgi-process> binary <process-stream> [
post-request? [ request get post-data>> raw>> write flush ] when
input-stream get swap (stream-copy)
post-request? [ request get post-data>> data>> write flush ] when
'[ _ write ] each-block
] with-stream
] >>body ;

2
basis/http/server/dispatchers/dispatchers-docs.factor
View File

@ -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
<" <dispatcher>
<new-action> "new" add-responder

21
basis/http/server/server.factor
View File

@ -26,8 +26,6 @@ html.elements
html.streams ;
IN: http.server
\ parse-cookie DEBUG add-input-logging
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
@ -44,7 +42,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
@ -55,18 +53,17 @@ ERROR: no-boundary ;
: read-content ( request -- bytes )
"content-length" header string>number read ;
: parse-content ( request content-type -- form-variables uploaded-files raw )
{
{ "multipart/form-data" [ read-multipart-data f ] }
{ "application/x-www-form-urlencoded" [ read-content [ f f ] dip ] }
[ drop read-content [ f f ] dip ]
: parse-content ( request content-type -- post-data )
[ <post-data> swap ] keep {
{ "multipart/form-data" [ read-multipart-data >>params ] }
{ "application/x-www-form-urlencoded" [ read-content query>assoc >>params ] }
[ drop read-content >>data ]
} case ;
: read-post-data ( request -- request )
dup method>> "POST" = [
dup dup "content-type" header
[ ";" split1 drop parse-content ] keep
<post-data> >>post-data
";" split1 drop parse-content >>post-data
] when ;
: extract-host ( request -- request )
@ -199,8 +196,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 ]

29
basis/interpolate/interpolate.factor
View File

@ -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
<PRIVATE
TUPLE: interpolate-var name ;
: (parse-interpolate) ( string -- )
@ -20,21 +22,22 @@ TUPLE: interpolate-var name ;
: parse-interpolate ( string -- seq )
[ (parse-interpolate) ] { } make ;
MACRO: interpolate ( string -- )
parse-interpolate [
: (interpolate) ( string quot -- quot' )
[ parse-interpolate ] dip '[
dup interpolate-var?
[ name>> '[ _ 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

3
basis/interval-maps/interval-maps-docs.factor
View File

@ -18,7 +18,8 @@ HELP: <interval-map>
{ $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 }

3
basis/interval-maps/interval-maps.factor
View File

@ -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 ;

2
basis/io/backend/windows/windows.factor
View File

@ -51,4 +51,4 @@ HOOK: add-completion io-backend ( port -- )
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
"SECURITY_ATTRIBUTES" heap-size
over set-SECURITY_ATTRIBUTES-nLength ;
over set-SECURITY_ATTRIBUTES-nLength ;

9
basis/io/directories/directories-docs.factor
View File

@ -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"

7
basis/io/directories/search/search-tests.factor
View File

@ -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

8
basis/io/directories/windows/windows.factor
View File

@ -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" <c-object> tuck
FindFirstFile
"WIN32_FIND_DATA" <c-object>
[ nip ] [ FindFirstFile ] 2bi
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
"WIN32_FIND_DATA" <c-object> tuck
FindNextFile 0 = [
"WIN32_FIND_DATA" <c-object>
[ nip ] [ FindNextFile ] 2bi 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
] unless drop f

2
basis/io/encodings/8-bit/8-bit-docs.factor
View File

@ -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 }

3
basis/io/encodings/ascii/ascii.factor
View File

@ -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

4
basis/io/files/info/unix/freebsd/freebsd.factor
View File

@ -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" <c-object> tuck statfs io-error ;
"statfs" <c-object> [ 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" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{

4
basis/io/files/info/unix/linux/linux.factor
View File

@ -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" <c-object> tuck statfs64 io-error ;
"statfs64" <c-object> [ 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" <c-object> tuck statvfs64 io-error ;
"statvfs64" <c-object> [ statvfs64 io-error ] keep ;
M: linux statvfs>file-system-info ( struct -- statfs )
{

4
basis/io/files/info/unix/macosx/macosx.factor
View File

@ -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" <c-object> tuck statfs64 io-error ;
"statfs64" <c-object> [ statfs64 io-error ] keep ;
M: macosx file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{

2
basis/io/files/info/unix/netbsd/netbsd.factor
View File

@ -16,7 +16,7 @@ idx mount-from ;
M: netbsd new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{

4
basis/io/files/info/unix/openbsd/openbsd.factor
View File

@ -14,7 +14,7 @@ owner ;
M: openbsd new-file-system-info freebsd-file-system-info new ;
M: openbsd file-system-statfs
"statfs" <c-object> tuck statfs io-error ;
"statfs" <c-object> [ 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" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{

24
basis/io/files/links/unix/unix-tests.factor
View File

@ -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

75
basis/io/files/unique/unique-docs.factor
View File

@ -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"

28
basis/io/files/unique/unique-tests.factor
View File

@ -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 <repetition> ] 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

49
basis/io/files/unique/unique.factor
View File

@ -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
<PRIVATE
: random-letter ( -- ch )
@ -24,37 +32,44 @@ SYMBOL: unique-retries
{ t f } random
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
: random-name ( n -- string )
[ random-ch ] "" replicate-as ;
PRIVATE>
: 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

4
basis/io/files/unique/unix/unix.factor
View File

@ -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" ;

4
basis/io/files/unique/windows/windows.factor
View File

@ -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 ;

4
basis/io/monitors/linux/linux-tests.factor
View File

@ -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

17
basis/io/monitors/monitors-docs.factor
View File

@ -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 <monitor> } " 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 <monitor> } " 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 <monitor> } " 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"

10
basis/io/monitors/monitors-tests.factor
View File

@ -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,7 +53,7 @@ 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
@ -62,7 +62,7 @@ os { winnt linux macosx } member? [
"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
@ -101,13 +101,13 @@ os { winnt linux macosx } member? [
! Non-recursive
[ ] [ "monitor-timeout-test" temp-file f <monitor> "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 <monitor> "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

20
basis/io/monitors/monitors.factor
View File

@ -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 )
: <monitor> ( path recursive? -- monitor )
<mailbox> (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 -- )
[ <monitor> ] 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

11
basis/io/monitors/recursive/recursive.factor
View File

@ -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 ] }

2
basis/io/pipes/pipes-docs.factor
View File

@ -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" }
} ;

2
basis/io/ports/ports.factor
View File

@ -99,7 +99,7 @@ TUPLE: output-port < buffered-port ;
output-port <buffered-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

2
basis/io/sockets/windows/nt/nt.factor
View File

@ -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 ;

2
basis/io/streams/limited/limited-docs.factor
View File

@ -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:"

19
basis/io/streams/limited/limited-tests.factor
View File

@ -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" <string-reader> 3 stream-eofs limit unlimit
"abc" <string-reader> =
] unit-test
[ t ]
[
"abc" <string-reader> 3 stream-eofs limit unlimit
"abc" <string-reader> =
] unit-test
[ t ]
[
[
"resource:license.txt" utf8 <file-reader> &dispose
3 stream-eofs limit unlimit
"resource:license.txt" utf8 <file-reader> &dispose
[ decoder? ] both?
] with-destructors
] unit-test

15
basis/io/streams/limited/limited.factor
View File

@ -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' )
<limited-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 ;

6
basis/lcs/diff2html/diff2html-tests.factor Normal file
View File

@ -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-chunk>string drop ] unit-test

58
basis/lcs/diff2html/diff2html.factor
View File

@ -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.interpolate 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>> [ "&nbsp;" ] [ escape-string ] if-empty write ;
: item-string ( item -- string )
item>> [ CHAR: no-break-space 1string ] when-empty ;
M: retain diff-line
<tr>
dup [
<td "retain" =class td>
write-item
</td>
] bi@
</tr> ;
item-string
[XML <td class="retain"><-></td> XML]
dup [XML <tr><-><-></tr> XML] ;
M: insert diff-line
<tr>
<td> </td>
<td "insert" =class td>
write-item
</td>
</tr> ;
item-string [XML
<tr>
<td> </td>
<td class="insert"><-></td>
</tr>
XML] ;
M: delete diff-line
<tr>
<td "delete" =class td>
write-item
</td>
<td> </td>
</tr> ;
item-string [XML
<tr>
<td class="delete"><-></td>
<td> </td>
</tr>
XML] ;
: htmlize-diff ( diff -- )
<table "100%" =width "comparison" =class table>
<tr> <th> "Old" write </th> <th> "New" write </th> </tr>
[ diff-line ] each
</table> ;
: htmlize-diff ( diff -- xml )
[ diff-line ] map
[XML
<table width="100%" class="comparison">
<tr><th>Old</th><th>New</th></tr>
<->
</table>
XML] ;

5
basis/locals/locals-docs.factor
View File

@ -134,6 +134,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 )"
@ -166,7 +167,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 +180,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." ;

6
basis/locals/locals-tests.factor
View File

@ -490,4 +490,8 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 10 ] [
[| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
] unit-test
] 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

32
basis/locals/parser/parser.factor
View File

@ -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) <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 ;

2
basis/match/match.factor
View File

@ -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* ;

2
basis/math/complex/complex-docs.factor
View File

@ -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"

Some files were not shown because too many files have changed in this diff Show More