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

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

db4
Aaron Schaefer 2009-02-01 18:33:03 -05:00
parent 52690f3088 e089ce6df0
commit 3c02bcc065
548 changed files with 7340 additions and 5522 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -22,3 +22,4 @@ work
build-support/wordsize
*.bak
.#*
*.swo

26
Makefile
View File

@ -3,6 +3,7 @@ AR = ar
LD = ld
EXECUTABLE = factor
CONSOLE_EXECUTABLE = factor-console
VERSION = 0.92
IMAGE = factor.image
@ -25,23 +26,25 @@ ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \
vm/bignum.o \
vm/callstack.o \
vm/code_block.o \
vm/code_gc.o \
vm/code_heap.o \
vm/data_gc.o \
vm/data_heap.o \
vm/debug.o \
vm/errors.o \
vm/factor.o \
vm/ffi_test.o \
vm/image.o \
vm/io.o \
vm/math.o \
vm/data_gc.o \
vm/code_gc.o \
vm/primitives.o \
vm/run.o \
vm/callstack.o \
vm/types.o \
vm/profiler.o \
vm/quotations.o \
vm/utilities.o \
vm/errors.o \
vm/profiler.o
vm/run.o \
vm/types.o \
vm/utilities.o
EXE_OBJS = $(PLAF_EXE_OBJS)
@ -136,9 +139,11 @@ zlib1.dll:
winnt-x86-32: freetype6.dll zlib1.dll
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
@ -159,6 +164,11 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
factor-console: $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor.{a,so,dylib}

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

8
basis/base64/base64.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.binary io.encodings.binary
io.streams.byte-array io.streams.string kernel math namespaces
sequences strings ;
sequences strings io.crlf ;
IN: base64
<PRIVATE
@ -32,7 +32,7 @@ SYMBOL: column
: write1-lines ( ch -- )
write1
column get [
1+ [ 76 = [ "\r\n" write ] when ]
1+ [ 76 = [ crlf ] when ]
[ 76 mod column set ] bi
] when* ;
@ -45,8 +45,8 @@ SYMBOL: column
] with each ; inline
: encode-pad ( seq n -- )
[ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
ERROR: malformed-base64 ;

2
basis/base64/tags.txt Normal file
View File

@ -0,0 +1,2 @@
parsing
web

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

54
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 ;
dup length bootstrap-cell align 0 pad-tail ;
: check-string ( string -- )
[ 127 > ] contains?
[ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
: extended-part ( str -- str' )
dup [ 128 < ] all? [ drop f ] [
[ -7 shift 1 bitxor ] { } map-as
big-endian get
[ [ 2 >be ] { } map-as ]
[ [ 2 >le ] { } map-as ] if
B{ } join
] if ;
: ascii-part ( str -- str' )
[
[ 128 mod ] [ 128 >= ] bi
[ 128 bitor ] when
] B{ } map-as ;
: emit-string ( string -- ptr )
dup check-string
[ length ] [ extended-part ' ] [ ] tri
string type-number object tag-number [
dup length emit-fixnum
f ' emit
f ' emit
pad-bytes emit-bytes
[ emit-fixnum ]
[ emit ]
[ f ' emit ascii-part pad-bytes emit-bytes ]
tri*
] emit-object ;
M: string '
@ -433,7 +445,7 @@ M: quotation '
array>> '
quotation type-number object tag-number [
emit ! array
f ' emit ! compiled>>
f ' emit ! compiled
0 emit ! xt
0 emit ! code
] emit-object
@ -524,11 +536,9 @@ M: quotation '
! Image output
: (write-image) ( image -- )
bootstrap-cell big-endian get [
[ >be write ] curry each
] [
[ >le write ] curry each
] if ;
bootstrap-cell big-endian get
[ '[ _ >be write ] each ]
[ '[ _ >le write ] each ] if ;
: write-image ( image -- )
"Writing image to " write

4
basis/bootstrap/stage2.factor
View File

@ -13,7 +13,7 @@ SYMBOL: core-bootstrap-time
SYMBOL: bootstrap-time
: default-image-name ( -- string )
vm file-name os windows? [ "." split1 drop ] when
vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
: do-crossref ( -- )
@ -42,7 +42,7 @@ SYMBOL: bootstrap-time
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
[ compiled>> ] count-words " compiled words" print
[ optimized>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print

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

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

33
basis/cairo/gadgets/gadgets.factor
View File

@ -2,19 +2,26 @@
! See http://factorcode.org/license.txt for BSD license.
USING: sequences math kernel byte-arrays cairo.ffi cairo
io.backend ui.gadgets accessors opengl.gl arrays fry
classes ui.render namespaces ;
classes ui.render namespaces destructors libc ;
IN: cairo.gadgets
<PRIVATE
: width>stride ( width -- stride ) 4 * ;
: image-dims ( gadget -- width height stride )
dim>> first2 over width>stride ; inline
: image-buffer ( width height stride -- alien )
* nip malloc ; inline
PRIVATE>
GENERIC: render-cairo* ( gadget -- )
: render-cairo ( gadget -- byte-array )
dup dim>> first2 over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
rot '[ _ render-cairo* ] with-cairo-from-surface ; inline
: render-cairo ( gadget -- alien )
[
image-dims
[ image-buffer dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
TUPLE: cairo-gadget < gadget ;
@ -23,11 +30,13 @@ TUPLE: cairo-gadget < gadget ;
swap >>dim ;
M: cairo-gadget draw-gadget*
[ dim>> ] [ render-cairo ] bi
origin get first2 glRasterPos2i
1.0 -1.0 glPixelZoom
[ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
glDrawPixels ;
[
[ dim>> ] [ render-cairo &free ] bi
origin get first2 glRasterPos2i
1.0 -1.0 glPixelZoom
[ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
glDrawPixels
] with-destructors ;
: copy-surface ( surface -- )
cr swap 0 0 cairo_set_source_surface

6
basis/calendar/format/format.factor
View File

@ -5,11 +5,11 @@ sequences io accessors arrays io.streams.string splitting
combinators accessors calendar calendar.format.macros present ;
IN: calendar.format
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;
: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;
: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
: write-00 ( n -- ) pad-00 write ;

2
basis/checksums/sha1/sha1.factor
View File

@ -128,7 +128,7 @@ M: sha1 checksum-stream ( stream -- sha1 )
[ zip concat ] keep like ;
: sha1-interleave ( string -- seq )
[ zero? ] trim-left
[ zero? ] trim-head
dup length odd? [ rest ] when
seq>2seq [ sha1 checksum-bytes ] bi@
2seq>seq ;

2
basis/checksums/sha2/sha2.factor
View File

@ -62,7 +62,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ + + w+ ] 2dip swap set-nth ; inline
: prepare-message-schedule ( seq -- w-seq )
word-size get group [ be> ] map block-size get 0 pad-right
word-size get group [ be> ] map block-size get 0 pad-tail
dup 16 64 dup <slice> [
process-M-256
] with each ;

2
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
View File

@ -13,7 +13,7 @@ IN: compiler.cfg.alias-analysis.tests
[ ] [
{
T{ ##load-indirect f V int-regs 1 "hello" }
T{ ##load-reference f V int-regs 1 "hello" }
T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test

2
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -224,7 +224,7 @@ GENERIC: analyze-aliases* ( insn -- insn' )
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
M: ##load-indirect analyze-aliases*
M: ##load-reference analyze-aliases*
dup dst>> set-heap-ac ;
M: ##alien-global analyze-aliases*

4
basis/compiler/cfg/instructions/instructions.factor
View File

@ -36,13 +36,13 @@ TUPLE: ##alien-setter < ##effect { value vreg } ;
! Stack operations
INSN: ##load-immediate < ##pure { val integer } ;
INSN: ##load-indirect < ##pure obj ;
INSN: ##load-reference < ##pure obj ;
GENERIC: ##load-literal ( dst value -- )
M: fixnum ##load-literal tag-fixnum ##load-immediate ;
M: f ##load-literal drop \ f tag-number ##load-immediate ;
M: object ##load-literal ##load-indirect ;
M: object ##load-literal ##load-reference ;
INSN: ##peek < ##read { loc loc } ;
INSN: ##replace < ##write { loc loc } ;

2
basis/compiler/cfg/linearization/linearization.factor Normal file → Executable file
View File

@ -63,7 +63,7 @@ M: ##compare-float-branch linearize-insn
##box-float
##box-alien
} memq?
] contains? ;
] any? ;
: linearize-basic-block ( bb -- )
[ number>> _label ]

2
basis/compiler/cfg/value-numbering/expressions/expressions.factor
View File

@ -39,8 +39,6 @@ GENERIC: >expr ( insn -- expr )
M: ##load-immediate >expr val>> <constant> ;
M: ##load-indirect >expr obj>> <constant> ;
M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;

8
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -81,7 +81,7 @@ sequences ;
[
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
@ -89,7 +89,7 @@ sequences ;
}
] [
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
@ -99,7 +99,7 @@ sequences ;
[
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
@ -107,7 +107,7 @@ sequences ;
}
] [
{
T{ ##load-indirect f V int-regs 1 + }
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }

6
basis/compiler/codegen/codegen.factor Normal file → Executable file
View File

@ -70,8 +70,8 @@ SYMBOL: labels
M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ;
M: ##load-indirect generate-insn
[ dst>> register ] [ obj>> ] bi %load-indirect ;
M: ##load-reference generate-insn
[ dst>> register ] [ obj>> ] bi %load-reference ;
M: ##peek generate-insn
[ dst>> register ] [ loc>> ] bi %peek ;
@ -400,7 +400,7 @@ M: no-such-symbol compiler-error-type
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd '[ _ dlsym ] contains?
dupd '[ _ dlsym ] any?
[ drop ] [ no-such-symbol ] if
] [
dll-path no-such-library drop

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

8
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
@ -276,3 +276,9 @@ TUPLE: id obj ;
[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
TUPLE: cucumber ;
M: cucumber equal? "The cucumber has no equal" throw ;
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test

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

8
basis/compiler/tests/stack-trace.factor Normal file → Executable file
View File

@ -19,14 +19,14 @@ words splitting grouping sorting accessors ;
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ;
[ t ] [
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
] unit-test
[ t f ] [
[ { "hi" } bleh ] ignore-errors
\ + stack-trace-contains?
\ > stack-trace-contains?
\ + stack-trace-any?
\ > stack-trace-any?
] unit-test

2
basis/compiler/tree/builder/builder-tests.factor Normal file → Executable file
View File

@ -8,4 +8,4 @@ compiler.tree ;
: inline-recursive ( -- ) inline-recursive ; inline recursive
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? nip ] unit-test

2
basis/compiler/tree/checker/checker.factor Normal file → Executable file
View File

@ -175,7 +175,7 @@ M: #branch check-stack-flow*
branch-out get [ ] find nip swap head* >vector datastack set ;
M: #phi check-stack-flow*
branch-out get [ ] contains? [
branch-out get [ ] any? [
[ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
] [ drop terminated? on ] if ;

2
basis/compiler/tree/cleanup/cleanup-tests.factor Normal file → Executable file
View File

@ -498,7 +498,7 @@ cell-bits 32 = [
[ t ] [
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
] unit-test
[ ] [

4
basis/compiler/tree/combinators/combinators.factor Normal file → Executable file
View File

@ -34,14 +34,14 @@ IN: compiler.tree.combinators
dup dup '[
_ keep swap [ drop t ] [
dup #branch? [
children>> [ _ contains-node? ] contains?
children>> [ _ contains-node? ] any?
] [
dup #recursive? [
child>> _ contains-node?
] [ drop f ] if
] if
] if
] contains? ; inline recursive
] any? ; inline recursive
: select-children ( seq flags -- seq' )
[ [ drop f ] unless ] 2map ;

2
basis/compiler/tree/dead-code/simple/simple.factor Normal file → Executable file
View File

@ -79,7 +79,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
: some-outputs-dead? ( #call -- ? )
out-d>> [ live-value? not ] contains? ;
out-d>> [ live-value? not ] any? ;
: maybe-drop-dead-outputs ( node -- nodes )
dup some-outputs-dead? [

2
basis/compiler/tree/normalization/normalization.factor
View File

@ -60,7 +60,7 @@ M: #branch normalize*
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
[
[ nip ] [
dup [ +bottom+ eq? ] trim-left
dup [ +bottom+ eq? ] trim-head
[ [ length ] bi@ - tail* ] keep append
] if
] 3map ;

0
basis/compiler/tree/propagation/branches/branches.factor Normal file → Executable file
View File

2
basis/compiler/tree/propagation/inlining/inlining.factor Normal file → Executable file
View File

@ -124,7 +124,7 @@ DEFER: (flat-length)
[ class-types length 1 = ]
[ union-class? not ]
bi and
] contains? ;
] any? ;
: node-count-bias ( -- n )
45 node-count get [-] 8 /i ;

2
basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor Normal file → Executable file
View File

@ -118,7 +118,7 @@ M: #return-recursive unbox-tuples*
! These nodes never participate in unboxing
: assert-not-unboxed ( values -- )
dup array?
[ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if
[ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if
[ "Unboxing wrong value" throw ] when ;
M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;

2
basis/concurrency/mailboxes/mailboxes.factor Normal file → Executable file
View File

@ -25,7 +25,7 @@ M: mailbox dispose* threads>> notify-all ;
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
mailbox check-disposed
mailbox data>> pred dlist-contains? [
mailbox data>> pred dlist-any? [
mailbox timeout wait-for-mailbox
mailbox timeout pred block-unless-pred
] unless ; inline recursive

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"

2
basis/cpu/architecture/architecture.factor
View File

@ -38,7 +38,7 @@ M: object param-reg param-regs nth ;
HOOK: two-operand? cpu ( -- ? )
HOOK: %load-immediate cpu ( reg obj -- )
HOOK: %load-indirect cpu ( reg obj -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %peek cpu ( vreg loc -- )
HOOK: %replace cpu ( vreg loc -- )

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 ;

10
basis/cpu/ppc/ppc.factor
View File

@ -34,7 +34,7 @@ M: ppc two-operand? f ;
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
M: ppc %load-indirect ( reg obj -- )
M: ppc %load-reference ( reg obj -- )
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
M: ppc %alien-global ( register symbol dll -- )
@ -261,7 +261,7 @@ M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
M:: ppc %integer>bignum ( dst src temp -- )
[
"end" define-label
dst 0 >bignum %load-indirect
dst 0 >bignum %load-reference
! Is it zero? Then just go to the end and return this zero
0 src 0 CMPI
"end" get BEQ
@ -321,7 +321,7 @@ M:: ppc %integer>float ( dst src -- )
scratch-reg dup HEX: 8000 XORIS
scratch-reg 1 4 scratch@ STW
dst 1 0 scratch@ LFD
scratch-reg 4503601774854144.0 %load-indirect
scratch-reg 4503601774854144.0 %load-reference
fp-scratch-reg scratch-reg float-offset LFD
dst dst fp-scratch-reg FSUB ;
@ -488,7 +488,7 @@ M: ppc %epilogue ( n -- )
"end" define-label
dst \ f tag-number %load-immediate
"end" get word execute
dst \ t %load-indirect
dst \ t %load-reference
"end" get resolve-label ; inline
: %boolean ( dst temp cc -- )
@ -637,7 +637,7 @@ M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
3 swap %load-indirect "c_to_factor" f %alien-invoke ;
3 swap %load-reference "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke

2
basis/cpu/x86/32/32.factor
View File

@ -237,7 +237,7 @@ M: x86.32 %alien-indirect ( -- )
M: x86.32 %alien-callback ( quot -- )
4 [
EAX swap %load-indirect
EAX swap %load-reference
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;

2
basis/cpu/x86/64/64.factor
View File

@ -176,7 +176,7 @@ M: x86.64 %alien-indirect ( -- )
RBP CALL ;
M: x86.64 %alien-callback ( quot -- )
param-reg-1 swap %load-indirect
param-reg-1 swap %load-reference
"c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )

4
basis/cpu/x86/x86.factor
View File

@ -21,7 +21,7 @@ HOOK: param-reg-2 cpu ( -- reg )
M: x86 %load-immediate MOV ;
M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ;
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
@ -188,7 +188,7 @@ M:: x86 %integer>bignum ( dst src temp -- )
[
"end" define-label
! Load cached zero value
dst 0 >bignum %load-indirect
dst 0 >bignum %load-reference
src 0 CMP
! Is it zero? Then just go to the end and return this zero
"end" get JE

48
basis/csv/csv-docs.factor
View File

@ -1,28 +1,52 @@
USING: help.syntax help.markup kernel prettyprint sequences ;
USING: help.syntax help.markup kernel prettyprint sequences
io.pathnames ;
IN: csv
HELP: csv
{ $values { "stream" "an input stream" }
{ "rows" "an array of arrays of fields" } }
{ $description "parses a csv stream into an array of row arrays"
} ;
{ $description "Parses a csv stream into an array of row arrays." } ;
HELP: file>csv
{ $values
{ "path" pathname } { "encoding" "an encoding descriptor" }
{ "csv" "csv" }
}
{ $description "Opens a file and parses it into a sequence of comma-separated-value fields." } ;
HELP: csv>file
{ $values
{ "rows" "a sequence of sequences of strings" }
{ "path" pathname } { "encoding" "an encoding descriptor" }
}
{ $description "Writes a comma-separated-value structure to a file." } ;
HELP: csv-row
{ $values { "stream" "an input stream" }
{ "row" "an array of fields" } }
{ $description "parses a row from a csv stream"
} ;
{ $description "parses a row from a csv stream" } ;
HELP: write-csv
{ $values { "rows" "an sequence of sequences of strings" }
{ $values { "rows" "a sequence of sequences of strings" }
{ "stream" "an output stream" } }
{ $description "writes csv to the output stream, escaping where necessary"
} ;
{ $description "Writes a sequence of sequences of comma-separated-values to the output stream, escaping where necessary." } ;
HELP: with-delimiter
{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
{ $values { "ch" "field delimiter (e.g. CHAR: \t)" }
{ "quot" "a quotation" } }
{ $description "Sets the field delimiter for csv or csv-row words "
} ;
{ $description "Sets the field delimiter for csv or csv-row words." } ;
ARTICLE: "csv" "Comma-separated-values parsing and writing"
"The " { $vocab-link "csv" } " vocabulary can read and write CSV (comma-separated-value) files." $nl
"Reading a csv file:"
{ $subsection file>csv }
"Writing a csv file:"
{ $subsection csv>file }
"Changing the delimiter from a comma:"
{ $subsection with-delimiter }
"Reading from a stream:"
{ $subsection csv }
"Writing to a stream:"
{ $subsection write-csv } ;
ABOUT: "csv"

16
basis/csv/csv-tests.factor
View File

@ -1,5 +1,7 @@
USING: io.streams.string csv tools.test shuffle kernel strings
io.pathnames io.files.unique io.encodings.utf8 io.files
io.directories ;
IN: csv.tests
USING: io.streams.string csv tools.test shuffle kernel strings ;
! I like to name my unit tests
: named-unit-test ( name output input -- )
@ -76,3 +78,15 @@ USING: io.streams.string csv tools.test shuffle kernel strings ;
"escapes quotes commas and newlines when writing"
[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "
[ { { "writing" "some" "csv" "tests" } } ]
[
"writing,some,csv,tests"
"csv-test1-" unique-file utf8
[ set-file-contents ] [ file>csv ] [ drop delete-file ] 2tri
] unit-test
[ t ] [
{ { "writing,some,csv,tests" } } dup "csv-test2-"
unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
] unit-test

95
basis/csv/csv.factor Normal file → Executable file
View File

@ -1,89 +1,100 @@
! Copyright (C) 2007, 2008 Phil Dawes
! See http://factorcode.org/license.txt for BSD license.
! Simple CSV Parser
! Phil Dawes phil@phildawes.net
USING: kernel sequences io namespaces make
combinators unicode.categories ;
USING: kernel sequences io namespaces make combinators
unicode.categories io.files combinators.short-circuit ;
IN: csv
SYMBOL: delimiter
CHAR: , delimiter set-global
<PRIVATE
: delimiter> ( -- delimiter ) delimiter get ; inline
DEFER: quoted-field ( -- endchar )
! trims whitespace from either end of string
: trim-whitespace ( str -- str )
[ blank? ] trim ; inline
[ blank? ] trim ; inline
: skip-to-field-end ( -- endchar )
"\n" delimiter> suffix read-until nip ; inline
: not-quoted-field ( -- endchar )
"\"\n" delimiter> suffix read-until ! "
dup
{ { CHAR: " [ drop drop quoted-field ] } ! "
{ delimiter> [ swap trim-whitespace % ] }
{ CHAR: \n [ swap trim-whitespace % ] }
{ f [ swap trim-whitespace % ] } ! eof
} case ;
"\"\n" delimiter> suffix read-until
dup {
{ CHAR: " [ 2drop quoted-field ] }
{ delimiter> [ swap trim-whitespace % ] }
{ CHAR: \n [ swap trim-whitespace % ] }
{ f [ swap trim-whitespace % ] }
} case ;
: maybe-escaped-quote ( -- endchar )
read1 dup
{ { CHAR: " [ , quoted-field ] } ! " is an escaped quote
{ delimiter> [ ] } ! end of quoted field
{ CHAR: \n [ ] }
[ 2drop skip-to-field-end ] ! end of quoted field + padding
} case ;
read1 dup {
{ CHAR: " [ , quoted-field ] }
{ delimiter> [ ] }
{ CHAR: \n [ ] }
[ 2drop skip-to-field-end ]
} case ;
: quoted-field ( -- endchar )
"\"" read-until ! "
drop % maybe-escaped-quote ;
"\"" read-until
drop % maybe-escaped-quote ;
: field ( -- sep string )
[ not-quoted-field ] "" make ; ! trim-whitespace
[ not-quoted-field ] "" make ;
: (row) ( -- sep )
field ,
dup delimiter get = [ drop (row) ] when ;
field ,
dup delimiter get = [ drop (row) ] when ;
: row ( -- eof? array[string] )
[ (row) ] { } make ;
: append-if-row-not-empty ( row -- )
dup { "" } = [ drop ] [ , ] if ;
[ (row) ] { } make ;
: (csv) ( -- )
row append-if-row-not-empty
[ (csv) ] when ;
row harvest [ , ] unless-empty [ (csv) ] when ;
PRIVATE>
: csv-row ( stream -- row )
[ row nip ] with-input-stream ;
[ row nip ] with-input-stream ;
: csv ( stream -- rows )
[ [ (csv) ] { } make ] with-input-stream ;
[ [ (csv) ] { } make ] with-input-stream ;
: with-delimiter ( char quot -- )
delimiter swap with-variable ; inline
: file>csv ( path encoding -- csv )
<file-reader> csv ;
: with-delimiter ( ch quot -- )
[ delimiter ] dip with-variable ; inline
<PRIVATE
: needs-escaping? ( cell -- ? )
[ [ "\n\"" member? ] [ delimiter get = ] bi or ] contains? ; inline ! "
[ { [ "\n\"" member? ] [ delimiter get = ] } 1|| ] any? ; inline
: escape-quotes ( cell -- cell' )
[ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
[
[
[ , ]
[ dup CHAR: " = [ , ] [ drop ] if ] bi
] each
] "" make ; inline
: enclose-in-quotes ( cell -- cell' )
CHAR: " [ prefix ] [ suffix ] bi ; inline ! "
"\"" dup surround ; inline
: escape-if-required ( cell -- cell' )
dup needs-escaping? [ escape-quotes enclose-in-quotes ] when ; inline
dup needs-escaping?
[ escape-quotes enclose-in-quotes ] when ; inline
PRIVATE>
: write-row ( row -- )
[ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline
[ delimiter get write1 ]
[ escape-if-required write ] interleave nl ; inline
: write-csv ( rows stream -- )
[ [ write-row ] each ] with-output-stream ;
[ [ write-row ] each ] with-output-stream ;
: csv>file ( rows path encoding -- ) <file-writer> write-csv ;

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

@ -173,7 +173,7 @@ HELP: with-db
HELP: with-transaction
{ $values
{ "quot" quotation } }
{ $description "" } ;
{ $description "Calls the quotation inside a database transaction and commits the result to the database after the quotation finishes. If the quotation throws an error, the transaction is aborted." } ;
ARTICLE: "db" "Database library"
"Accessing a database:"
@ -244,13 +244,13 @@ ARTICLE: "db-protocol" "Low-level database protocol"
! { $subsection bind-tuple }
ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "."
"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." $nl
"Executing a SQL command:"
{ $subsection sql-command }
"Executing a query directly:"
{ $subsection sql-query }
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
{ $code <"
USING: db.sqlite db io.files ;
: with-book-db ( quot -- )

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 )

2
basis/db/queries/queries.factor Normal file → Executable file
View File

@ -19,7 +19,7 @@ SINGLETON: retryable
] if ;
: maybe-make-retryable ( statement -- statement )
dup in-params>> [ generator-bind? ] contains?
dup in-params>> [ generator-bind? ] any?
[ make-retryable ] when ;
: regenerate-params ( statement -- statement )

2
basis/db/sqlite/sqlite.factor Normal file → Executable file
View File

@ -294,7 +294,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
] with-string-writer ;
: can-be-null? ( -- ? )
"sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
"sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
: delete-cascade? ( -- ? )
"sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;

12
basis/db/tuples/tuples-docs.factor
View File

@ -1,9 +1,13 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel
quotations sequences strings multiline math db.types db ;
quotations sequences strings multiline math db.types
db.tuples.private db ;
IN: db.tuples
HELP: random-id-generator
{ $description "Used to tell " { $link eval-generator } " to generate a random number for use as a key." } ;
HELP: create-sql-statement
{ $values
{ "class" class }
@ -90,7 +94,7 @@ HELP: ensure-table
HELP: ensure-tables
{ $values
{ "classes" null } }
{ "classes" "a sequence of classes" } }
{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ;
HELP: recreate-table
@ -199,7 +203,7 @@ ARTICLE: "db-tuples-protocol" "Tuple database protocol"
{ $subsection <count-statement> } ;
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
"We're going to store books in this tutorial."
{ $code "TUPLE: book id title author date-published edition cover-price condition ;" }
"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
@ -246,7 +250,7 @@ T{ book
{ $code <" [
book get update-tuple
] with-book-tutorial "> }
"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
{ $code <" [
T{ book { title "Factor for Sheeple" } } select-tuples
] with-book-tutorial "> }

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

151
basis/db/types/types-docs.factor
View File

@ -4,53 +4,34 @@ USING: classes hashtables help.markup help.syntax io.streams.string
kernel sequences strings math ;
IN: db.types
HELP: +autoincrement+
{ $description "" } ;
HELP: +db-assigned-id+
{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
HELP: +default+
{ $description "" } ;
HELP: +foreign-id+
{ $description "" } ;
HELP: +has-many+
{ $description "" } ;
{ $description "Allows a default value for a column to be provided." } ;
HELP: +not-null+
{ $description "" } ;
{ $description "Ensures that a column is not null." } ;
HELP: +null+
{ $description "" } ;
{ $description "Allows a column to be null." } ;
HELP: +primary-key+
{ $description "" } ;
{ $description "Makes a column a primary key. Only one column may be a primary key." } ;
HELP: +random-id+
{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
HELP: +serial+
{ $description "" } ;
HELP: +unique+
{ $description "" } ;
HELP: +user-assigned-id+
{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
HELP: <generator-bind>
{ $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } }
{ $description "" } ;
{ $description "An internal constructor for creating objects containing parameters used for binding generated values to a tuple query." } ;
HELP: <literal-bind>
{ $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } }
{ $description "" } ;
HELP: <low-level-binding>
{ $values { "value" object } { "low-level-binding" low-level-binding } }
{ $description "" } ;
{ $description "An internal constructor for creating objects containing parameters used for binding literal values to a tuple query." } ;
HELP: BIG-INTEGER
{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
@ -108,87 +89,48 @@ HELP: VARCHAR
HELP: user-assigned-id-spec?
{ $values
{ "specs" "a sequence of sql specs" }
{ "specs" "a sequence of SQL specs" }
{ "?" "a boolean" } }
{ $description "Tests if any of the sql specs has the type " { $link +user-assigned-id+ } "." } ;
{ $description "Tests if any of the SQL specs has the type " { $link +user-assigned-id+ } "." } ;
HELP: bind#
{ $values
{ "spec" null } { "obj" object } }
{ $description "" } ;
{ "spec" "a SQL spec" } { "obj" object } }
{ $description "A generic word that lets a database construct a literal binding." } ;
HELP: bind%
{ $values
{ "spec" null } }
{ $description "" } ;
HELP: compound
{ $values
{ "string" string } { "obj" object }
{ "hash" hashtable } }
{ $description "" } ;
{ "spec" "a SQL spec" } }
{ $description "A generic word that lets a database output a binding." } ;
HELP: db-assigned-id-spec?
{ $values
{ "specs" "a sequence of sql specs" }
{ "specs" "a sequence of SQL specs" }
{ "?" "a boolean" } }
{ $description "Tests if any of the sql specs has the type " { $link +db-assigned-id+ } "." } ;
{ $description "Tests if any of the SQL specs has the type " { $link +db-assigned-id+ } "." } ;
HELP: find-primary-key
{ $values
{ "specs" "a sequence of sql-specs" }
{ "seq" "a sequence of sql-specs" } }
{ $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
{ "specs" "a sequence of SQL specs" }
{ "seq" "a sequence of SQL specs" } }
{ $description "Returns the rows from the SQL specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." }
{ $notes "This is a low-level word." } ;
HELP: generator-bind
{ $description "" } ;
HELP: get-slot-named
{ $values
{ "name" "a slot name" } { "tuple" tuple }
{ "value" "the value stored in the slot" } }
{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
HELP: literal-bind
{ $description "" } ;
HELP: lookup-create-type
{ $values
{ "obj" object }
{ "string" string } }
{ $description "" } ;
HELP: lookup-modifier
{ $values
{ "obj" object }
{ "string" string } }
{ $description "" } ;
HELP: lookup-type
{ $values
{ "obj" object }
{ "string" string } }
{ $description "" } ;
HELP: low-level-binding
{ $description "" } ;
HELP: modifiers
{ $values
{ "spec" null }
{ "string" string } }
{ $description "" } ;
HELP: no-sql-type
{ $values
{ "type" "a sql type" } }
{ $description "Throws an error containing a sql type that is unsupported or the result of a typo." } ;
{ "type" "a SQL type" } }
{ $description "Throws an error containing a SQL type that is unsupported or the result of a typo." } ;
HELP: normalize-spec
{ $values
{ "spec" null } }
{ $description "" } ;
{ "spec" "a SQL spec" } }
{ $description "Normalizes a SQL spec." } ;
HELP: offset-of-slot
{ $values
@ -196,62 +138,21 @@ HELP: offset-of-slot
{ "n" integer } }
{ $description "Returns the offset of a tuple slot accessed by name." } ;
HELP: persistent-table
{ $values
{ "hash" hashtable } }
{ $description "" } ;
HELP: primary-key?
{ $values
{ "spec" null }
{ "spec" "a SQL spec" }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: random-id-generator
{ $description "" } ;
{ $description "Returns true if a SQL spec is a primary key." } ;
HELP: relation?
{ $values
{ "spec" null }
{ "spec" "a SQL spec" }
{ "?" "a boolean" } }
{ $description "" } ;
HELP: remove-db-assigned-id
{ $values
{ "specs" null }
{ "obj" object } }
{ $description "" } ;
HELP: remove-id
{ $values
{ "specs" null }
{ "obj" object } }
{ $description "" } ;
HELP: remove-relations
{ $values
{ "specs" null }
{ "newcolumns" null } }
{ $description "" } ;
HELP: set-slot-named
{ $values
{ "value" null } { "name" null } { "obj" object } }
{ $description "" } ;
HELP: spec>tuple
{ $values
{ "class" class } { "spec" null }
{ "tuple" null } }
{ $description "" } ;
HELP: sql-spec
{ $description "" } ;
{ $description "Returns true if a SQL spec is a relation." } ;
HELP: unknown-modifier
{ $values { "modifier" string } }
{ $description "Throws an error containing an unknown sql modifier." } ;
{ $description "Throws an error containing an unknown SQL modifier." } ;
ARTICLE: "db.types" "Database types"
"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl

10
basis/db/types/types.factor Normal file → Executable file
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 ;
@ -71,10 +71,10 @@ ERROR: not-persistent class ;
primary-key>> +primary-key+? ;
: db-assigned-id-spec? ( specs -- ? )
[ primary-key>> +db-assigned-id+? ] contains? ;
[ primary-key>> +db-assigned-id+? ] any? ;
: user-assigned-id-spec? ( specs -- ? )
[ primary-key>> +user-assigned-id+? ] contains? ;
[ primary-key>> +user-assigned-id+? ] any? ;
: normalize-spec ( spec -- )
dup type>> dup +primary-key+? [
@ -105,7 +105,7 @@ FACTOR-BLOB NULL URL ;
dup normalize-spec ;
: spec>tuple ( class spec -- tuple )
3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
3 f pad-tail [ first3 ] keep 3 tail <sql-spec> ;
: number>string* ( n/string -- string )
dup number? [ number>string ] when ;

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

4
basis/dlists/dlists-docs.factor Normal file → Executable file
View File

@ -15,7 +15,7 @@ $nl
"Iterating over elements:"
{ $subsection dlist-each }
{ $subsection dlist-find }
{ $subsection dlist-contains? }
{ $subsection dlist-any? }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
{ $subsection delete-node-if }
@ -40,7 +40,7 @@ HELP: dlist-find
"This operation is O(n)."
} ;
HELP: dlist-contains?
HELP: dlist-any?
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ;

4
basis/dlists/dlists-tests.factor Normal file → Executable file
View File

@ -46,8 +46,8 @@ IN: dlists.tests
[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-any? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-any? ] unit-test
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test

21
basis/dlists/dlists.factor Normal file → Executable file
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,14 +115,13 @@ M: dlist pop-back* ( dlist -- )
normalize-front ;
: dlist-find ( dlist quot -- obj/f ? )
[ obj>> ] prepose
dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
'[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-contains? ( dlist quot -- ? )
: dlist-any? ( dlist quot -- ? )
dlist-find nip ; inline
M: dlist deque-member? ( value dlist -- ? )
[ = ] with dlist-contains? ;
[ = ] with dlist-any? ;
M: dlist delete-node ( dlist-node dlist -- )
{
@ -143,7 +142,7 @@ M: dlist delete-node ( dlist-node dlist -- )
] if ; inline
: delete-node-if ( dlist quot -- obj/f )
[ obj>> ] prepose delete-node-if* drop ; inline
'[ obj>> @ ] delete-node-if* drop ; inline
M: dlist clear-deque ( dlist -- )
f >>front
@ -151,7 +150,7 @@ M: dlist clear-deque ( dlist -- )
drop ;
: dlist-each ( dlist quot -- )
[ obj>> ] prepose dlist-each-node ; inline
'[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
[ ] accumulator [ dlist-each ] dip ;
@ -159,8 +158,6 @@ M: dlist clear-deque ( dlist -- )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
M: dlist clone
<dlist> [
[ push-back ] curry dlist-each
] keep ;
<dlist> [ '[ _ push-back ] dlist-each ] keep ;
INSTANCE: dlist deque

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

@ -7,12 +7,14 @@ HELP: (os-envs)
{ $values
{ "seq" sequence } }
{ $description "" } ;
{ $description "Returns a sequence of key/value pairs from the operating system." }
{ $notes "In most cases, use " { $link os-envs } " instead." } ;
HELP: (set-os-envs)
{ $values
{ "seq" sequence } }
{ $description "" } ;
{ $description "Low-level word for replacing the current set of environment variables." }
{ $notes "In most cases, use " { $link set-os-envs } " instead." } ;
HELP: os-env ( key -- value )

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

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
urls.encoding assocs xml.utilities ;
urls.encoding assocs xml.utilities xml.data ;
IN: farkup.tests
relative-link-prefix off
@ -92,22 +92,22 @@ link-no-follow? off
[ "<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>" ]
@ -161,9 +161,9 @@ link-no-follow? off
: check-link-escaping ( string -- link )
convert-farkup string>xml-chunk
"a" deep-tag-named "href" swap at url-decode ;
"a" deep-tag-named "href" attr url-decode ;
[ "Trader Joe's" ] [ "[[Trader Joe's]]" check-link-escaping ] unit-test
[ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test
[ "<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

128
basis/farkup/farkup.factor Normal file → Executable file
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators html.elements io
USING: accessors arrays combinators io
io.streams.string kernel math namespaces peg peg.ebnf
sequences sequences.deep strings xml.entities
vectors splitting xmode.code2html urls.encoding ;
sequences sequences.deep strings xml.entities xml.literals
vectors splitting xmode.code2html urls.encoding xml.data
xml.writer ;
IN: farkup
SYMBOL: relative-link-prefix
@ -33,7 +34,7 @@ TUPLE: line ;
TUPLE: line-break ;
: absolute-url? ( string -- ? )
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
{ "http://" "https://" "ftp://" } [ head? ] with any? ;
: simple-link-title ( string -- string' )
dup absolute-url? [ "/" split1-last swap or ] unless ;
@ -74,6 +75,7 @@ inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]]
link-content = (!("|"|"]").)+
=> [[ >string ]]
image-link = "[[image:" link-content "|" link-content "]]"
=> [[ [ second >string ] [ fourth >string ] bi image boa ]]
@ -146,7 +148,7 @@ named-code
simple-code
= "[{" (!("}]").)+ "}]"
=> [[ second f swap code boa ]]
=> [[ second >string f swap code boa ]]
code = named-code | simple-code
@ -160,69 +162,81 @@ stand-alone
: check-url ( href -- href' )
{
{ [ dup empty? ] [ drop invalid-url ] }
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
{ [ dup [ 127 > ] any? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
[ relative-link-prefix get prepend ]
} cond ;
[ relative-link-prefix get prepend "" like ]
} cond url-encode ;
: escape-link ( href text -- href-esc text-esc )
[ check-url ] dip escape-string ;
: write-link ( href text -- xml )
[ check-url link-no-follow? get "true" and ] dip
[XML <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 ;
: convert-farkup ( string -- string' )
parse-farkup [ (write-farkup) ] with-string-writer ;
[ write-farkup ] with-string-writer ;

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

@ -7,27 +7,29 @@ HELP: printf
{ $values { "format-string" string } }
{ $description
"Writes the arguments (specified on the stack) formatted according to the format string.\n"
"\n"
$nl
"Several format specifications exist for handling arguments of different types, and "
"specifying attributes for the result string, including such things as maximum width, "
"padding, and decimals.\n"
{ $table
{ "%%" "Single %" "" }
{ "%P.Ds" "String format" "string" }
{ "%P.DS" "String format uppercase" "string" }
{ "%c" "Character format" "char" }
{ "%C" "Character format uppercase" "char" }
{ "%+Pd" "Integer format" "fixnum" }
{ "%+P.De" "Scientific notation" "fixnum, float" }
{ "%+P.DE" "Scientific notation" "fixnum, float" }
{ "%+P.Df" "Fixed format" "fixnum, float" }
{ "%+Px" "Hexadecimal" "hex" }
{ "%+PX" "Hexadecimal uppercase" "hex" }
{ "%%" "Single %" "" }
{ "%P.Ds" "String format" "string" }
{ "%P.DS" "String format uppercase" "string" }
{ "%c" "Character format" "char" }
{ "%C" "Character format uppercase" "char" }
{ "%+Pd" "Integer format" "fixnum" }
{ "%+P.De" "Scientific notation" "fixnum, float" }
{ "%+P.DE" "Scientific notation" "fixnum, float" }
{ "%+P.Df" "Fixed format" "fixnum, float" }
{ "%+Px" "Hexadecimal" "hex" }
{ "%+PX" "Hexadecimal uppercase" "hex" }
{ "%[%?, %]" "Sequence format" "sequence" }
{ "%[%?: %? %]" "Assocs format" "assocs" }
}
"\n"
$nl
"A plus sign ('+') is used to optionally specify that the number should be "
"formatted with a '+' preceeding it if positive.\n"
"\n"
$nl
"Padding ('P') is used to optionally specify the minimum width of the result "
"string, the padding character, and the alignment. By default, the padding "
"character defaults to a space and the alignment defaults to right-aligned. "
@ -38,12 +40,12 @@ HELP: printf
"\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
"\"%-10d\" formats an integer to 10 characters wide and left-aligns."
}
"\n"
$nl
"Digits ('D') is used to optionally specify the maximum digits in the result "
"string. For example:\n"
{ $list
"\"%.3s\" formats a string to truncate at 3 characters (from the left)."
"\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
"\"%.10f\" formats a float to pad-tail with zeros up to 10 digits beyond the decimal point."
"\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
}
}
@ -72,6 +74,14 @@ HELP: printf
"USING: formatting ;"
"1234 \"%+d\" printf"
"+1234" }
{ $example
"USING: formatting ;"
"{ 1 2 3 } \"%[%d, %]\" printf"
"{ 1, 2, 3 }" }
{ $example
"USING: formatting ;"
"H{ { 1 2 } { 3 4 } } \"%[%d: %d %]\" printf"
"{ 1:2, 3:4 }" }
} ;
HELP: sprintf
@ -83,7 +93,7 @@ HELP: strftime
{ $values { "format-string" string } }
{ $description
"Writes the timestamp (specified on the stack) formatted according to the format string.\n"
"\n"
$nl
"Different attributes of the timestamp can be retrieved using format specifications.\n"
{ $table
{ "%a" "Abbreviated weekday name." }
@ -118,7 +128,7 @@ HELP: strftime
} ;
ARTICLE: "formatting" "Formatted printing"
"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing.\n"
"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing."
{ $subsection printf }
{ $subsection sprintf }
{ $subsection strftime }

24
basis/formatting/formatting.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays ascii calendar combinators fry kernel
USING: accessors arrays ascii assocs calendar combinators fry kernel
generalizations io io.encodings.ascii io.files io.streams.string
macros math math.functions math.parser peg.ebnf quotations
sequences splitting strings unicode.case vectors ;
@ -29,7 +29,7 @@ IN: formatting
[ 0 ] [ string>number ] if-empty ;
: pad-digits ( string digits -- string' )
[ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
[ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
: max-digits ( n digits -- n' )
10 swap ^ [ * round ] keep / ; inline
@ -48,7 +48,7 @@ IN: formatting
[ max-digits ] keep -rot
[
[ 0 < "-" "+" ? ]
[ abs number>string 2 CHAR: 0 pad-left ] bi
[ abs number>string 2 CHAR: 0 pad-head ] bi
"e" -rot 3append
]
[ number>string ] bi*
@ -60,7 +60,7 @@ zero = "0" => [[ CHAR: 0 ]]
char = "'" (.) => [[ second ]]
pad-char = (zero|char)? => [[ CHAR: \s or ]]
pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
pad-align = ("-")? => [[ \ pad-tail \ pad-head ? ]]
pad-width = ([0-9])* => [[ >digits ]]
pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
@ -75,8 +75,8 @@ digits = (digits_)? => [[ 6 or ]]
fmt-% = "%" => [[ [ "%" ] ]]
fmt-c = "c" => [[ [ 1string ] ]]
fmt-C = "C" => [[ [ 1string >upper ] ]]
fmt-s = "s" => [[ [ ] ]]
fmt-S = "S" => [[ [ >upper ] ]]
fmt-s = "s" => [[ [ dup number? [ number>string ] when ] ]]
fmt-S = "S" => [[ [ dup number? [ number>string ] when >upper ] ]]
fmt-d = "d" => [[ [ >fixnum number>string ] ]]
fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
@ -91,7 +91,13 @@ strings = pad width strings_ => [[ reverse compose-all ]]
numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
types = strings|numbers
lists = "[%" types ", %]" => [[ second '[ _ map ", " join "{ " prepend " }" append ] ]]
assocs = "[%" types ": %" types " %]" => [[ [ second ] [ fourth ] bi '[ unzip [ _ map ] dip _ map zip [ ":" join ] map ", " join "{ " prepend " }" append ] ]]
formats = "%" (types|fmt-%|lists|assocs|unknown) => [[ second '[ _ dip ] ]]
plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
@ -110,9 +116,9 @@ MACRO: printf ( format-string -- )
<PRIVATE
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-left ; inline
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline
: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-head ; inline
: >time ( timestamp -- string )
[ hour>> ] [ minute>> ] [ second>> floor ] tri 3array

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

2
basis/ftp/client/listing-parser/listing-parser.factor
View File

@ -39,7 +39,7 @@ name target ;
: parse-list-11 ( lines -- seq )
[
11 f pad-right
11 f pad-tail
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]

20
basis/functors/functors-tests.factor
View File

@ -34,7 +34,7 @@ WW DEFINES ${W}${W}
WHERE
: WW W twice ; inline
: WW ( a -- b ) \ W twice ; inline
;FUNCTOR
@ -45,3 +45,21 @@ WHERE
\ sqsq must-infer
[ 16 ] [ 2 sqsq ] unit-test
<<
FUNCTOR: wrapper-test-2 ( W -- )
W DEFINES ${W}
WHERE
: W ( a b -- c ) \ + execute ;
;FUNCTOR
"blah" wrapper-test-2
>>
[ 4 ] [ 1 3 blah ] unit-test

44
basis/functors/functors.factor
View File

@ -1,17 +1,43 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel quotations classes.tuple make combinators generic
words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser
locals.rewrite.closures vocabs.parser ;
locals.rewrite.closures vocabs.parser arrays accessors ;
IN: functors
: scan-param ( -- obj )
scan-object dup special? [ literalize ] unless ;
! This is a hack
<PRIVATE
: scan-param ( -- obj ) scan-object literalize ;
: define* ( word def effect -- ) pick set-word define-declared ;
TUPLE: fake-quotation seq ;
GENERIC: >fake-quotations ( quot -- fake )
M: callable >fake-quotations
>array >fake-quotations fake-quotation boa ;
M: array >fake-quotations [ >fake-quotations ] { } map-as ;
M: object >fake-quotations ;
GENERIC: fake-quotations> ( fake -- quot )
M: fake-quotation fake-quotations>
seq>> [ fake-quotations> ] map >quotation ;
M: array fake-quotations> [ fake-quotations> ] map ;
M: object fake-quotations> ;
: parse-definition* ( -- )
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
: `TUPLE:
@ -32,7 +58,7 @@ IN: functors
scan-param parsed
scan-param parsed
\ create-method parsed
parse-definition parsed
parse-definition*
DEFINE* ; parsing
: `C:
@ -45,7 +71,7 @@ IN: functors
: `:
effect off
scan-param parsed
parse-definition parsed
parse-definition*
DEFINE* ; parsing
: `INSTANCE:
@ -64,12 +90,16 @@ IN: functors
[ scan interpolate-locals ] dip
'[ _ with-string-writer @ ] parsed ;
PRIVATE>
: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
DEFER: ;FUNCTOR delimiter
<PRIVATE
: functor-words ( -- assoc )
H{
{ "TUPLE:" POSTPONE: `TUPLE: }
@ -104,4 +134,6 @@ DEFER: ;FUNCTOR delimiter
parse-functor-body swap pop-locals <lambda>
rewrite-closures first ;
PRIVATE>
: FUNCTOR: (FUNCTOR:) define ; parsing

1
basis/furnace/actions/actions.factor
View File

@ -10,7 +10,6 @@ furnace.utilities
furnace.redirection
furnace.conversations
html.forms
html.elements
html.components
html.components
html.templates.chloe

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

@ -105,9 +105,8 @@ ARTICLE: "furnace.auth.realm-config" "Authentication realm configuration"
"Instances of subclasses of " { $link realm } " have the following slots which may be set:"
{ $table
{ { $slot "name" } "A string identifying the realm for user interface purposes" }
{ { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } ". By default, the " { $link users-in-db } " provider is used." } }
{ { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } "). By default, the " { $link users-in-db } " provider is used." } }
{ { $slot "checksum" } { "An implementation of the checksum protocol used for verifying passwords (see " { $link "checksums" } "). The " { $link sha-256 } " checksum is used by default." } }
{ { $slot "users" } { "An authentication provider (see " { $link "furnace.auth.providers" } } }
{ { $slot "secure" } { "A boolean, that when set to a true value, forces the client to access the authentication realm via HTTPS. An attempt to access the realm via HTTP results in a redirect to the corresponding HTTPS URL. On by default." } }
} ;
@ -121,7 +120,7 @@ $nl
{ $subsection "furnace.auth.providers.db" } ;
ARTICLE: "furnace.auth.features" "Optional authentication features"
"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm."
"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm."
{ $subsection "furnace.auth.features.deactivate-user" }
{ $subsection "furnace.auth.features.edit-profile" }
{ $subsection "furnace.auth.features.recover-password" }
@ -148,7 +147,7 @@ ARTICLE: "furnace.auth.users" "User profiles"
"User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ;
ARTICLE: "furnace.auth.example" "Furnace authentication example"
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':"
"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message “You must log in to view your todo list”:"
{ $code
<" <protected>
"view your todo list" >>description">

2
basis/furnace/auth/features/edit-profile/edit-profile.factor Normal file → Executable file
View File

@ -31,7 +31,7 @@ IN: furnace.auth.features.edit-profile
} validate-params
{ "password" "new-password" "verify-password" }
[ value empty? not ] contains? [
[ value empty? not ] any? [
"password" value username check-login
[ "incorrect password" validation-error ] unless

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/auth/login/login.factor
View File

@ -16,7 +16,7 @@ IN: furnace.auth.login
SYMBOL: permit-id
: permit-id-key ( realm -- string )
[ >hex 2 CHAR: 0 pad-left ] { } map-as concat
[ >hex 2 CHAR: 0 pad-head ] { } map-as concat
"__p_" prepend ;
: client-permit-id ( realm -- id/f )

19
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -8,6 +8,7 @@ xml.data
xml.entities
xml.writer
xml.utilities
xml.literals
html.components
html.elements
html.forms
@ -20,7 +21,6 @@ http.server
http.server.redirection
http.server.responses
furnace.utilities ;
QUALIFIED-WITH: assocs a
IN: furnace.chloe-tags
! Chloe tags
@ -56,11 +56,11 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
: compile-link-attrs ( tag -- )
#! Side-effects current namespace.
attrs>> '[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
'[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
[ <a ] [code]
[ non-chloe-attrs-only compile-attrs ]
[ attrs>> non-chloe-attrs-only compile-attrs ]
[ compile-link-attrs ]
[ compile-a-url ]
tri
@ -116,17 +116,18 @@ CHLOE: form
} cleave
] compile-with-scope ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<div style="display: inline;"><button type="submit"></button></div>
</t:form>
;
: button-tag-markup ( -- xml )
<XML
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<div style="display: inline;"><button type="submit"></button></div>
</t:form>
XML> ;
: add-tag-attrs ( attrs tag -- )
attrs>> swap update ;
CHLOE: button
button-tag-markup string>xml body>>
button-tag-markup body>>
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]

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

8
basis/furnace/utilities/utilities-docs.factor
View File

@ -57,7 +57,7 @@ HELP: modify-redirect-query
HELP: nested-responders
{ $values { "seq" "a sequence of responders" } }
{ $description "" } ;
{ $description "Outputs a sequence of responders which participated in the processing of the current request, with the main responder first and the innermost responder last." } ;
HELP: referrer
{ $values { "referrer/f" { $maybe string } } }
@ -69,11 +69,11 @@ HELP: request-params
HELP: resolve-base-path
{ $values { "string" string } { "string'" string } }
{ $description "" } ;
{ $description "Resolves a responder-relative URL." } ;
HELP: resolve-template-path
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
{ $description "" } ;
{ $description "Resolves a responder-relative template path." } ;
HELP: same-host?
{ $values { "url" url } { "?" "a boolean" } }
@ -85,7 +85,7 @@ HELP: user-agent
HELP: vocab-path
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
{ $description "" } ;
{ $description "Outputs the full pathname of the vocabulary's source directory." } ;
HELP: exit-with
{ $values { "value" object } }

2
basis/furnace/utilities/utilities.factor Normal file → Executable file
View File

@ -29,7 +29,7 @@ ERROR: no-such-word name vocab ;
: base-path ( string -- pair )
dup responder-nesting get
[ second class superclasses [ name>> = ] with contains? ] with find nip
[ second class superclasses [ name>> = ] with any? ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )

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

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

5
basis/help/html/html-tests.factor
View File

@ -1,5 +1,4 @@
IN: help.html.tests
USING: html.streams classes.predicate help.topics help.markup
io.streams.string accessors prettyprint kernel tools.test ;
USING: help.html tools.test help.topics kernel ;
[ ] [ [ [ \ predicate-instance? def>> . ] with-html-writer ] with-string-writer drop ] unit-test
[ ] [ "xml" >link help>html drop ] unit-test

30
basis/help/html/html.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
io.files io.files.temp io.directories html.streams html.elements help kernel
io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
sorting debugger ;
sorting debugger html xml.literals xml.writer ;
IN: help.html
: escape-char ( ch -- )
@ -51,17 +51,21 @@ M: f topic>filename* drop \ f topic>filename* ;
] "" make
] [ 2drop f ] if ;
M: topic browser-link-href topic>filename ;
M: topic url-of topic>filename ;
: help-stylesheet ( -- )
"resource:basis/help/html/stylesheet.css" ascii file-contents write ;
: help-stylesheet ( -- string )
"resource:basis/help/html/stylesheet.css" ascii file-contents
[XML <style><-></style> XML] ;
: help>html ( topic -- )
dup topic>filename utf8 [
dup article-title
[ <style> help-stylesheet </style> ]
[ [ help ] with-html-writer ] simple-page
] with-file-writer ;
: help>html ( topic -- xml )
[ article-title ]
[ drop help-stylesheet ]
[ [ help ] with-html-writer ]
tri simple-page ;
: generate-help-file ( topic -- )
dup .
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
#! Hack.
@ -87,7 +91,7 @@ M: topic browser-link-href topic>filename ;
all-vocabs-really [ dup vocab-name ] { } map>assoc "vocabs.idx" serialize-index ;
: generate-help-files ( -- )
all-topics [ '[ _ help>html ] try ] each ;
all-topics [ '[ _ generate-help-file ] try ] each ;
: generate-help ( -- )
"docs" temp-file

123
basis/help/lint/lint.factor Normal file → Executable file
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? [
@ -40,7 +43,7 @@ IN: help.lint
$predicate
$class-description
$error-description
} swap '[ _ elements empty? not ] contains? ;
} swap '[ _ elements empty? not ] any? ;
: don't-check-word? ( word -- ? )
{
@ -64,8 +67,13 @@ IN: help.lint
]
} 2|| [ "$values don't match stack effect" throw ] unless ;
: check-see-also ( word element -- )
nip \ $see-also swap elements [
: check-nulls ( element -- )
\ $values swap elements
null swap deep-member?
[ "$values should not contain null" throw ] when ;
: check-see-also ( element -- )
\ $see-also swap elements [
rest dup prune [ length ] bi@ assert=
] each ;
@ -79,43 +87,88 @@ IN: help.lint
] each ;
: check-rendering ( element -- )
[ print-topic ] with-string-writer drop ;
[ print-content ] with-string-writer drop ;
: check-strings ( str -- )
[
"\n\t" intersects?
[ "Paragraph text should not contain \\n or \\t" throw ] when
] [
" " swap subseq?
[ "Paragraph text should not contain double spaces" throw ] when
] bi ;
: check-whitespace ( str1 str2 -- )
[ " " tail? ] [ " " head? ] bi* or
[ "Missing whitespace between strings" throw ] unless ;
: check-bogus-nl ( element -- )
{ { $nl } { { $nl } } } [ head? ] with any?
[ "Simple element should not begin with a paragraph break" throw ] when ;
: check-elements ( element -- )
{
[ check-bogus-nl ]
[ [ string? ] filter [ check-strings ] each ]
[ [ simple-element? ] filter [ check-elements ] each ]
[ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
} cleave ;
: check-descriptions ( element -- )
{ $description $class-description $var-description }
swap '[
_ elements [
rest { { } { "" } } member?
[ "Empty description" throw ] when
] each
] each ;
: check-markup ( element -- )
{
[ check-elements ]
[ check-rendering ]
[ check-examples ]
[ check-modules ]
[ check-descriptions ]
} cleave ;
: all-word-help ( words -- seq )
[ word-help ] filter ;
TUPLE: help-error topic error ;
TUPLE: help-error error topic ;
C: <help-error> 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 +188,7 @@ M: help-error error.
] keep ;
: check-about ( vocab -- )
[ vocab-help [ article drop ] when* ] check-something ;
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
: check-vocab ( vocab -- seq )
"Checking " write dup write "..." print

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

1
basis/html/components/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov
Daniel Ehrenberg

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

@ -1,4 +1,4 @@
! Copyright (C) 2008 Your name.
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string kernel strings
urls lcs inspector present io ;
@ -70,8 +70,8 @@ HELP: render
{ $description "Renders an HTML component to the " { $link output-stream } "." } ;
HELP: render*
{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } }
{ $contract "Renders an HTML component to the " { $link output-stream } "." } ;
{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } { "xml" "an XML chunk" } }
{ $contract "Renders an HTML component, outputting an XHTML snippet." } ;
ARTICLE: "html.components" "HTML components"
"The " { $vocab-link "html.components" } " vocabulary provides various HTML form components."
@ -100,6 +100,6 @@ $nl
{ $subsection farkup }
"Creating custom components:"
{ $subsection render* }
"Custom components can emit HTML using the " { $vocab-link "html.elements" } " vocabulary." ;
"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ;
ABOUT: "html.components"

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

@ -1,7 +1,8 @@
IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
html.elements html.components html.forms namespaces ;
html.components html.forms namespaces
xml.writer ;
[ ] [ begin-form ] unit-test
@ -31,7 +32,12 @@ TUPLE: color red green blue ;
] with-string-writer
] unit-test
[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
[
"red" hidden render
] with-string-writer
] unit-test
[ "<input value=\"&lt;jimmy>\" name=\"red\" type=\"hidden\"/>" ] [
[
"red" hidden render
] with-string-writer
@ -39,13 +45,13 @@ TUPLE: color red green blue ;
[ ] [ "'jimmy'" "red" set-value ] unit-test
[ "<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 +111,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 +122,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 +139,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 +155,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,7 +169,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ t ] [
[ "object" inspector render ] with-string-writer
[ "object" value [ describe ] with-html-writer ] with-string-writer
"object" value [ describe ] with-html-writer xml>string
=
] unit-test
@ -183,3 +189,9 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
}
}
] [ values ] unit-test
[ ] [ "error" "blah" <validation-error> "error" set-value ] unit-test
[ ] [
"error" hidden render
] unit-test

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

@ -1,56 +1,47 @@
! Copyright (C) 2008 Slava Pestov
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings inspector
fry locals calendar calendar.format xml.entities
validators urls present
xmode.code2html lcs.diff2html farkup
html.elements html.streams html.forms ;
fry locals calendar calendar.format xml.entities xml.data
validators urls present xml.writer xml.literals xml
xmode.code2html lcs.diff2html farkup io.streams.string
html html.streams html.forms ;
IN: html.components
GENERIC: render* ( value name renderer -- )
GENERIC: render* ( value name renderer -- xml )
: render ( name renderer -- )
prepare-value
[
dup validation-error?
[ [ message>> ] [ value>> ] bi ]
[ [ message>> render-error ] [ value>> ] bi ]
[ f swap ]
if
] 2dip
render*
[ render-error ] when* ;
<PRIVATE
: render-input ( value name type -- )
<input =type =name present =value input/> ;
PRIVATE>
swap 2array write-xml ;
SINGLETON: label
M: label render* 2drop present escape-string write ;
M: label render*
2drop present ;
SINGLETON: hidden
M: hidden render* drop "hidden" render-input ;
M: hidden render*
drop [XML <input value=<-> name=<-> type="hidden"/> XML] ;
: 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 +58,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 +74,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 +99,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 +117,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 +148,7 @@ M: farkup render*
nip
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
[ disable-images>> [ string>boolean disable-images? set ] when* ]
[ parsed>> string>boolean [ (write-farkup) ] [ write-farkup ] if ]
[ parsed>> string>boolean [ (write-farkup) ] [ farkup>xml ] if ]
tri
] with-scope ;
@ -180,4 +167,4 @@ M: comparison render*
! HTML component
SINGLETON: html
M: html render* 2drop write ;
M: html render* 2drop <unescaped> ;

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

@ -1,5 +1,5 @@
USING: help.markup help.syntax io present html ;
IN: html.elements
USING: help.markup help.syntax io present ;
ARTICLE: "html.elements" "HTML elements"
"The " { $vocab-link "html.elements" } " vocabulary provides words for writing HTML tags to the " { $link output-stream } " with a familiar look and feel in the code."
@ -14,16 +14,12 @@ $nl
{ $code "<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
"Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
{ $subsection write-html }
{ $subsection print-html }
"Writing some common HTML patterns:"
{ $subsection xhtml-preamble }
{ $subsection simple-page }
{ $subsection render-error } ;
{ $subsection print-html } ;
ABOUT: "html.elements"

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