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

db4
Aaron Schaefer 2009-02-01 18:33:03 -05:00
commit 3c02bcc065
548 changed files with 7340 additions and 5522 deletions

1
.gitignore vendored
View File

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

View File

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

View File

@ -15,7 +15,7 @@ IN: alien.remote-control
"void" { "long" } "cdecl" [ sleep ] alien-callback ; "void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien ) : ?callback ( word -- alien )
dup compiled>> [ execute ] [ drop f ] if ; inline dup optimized>> [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- ) : init-remote-control ( -- )
\ eval-callback ?callback 16 setenv \ eval-callback ?callback 16 setenv

View File

@ -57,8 +57,10 @@ HELP: >upper
{ $values { "str" "a string" } { "upper" "a string" } } { $values { "str" "a string" } { "upper" "a string" } }
{ $description "Converts an ASCII string to upper case." } ; { $description "Converts an ASCII string to upper case." } ;
ARTICLE: "ascii" "ASCII character classes" ARTICLE: "ascii" "ASCII"
"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:" "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 blank? }
{ $subsection letter? } { $subsection letter? }
{ $subsection LETTER? } { $subsection LETTER? }
@ -67,11 +69,10 @@ ARTICLE: "ascii" "ASCII character classes"
{ $subsection control? } { $subsection control? }
{ $subsection quotable? } { $subsection quotable? }
{ $subsection ascii? } { $subsection ascii? }
"ASCII case conversion is also implemented:" "ASCII case conversion:"
{ $subsection ch>lower } { $subsection ch>lower }
{ $subsection ch>upper } { $subsection ch>upper }
{ $subsection >lower } { $subsection >lower }
{ $subsection >upper } { $subsection >upper } ;
"Modern applications should use Unicode 5.1 instead (" { $vocab-link "unicode.categories" } ")." ;
ABOUT: "ascii" ABOUT: "ascii"

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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences USING: kernel math math.order sequences strings
combinators.short-circuit ; combinators.short-circuit hints ;
IN: ascii IN: ascii
: ascii? ( ch -- ? ) 0 127 between? ; inline : ascii? ( ch -- ? ) 0 127 between? ; inline
: blank? ( ch -- ? ) " \t\n\r" member? ; inline : blank? ( ch -- ? ) " \t\n\r" member? ; inline
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline : letter? ( ch -- ? ) CHAR: a CHAR: z between? ; 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 : digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ 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 -- ? ) HINTS: >lower string ;
"\0\e\r\n\t\u000008\u00007f" member? ; inline HINTS: >upper string ;
: 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 ;

View File

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

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

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler cpu.architecture vocabs.loader system USING: accessors compiler cpu.architecture vocabs.loader system
sequences namespaces parser kernel kernel.private classes sequences namespaces parser kernel kernel.private classes
@ -25,8 +25,8 @@ IN: bootstrap.compiler
enable-compiler enable-compiler
: compile-uncompiled ( words -- ) : compile-unoptimized ( words -- )
[ compiled>> not ] filter compile ; [ optimized>> not ] filter compile ;
nl nl
"Compiling..." write flush "Compiling..." write flush
@ -48,70 +48,70 @@ nl
wrap probe wrap probe
namestack* namestack*
} compile-uncompiled } compile-unoptimized
"." write flush "." write flush
{ {
bitand bitor bitxor bitnot bitand bitor bitxor bitnot
} compile-uncompiled } compile-unoptimized
"." write flush "." write flush
{ {
+ 1+ 1- 2/ < <= > >= shift + 1+ 1- 2/ < <= > >= shift
} compile-uncompiled } compile-unoptimized
"." write flush "." write flush
{ {
new-sequence nth push pop peek flip new-sequence nth push pop peek flip
} compile-uncompiled } compile-unoptimized
"." write flush "." write flush
{ {
hashcode* = get set hashcode* = get set
} compile-uncompiled } compile-unoptimized
"." write flush "." write flush
{ {
memq? split harvest sift cut cut-slice start index clone memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number set-at reverse push-all class number>string string>number
} compile-uncompiled } compile-unoptimized
"." write flush "." write flush
{ {
lines prefix suffix unclip new-assoc update lines prefix suffix unclip new-assoc update
word-prop set-word-prop 1array 2array 3array ?nth word-prop set-word-prop 1array 2array 3array ?nth
} compile-uncompiled } compile-unoptimized
"." write flush "." write flush
{ {
malloc calloc free memcpy malloc calloc free memcpy
} compile-uncompiled } compile-unoptimized
"." write flush "." write flush
{ build-tree } compile-uncompiled { build-tree } compile-unoptimized
"." write flush "." write flush
{ optimize-tree } compile-uncompiled { optimize-tree } compile-unoptimized
"." write flush "." write flush
{ optimize-cfg } compile-uncompiled { optimize-cfg } compile-unoptimized
"." write flush "." write flush
{ (compile) } compile-uncompiled { (compile) } compile-unoptimized
"." write flush "." write flush
vocabs [ words compile-uncompiled "." write flush ] each vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush " done" print flush

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. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic assocs hashtables assocs USING: alien arrays byte-arrays generic assocs hashtables assocs
hashtables.private io io.binary io.files io.encodings.binary 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 vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators quotations.private sequences.private combinators
math.order math.private accessors math.order math.private accessors
slots.private compiler.units ; slots.private compiler.units fry ;
IN: bootstrap.image IN: bootstrap.image
: arch ( os cpu -- arch ) : arch ( os cpu -- arch )
@ -73,7 +73,7 @@ SYMBOL: objects
: put-object ( n obj -- ) (objects) set-at ; : put-object ( n obj -- ) (objects) set-at ;
: cache-object ( obj quot -- value ) : cache-object ( obj quot -- value )
[ (objects) ] dip [ obj>> ] prepose cache ; inline [ (objects) ] dip '[ obj>> @ ] cache ; inline
! Constants ! Constants
@ -95,7 +95,7 @@ SYMBOL: objects
SYMBOL: sub-primitives SYMBOL: sub-primitives
: make-jit ( quot rc rt offset -- quad ) : make-jit ( quot rc rt offset -- quad )
{ [ { } make ] [ ] [ ] [ ] } spread 4array ; inline [ { } make ] 3dip 4array ; inline
: jit-define ( quot rc rt offset name -- ) : jit-define ( quot rc rt offset name -- )
[ make-jit ] dip set ; inline [ make-jit ] dip set ; inline
@ -344,25 +344,37 @@ M: wrapper '
[ emit ] emit-object ; [ emit ] emit-object ;
! Strings ! Strings
: native> ( object -- object )
big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
: emit-bytes ( seq -- ) : emit-bytes ( seq -- )
bootstrap-cell <groups> bootstrap-cell <groups> native> emit-seq ;
big-endian get [ [ be> ] map ] [ [ le> ] map ] if
emit-seq ;
: pad-bytes ( seq -- newseq ) : pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ; dup length bootstrap-cell align 0 pad-tail ;
: check-string ( string -- ) : extended-part ( str -- str' )
[ 127 > ] contains? dup [ 128 < ] all? [ drop f ] [
[ "Bootstrap cannot emit non-ASCII strings" throw ] when ; [ -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 ) : emit-string ( string -- ptr )
dup check-string [ length ] [ extended-part ' ] [ ] tri
string type-number object tag-number [ string type-number object tag-number [
dup length emit-fixnum [ emit-fixnum ]
f ' emit [ emit ]
f ' emit [ f ' emit ascii-part pad-bytes emit-bytes ]
pad-bytes emit-bytes tri*
] emit-object ; ] emit-object ;
M: string ' M: string '
@ -433,7 +445,7 @@ M: quotation '
array>> ' array>> '
quotation type-number object tag-number [ quotation type-number object tag-number [
emit ! array emit ! array
f ' emit ! compiled>> f ' emit ! compiled
0 emit ! xt 0 emit ! xt
0 emit ! code 0 emit ! code
] emit-object ] emit-object
@ -524,11 +536,9 @@ M: quotation '
! Image output ! Image output
: (write-image) ( image -- ) : (write-image) ( image -- )
bootstrap-cell big-endian get [ bootstrap-cell big-endian get
[ >be write ] curry each [ '[ _ >be write ] each ]
] [ [ '[ _ >le write ] each ] if ;
[ >le write ] curry each
] if ;
: write-image ( image -- ) : write-image ( image -- )
"Writing image to " write "Writing image to " write

View File

@ -13,7 +13,7 @@ SYMBOL: core-bootstrap-time
SYMBOL: bootstrap-time SYMBOL: bootstrap-time
: default-image-name ( -- string ) : 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 ; ".image" append resource-path ;
: do-crossref ( -- ) : do-crossref ( -- )
@ -42,7 +42,7 @@ SYMBOL: bootstrap-time
"Core bootstrap completed in " write core-bootstrap-time get print-time "Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write 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 [ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print [ ] count-words " words total" print

View File

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

View File

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

View File

@ -5,11 +5,11 @@ sequences io accessors arrays io.streams.string splitting
combinators accessors calendar calendar.format.macros present ; combinators accessors calendar calendar.format.macros present ;
IN: calendar.format 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 ; : write-00 ( n -- ) pad-00 write ;

View File

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

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 [ + + w+ ] 2dip swap set-nth ; inline
: prepare-message-schedule ( seq -- w-seq ) : 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> [ dup 16 64 dup <slice> [
process-M-256 process-M-256
] with each ; ] with each ;

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 } T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
} alias-analysis drop } alias-analysis drop
] unit-test ] unit-test

View File

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

View File

@ -36,13 +36,13 @@ TUPLE: ##alien-setter < ##effect { value vreg } ;
! Stack operations ! Stack operations
INSN: ##load-immediate < ##pure { val integer } ; INSN: ##load-immediate < ##pure { val integer } ;
INSN: ##load-indirect < ##pure obj ; INSN: ##load-reference < ##pure obj ;
GENERIC: ##load-literal ( dst value -- ) GENERIC: ##load-literal ( dst value -- )
M: fixnum ##load-literal tag-fixnum ##load-immediate ; M: fixnum ##load-literal tag-fixnum ##load-immediate ;
M: f ##load-literal drop \ f tag-number ##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: ##peek < ##read { loc loc } ;
INSN: ##replace < ##write { 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-float
##box-alien ##box-alien
} memq? } memq?
] contains? ; ] any? ;
: linearize-basic-block ( bb -- ) : linearize-basic-block ( bb -- )
[ number>> _label ] [ number>> _label ]

View File

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

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{ ##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 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> } 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{ ##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 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= } T{ ##compare-imm f V int-regs 6 V int-regs 4 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{ ##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 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> } 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{ ##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 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= } T{ ##compare-imm f V int-regs 6 V int-regs 4 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 M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ; [ dst>> register ] [ val>> ] bi %load-immediate ;
M: ##load-indirect generate-insn M: ##load-reference generate-insn
[ dst>> register ] [ obj>> ] bi %load-indirect ; [ dst>> register ] [ obj>> ] bi %load-reference ;
M: ##peek generate-insn M: ##peek generate-insn
[ dst>> register ] [ loc>> ] bi %peek ; [ dst>> register ] [ loc>> ] bi %peek ;
@ -400,7 +400,7 @@ M: no-such-symbol compiler-error-type
: check-dlsym ( symbols dll -- ) : check-dlsym ( symbols dll -- )
dup dll-valid? [ dup dll-valid? [
dupd '[ _ dlsym ] contains? dupd '[ _ dlsym ] any?
[ drop ] [ no-such-symbol ] if [ drop ] [ no-such-symbol ] if
] [ ] [
dll-path no-such-library drop dll-path no-such-library drop

View File

@ -24,7 +24,7 @@ SYMBOL: compiled
} cond drop ; } cond drop ;
: maybe-compile ( word -- ) : maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ; dup optimized>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+ SYMBOL: +failed+
@ -110,7 +110,7 @@ t compile-dependencies? set-global
[ (compile) yield-hook get call ] slurp-deque ; [ (compile) yield-hook get call ] slurp-deque ;
: decompile ( word -- ) : decompile ( word -- )
f 2array 1array t modify-code-heap ; f 2array 1array modify-code-heap ;
: optimized-recompile-hook ( words -- alist ) : optimized-recompile-hook ( words -- alist )
[ [

View File

@ -211,7 +211,7 @@ TUPLE: my-tuple ;
{ tuple vector } 3 slot { word } declare { tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ; 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 [ vector ] [ dispatch-alignment-regression ] unit-test
@ -276,3 +276,9 @@ TUPLE: id obj ;
[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test [ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] 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

View File

@ -9,7 +9,7 @@ IN: optimizer.tests
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
M: array xyz xyz ; M: array xyz xyz ;
[ t ] [ \ xyz compiled>> ] unit-test [ t ] [ \ xyz optimized>> ] unit-test
! Test predicate inlining ! Test predicate inlining
: pred-test-1 : pred-test-1
@ -94,7 +94,7 @@ TUPLE: pred-test ;
! regression ! regression
GENERIC: void-generic ( obj -- * ) GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ; : breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage compiled>> ] unit-test [ t ] [ \ breakage optimized>> ] unit-test
[ breakage ] must-fail [ breakage ] must-fail
! regression ! regression
@ -119,7 +119,7 @@ GENERIC: void-generic ( obj -- * )
! compiling <tuple> with a non-literal class failed ! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ; : <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression compiled>> ] unit-test [ t ] [ \ <tuple>-regression optimized>> ] unit-test
GENERIC: foozul ( a -- b ) GENERIC: foozul ( a -- b )
M: reversed foozul ; M: reversed foozul ;
@ -228,7 +228,7 @@ USE: binary-search.private
: node-successor-f-bug ( x -- * ) : node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; [ 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 [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
@ -242,7 +242,7 @@ USE: binary-search.private
] if ] if
] 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 [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" 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-1 ( -- a )
{ } recursive-inline-hang ; { } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test [ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
DEFER: recursive-inline-hang-3 DEFER: recursive-inline-hang-3

View File

@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
USE: tools.test USE: tools.test
[ t ] [ \ expr compiled>> ] unit-test [ t ] [ \ expr optimized>> ] unit-test
[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test [ t ] [ \ ast>pipeline-expr optimized>> ] unit-test

View File

@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ;
: hey ( -- ) ; : hey ( -- ) ;
: there ( -- ) hey ; : there ( -- ) hey ;
[ t ] [ \ hey compiled>> ] unit-test [ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there compiled>> ] unit-test [ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ hey compiled>> ] unit-test [ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there compiled>> ] unit-test [ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
[ t ] [ \ there compiled>> ] unit-test [ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ; : good ( -- ) ;
: bad ( -- ) good ; : bad ( -- ) good ;
: ugly ( -- ) bad ; : ugly ( -- ) bad ;
[ t ] [ \ good compiled>> ] unit-test [ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test [ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test [ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ good compiled>> ] unit-test [ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad compiled>> ] unit-test [ f ] [ \ bad optimized>> ] unit-test
[ f ] [ \ ugly compiled>> ] unit-test [ f ] [ \ ugly optimized>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test [ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test [ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
[ t ] [ \ good compiled>> ] unit-test [ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test [ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test [ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test [ f ] [ \ good compiled-usage assoc-empty? ] unit-test

View File

@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ; : sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] 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 [ 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 [ 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 [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] 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 [ 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 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

View File

@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [ 10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [ [ 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 ] unit-test
] times ] times

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 ] [ 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 [ 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 ) : 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 ] [ 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 [ 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 ) : resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [ [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@ -159,7 +159,7 @@ IN: compiler.tests
16 narray 16 narray
] if ; ] if ;
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test [ t ] [ \ resolve-spill-bug optimized>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] 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 ; : bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ; : stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ;
[ t ] [ [ t ] [
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains? [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
] unit-test ] unit-test
[ t f ] [ [ t f ] [
[ { "hi" } bleh ] ignore-errors [ { "hi" } bleh ] ignore-errors
\ + stack-trace-contains? \ + stack-trace-any?
\ > stack-trace-contains? \ > stack-trace-any?
] unit-test ] 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 : 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 ; branch-out get [ ] find nip swap head* >vector datastack set ;
M: #phi check-stack-flow* M: #phi check-stack-flow*
branch-out get [ ] contains? [ branch-out get [ ] any? [
[ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
] [ drop terminated? on ] if ; ] [ 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 ] [ [ t ] [
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree [ { 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 ] 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 '[ dup dup '[
_ keep swap [ drop t ] [ _ keep swap [ drop t ] [
dup #branch? [ dup #branch? [
children>> [ _ contains-node? ] contains? children>> [ _ contains-node? ] any?
] [ ] [
dup #recursive? [ dup #recursive? [
child>> _ contains-node? child>> _ contains-node?
] [ drop f ] if ] [ drop f ] if
] if ] if
] if ] if
] contains? ; inline recursive ] any? ; inline recursive
: select-children ( seq flags -- seq' ) : select-children ( seq flags -- seq' )
[ [ drop f ] unless ] 2map ; [ [ 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 ; dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
: some-outputs-dead? ( #call -- ? ) : some-outputs-dead? ( #call -- ? )
out-d>> [ live-value? not ] contains? ; out-d>> [ live-value? not ] any? ;
: maybe-drop-dead-outputs ( node -- nodes ) : maybe-drop-dead-outputs ( node -- nodes )
dup some-outputs-dead? [ dup some-outputs-dead? [

View File

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

View File

View File

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

View File

@ -118,7 +118,7 @@ M: #return-recursive unbox-tuples*
! These nodes never participate in unboxing ! These nodes never participate in unboxing
: assert-not-unboxed ( values -- ) : assert-not-unboxed ( values -- )
dup array? dup array?
[ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if [ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if
[ "Unboxing wrong value" throw ] when ; [ "Unboxing wrong value" throw ] when ;
M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ; 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 -- ? ) -- ) :: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
mailbox check-disposed mailbox check-disposed
mailbox data>> pred dlist-contains? [ mailbox data>> pred dlist-any? [
mailbox timeout wait-for-mailbox mailbox timeout wait-for-mailbox
mailbox timeout pred block-unless-pred mailbox timeout pred block-unless-pred
] unless ; inline recursive ] unless ; inline recursive

View File

@ -53,7 +53,8 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
{ $subsection reply-synchronous } { $subsection reply-synchronous }
"An example:" "An example:"
{ $example { $example
"USING: concurrency.messaging kernel threads ;" "USING: concurrency.messaging kernel prettyprint threads ;"
"IN: scratchpad"
": pong-server ( -- )" ": pong-server ( -- )"
" receive [ \"pong\" ] dip reply-synchronous ;" " receive [ \"pong\" ] dip reply-synchronous ;"
"[ pong-server t ] \"pong-server\" spawn-server" "[ pong-server t ] \"pong-server\" spawn-server"

View File

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

View File

@ -97,10 +97,10 @@ X: XOR 0 316 31
X: XOR. 1 316 31 X: XOR. 1 316 31
X1: EXTSB 0 954 31 X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31 X1: EXTSB. 1 954 31
: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ; : FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ; : FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ; : FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ; : FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
! XO-form ! XO-form
XO: ADD 0 0 266 31 XO: ADD 0 0 266 31

View File

@ -74,8 +74,8 @@ IN: cpu.ppc.assembler.backend
GENERIC# (B) 2 ( dest aa lk -- ) GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ; M: integer (B) 18 i-insn ;
M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ; M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ; M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
GENERIC: BC ( a b c -- ) GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ; M: integer BC 0 0 16 b-insn ;

View File

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

View File

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

View File

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

View File

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

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 IN: csv
HELP: csv HELP: csv
{ $values { "stream" "an input stream" } { $values { "stream" "an input stream" }
{ "rows" "an array of arrays of fields" } } { "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 HELP: csv-row
{ $values { "stream" "an input stream" } { $values { "stream" "an input stream" }
{ "row" "an array of fields" } } { "row" "an array of fields" } }
{ $description "parses a row from a csv stream" { $description "parses a row from a csv stream" } ;
} ;
HELP: write-csv HELP: write-csv
{ $values { "rows" "an sequence of sequences of strings" } { $values { "rows" "a sequence of sequences of strings" }
{ "stream" "an output stream" } } { "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 HELP: with-delimiter
{ $values { "char" "field delimiter (e.g. CHAR: \t)" } { $values { "ch" "field delimiter (e.g. CHAR: \t)" }
{ "quot" "a quotation" } } { "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"

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 IN: csv.tests
USING: io.streams.string csv tools.test shuffle kernel strings ;
! I like to name my unit tests ! I like to name my unit tests
: named-unit-test ( name output input -- ) : 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" "escapes quotes commas and newlines when writing"
[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ] [ "\"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 ! " [ { { "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

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

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

View File

@ -173,7 +173,7 @@ HELP: with-db
HELP: with-transaction HELP: with-transaction
{ $values { $values
{ "quot" quotation } } { "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" ARTICLE: "db" "Database library"
"Accessing a database:" "Accessing a database:"
@ -244,7 +244,7 @@ ARTICLE: "db-protocol" "Low-level database protocol"
! { $subsection bind-tuple } ! { $subsection bind-tuple }
ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial" 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:" "Executing a SQL command:"
{ $subsection sql-command } { $subsection sql-command }
"Executing a query directly:" "Executing a query directly:"

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 ; [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
M: postgresql-statement bind-tuple ( tuple statement -- ) M: postgresql-statement bind-tuple ( tuple statement -- )
tuck in-params>> [ nip ] [
in-params>>
[ postgresql-bind-conversion ] with map [ postgresql-bind-conversion ] with map
] 2bi
>>bind-params drop ; >>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n ) 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 ; ] if ;
: maybe-make-retryable ( statement -- statement ) : maybe-make-retryable ( statement -- statement )
dup in-params>> [ generator-bind? ] contains? dup in-params>> [ generator-bind? ] any?
[ make-retryable ] when ; [ make-retryable ] when ;
: regenerate-params ( statement -- statement ) : 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 ; ] with-string-writer ;
: can-be-null? ( -- ? ) : can-be-null? ( -- ? )
"sql-spec" get modifiers>> [ +not-null+ = ] contains? not ; "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
: delete-cascade? ( -- ? ) : delete-cascade? ( -- ? )
"sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ; "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;

View File

@ -1,9 +1,13 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel 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 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 HELP: create-sql-statement
{ $values { $values
{ "class" class } { "class" class }
@ -90,7 +94,7 @@ HELP: ensure-table
HELP: ensure-tables HELP: ensure-tables
{ $values { $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." } ; { $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 HELP: recreate-table

View File

@ -73,9 +73,10 @@ PRIVATE>
! High level ! High level
ERROR: no-slots-named class seq ; ERROR: no-slots-named class seq ;
: check-columns ( class columns -- ) : check-columns ( class columns -- )
tuck [ nip ] [
[ [ first ] map ] [ [ first ] map ]
[ all-slots [ name>> ] map ] bi* diff [ all-slots [ name>> ] map ] bi* diff
] 2bi
[ drop ] [ no-slots-named ] if-empty ; [ drop ] [ no-slots-named ] if-empty ;
: define-persistent ( class table columns -- ) : define-persistent ( class table columns -- )

View File

@ -4,53 +4,34 @@ USING: classes hashtables help.markup help.syntax io.streams.string
kernel sequences strings math ; kernel sequences strings math ;
IN: db.types IN: db.types
HELP: +autoincrement+
{ $description "" } ;
HELP: +db-assigned-id+ 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." } ; { $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+ HELP: +default+
{ $description "" } ; { $description "Allows a default value for a column to be provided." } ;
HELP: +foreign-id+
{ $description "" } ;
HELP: +has-many+
{ $description "" } ;
HELP: +not-null+ HELP: +not-null+
{ $description "" } ; { $description "Ensures that a column is not null." } ;
HELP: +null+ HELP: +null+
{ $description "" } ; { $description "Allows a column to be null." } ;
HELP: +primary-key+ HELP: +primary-key+
{ $description "" } ; { $description "Makes a column a primary key. Only one column may be a primary key." } ;
HELP: +random-id+ 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." } ; { $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+ 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+ } "." } ; { $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> HELP: <generator-bind>
{ $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" 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> HELP: <literal-bind>
{ $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } } { $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } }
{ $description "" } ; { $description "An internal constructor for creating objects containing parameters used for binding literal values to a tuple query." } ;
HELP: <low-level-binding>
{ $values { "value" object } { "low-level-binding" low-level-binding } }
{ $description "" } ;
HELP: BIG-INTEGER HELP: BIG-INTEGER
{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ; { $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? HELP: user-assigned-id-spec?
{ $values { $values
{ "specs" "a sequence of sql specs" } { "specs" "a sequence of SQL specs" }
{ "?" "a boolean" } } { "?" "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# HELP: bind#
{ $values { $values
{ "spec" null } { "obj" object } } { "spec" "a SQL spec" } { "obj" object } }
{ $description "" } ; { $description "A generic word that lets a database construct a literal binding." } ;
HELP: bind% HELP: bind%
{ $values { $values
{ "spec" null } } { "spec" "a SQL spec" } }
{ $description "" } ; { $description "A generic word that lets a database output a binding." } ;
HELP: compound
{ $values
{ "string" string } { "obj" object }
{ "hash" hashtable } }
{ $description "" } ;
HELP: db-assigned-id-spec? HELP: db-assigned-id-spec?
{ $values { $values
{ "specs" "a sequence of sql specs" } { "specs" "a sequence of SQL specs" }
{ "?" "a boolean" } } { "?" "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 HELP: find-primary-key
{ $values { $values
{ "specs" "a sequence of sql-specs" } { "specs" "a sequence of SQL specs" }
{ "seq" "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." } { $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." } ; { $notes "This is a low-level word." } ;
HELP: generator-bind
{ $description "" } ;
HELP: get-slot-named HELP: get-slot-named
{ $values { $values
{ "name" "a slot name" } { "tuple" tuple } { "name" "a slot name" } { "tuple" tuple }
{ "value" "the value stored in the slot" } } { "value" "the value stored in the slot" } }
{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ; { $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 HELP: no-sql-type
{ $values { $values
{ "type" "a sql type" } } { "type" "a SQL type" } }
{ $description "Throws an error containing a sql type that is unsupported or the result of a typo." } ; { $description "Throws an error containing a SQL type that is unsupported or the result of a typo." } ;
HELP: normalize-spec HELP: normalize-spec
{ $values { $values
{ "spec" null } } { "spec" "a SQL spec" } }
{ $description "" } ; { $description "Normalizes a SQL spec." } ;
HELP: offset-of-slot HELP: offset-of-slot
{ $values { $values
@ -196,62 +138,21 @@ HELP: offset-of-slot
{ "n" integer } } { "n" integer } }
{ $description "Returns the offset of a tuple slot accessed by name." } ; { $description "Returns the offset of a tuple slot accessed by name." } ;
HELP: persistent-table
{ $values
{ "hash" hashtable } }
{ $description "" } ;
HELP: primary-key? HELP: primary-key?
{ $values { $values
{ "spec" null } { "spec" "a SQL spec" }
{ "?" "a boolean" } } { "?" "a boolean" } }
{ $description "" } ; { $description "Returns true if a SQL spec is a primary key." } ;
HELP: random-id-generator
{ $description "" } ;
HELP: relation? HELP: relation?
{ $values { $values
{ "spec" null } { "spec" "a SQL spec" }
{ "?" "a boolean" } } { "?" "a boolean" } }
{ $description "" } ; { $description "Returns true if a SQL spec is a relation." } ;
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 "" } ;
HELP: unknown-modifier HELP: unknown-modifier
{ $values { "modifier" string } } { $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" ARTICLE: "db.types" "Database types"
"The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl "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>> ; slot-named dup [ no-slot ] unless offset>> ;
: get-slot-named ( name tuple -- value ) : get-slot-named ( name tuple -- value )
tuck offset-of-slot slot ; [ nip ] [ offset-of-slot ] 2bi slot ;
: set-slot-named ( value name obj -- ) : set-slot-named ( value name obj -- )
tuck offset-of-slot set-slot ; [ nip ] [ offset-of-slot ] 2bi set-slot ;
ERROR: not-persistent class ; ERROR: not-persistent class ;
@ -71,10 +71,10 @@ ERROR: not-persistent class ;
primary-key>> +primary-key+? ; primary-key>> +primary-key+? ;
: db-assigned-id-spec? ( specs -- ? ) : db-assigned-id-spec? ( specs -- ? )
[ primary-key>> +db-assigned-id+? ] contains? ; [ primary-key>> +db-assigned-id+? ] any? ;
: user-assigned-id-spec? ( specs -- ? ) : user-assigned-id-spec? ( specs -- ? )
[ primary-key>> +user-assigned-id+? ] contains? ; [ primary-key>> +user-assigned-id+? ] any? ;
: normalize-spec ( spec -- ) : normalize-spec ( spec -- )
dup type>> dup +primary-key+? [ dup type>> dup +primary-key+? [
@ -105,7 +105,7 @@ FACTOR-BLOB NULL URL ;
dup normalize-spec ; dup normalize-spec ;
: spec>tuple ( class spec -- tuple ) : 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 ) : number>string* ( n/string -- string )
dup number? [ number>string ] when ; dup number? [ number>string ] when ;

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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math ; USING: kernel sequences math fry ;
IN: deques IN: deques
GENERIC: push-front* ( obj deque -- node ) GENERIC: push-front* ( obj deque -- node )
@ -34,7 +34,8 @@ GENERIC: deque-empty? ( deque -- ? )
[ peek-back ] [ pop-back* ] bi ; [ peek-back ] [ pop-back* ] bi ;
: slurp-deque ( deque quot -- ) : slurp-deque ( deque quot -- )
[ drop [ deque-empty? not ] curry ] [ drop '[ _ deque-empty? not ] ]
[ [ pop-back ] prepose curry ] 2bi [ ] while ; inline [ '[ _ pop-back @ ] ]
2bi [ ] while ; inline
MIXIN: deque MIXIN: deque

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

@ -15,7 +15,7 @@ $nl
"Iterating over elements:" "Iterating over elements:"
{ $subsection dlist-each } { $subsection dlist-each }
{ $subsection dlist-find } { $subsection dlist-find }
{ $subsection dlist-contains? } { $subsection dlist-any? }
"Deleting a node matching a predicate:" "Deleting a node matching a predicate:"
{ $subsection delete-node-if* } { $subsection delete-node-if* }
{ $subsection delete-node-if } { $subsection delete-node-if }
@ -40,7 +40,7 @@ HELP: dlist-find
"This operation is O(n)." "This operation is O(n)."
} ; } ;
HELP: dlist-contains? HELP: dlist-any?
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } } { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." } { $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ; { $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 [ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
[ 1 t ] [ <dlist> 1 over push-back [ 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 f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test [ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-any? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] 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 [ 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 [ 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. ! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences accessors deques USING: combinators kernel math sequences accessors deques
search-deques summary hashtables ; search-deques summary hashtables fry ;
IN: dlists IN: dlists
<PRIVATE <PRIVATE
@ -64,7 +64,7 @@ M: dlist-node node-value obj>> ;
[ front>> ] dip (dlist-find-node) ; inline [ front>> ] dip (dlist-find-node) ; inline
: dlist-each-node ( dlist quot -- ) : dlist-each-node ( dlist quot -- )
[ f ] compose dlist-find-node 2drop ; inline '[ @ f ] dlist-find-node 2drop ; inline
: unlink-node ( dlist-node -- ) : unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when dup prev>> over next>> set-prev-when
@ -115,14 +115,13 @@ M: dlist pop-back* ( dlist -- )
normalize-front ; normalize-front ;
: dlist-find ( dlist quot -- obj/f ? ) : dlist-find ( dlist quot -- obj/f ? )
[ obj>> ] prepose '[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-contains? ( dlist quot -- ? ) : dlist-any? ( dlist quot -- ? )
dlist-find nip ; inline dlist-find nip ; inline
M: dlist deque-member? ( value dlist -- ? ) M: dlist deque-member? ( value dlist -- ? )
[ = ] with dlist-contains? ; [ = ] with dlist-any? ;
M: dlist delete-node ( dlist-node dlist -- ) M: dlist delete-node ( dlist-node dlist -- )
{ {
@ -143,7 +142,7 @@ M: dlist delete-node ( dlist-node dlist -- )
] if ; inline ] if ; inline
: delete-node-if ( dlist quot -- obj/f ) : 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 -- ) M: dlist clear-deque ( dlist -- )
f >>front f >>front
@ -151,7 +150,7 @@ M: dlist clear-deque ( dlist -- )
drop ; drop ;
: dlist-each ( dlist quot -- ) : dlist-each ( dlist quot -- )
[ obj>> ] prepose dlist-each-node ; inline '[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq ) : dlist>seq ( dlist -- seq )
[ ] accumulator [ dlist-each ] dip ; [ ] accumulator [ dlist-each ] dip ;
@ -159,8 +158,6 @@ M: dlist clear-deque ( dlist -- )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ; : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
M: dlist clone M: dlist clone
<dlist> [ <dlist> [ '[ _ push-back ] dlist-each ] keep ;
[ push-back ] curry dlist-each
] keep ;
INSTANCE: dlist deque INSTANCE: dlist deque

View File

@ -7,12 +7,14 @@ HELP: (os-envs)
{ $values { $values
{ "seq" sequence } } { "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) HELP: (set-os-envs)
{ $values { $values
{ "seq" sequence } } { "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 ) HELP: os-env ( key -- value )

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." } ; { $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" 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 }
{ $subsection eval>string } ; { $subsection eval>string } ;

View File

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: splitting parser compiler.units kernel namespaces USING: splitting parser compiler.units kernel namespaces
debugger io.streams.string ; debugger io.streams.string fry ;
IN: eval IN: eval
: parse-string ( str -- )
[ string-lines parse-lines ] with-compilation-unit ;
: (eval) ( str -- )
parse-string call ;
: eval ( str -- ) : 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 ) : eval>string ( str -- output )
[ [ (eval>string) ] with-file-vocabs ;
parser-notes off
[ [ eval ] keep ] try drop
] with-string-writer ;

View File

@ -14,8 +14,8 @@ HELP: parse-farkup ( string -- farkup )
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ; { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
HELP: (write-farkup) HELP: (write-farkup)
{ $values { "farkup" "a Farkup syntax tree node" } } { $values { "farkup" "a Farkup syntax tree node" } { "xml" "an XML chunk" } }
{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ; { $description "Converts a Farkup syntax tree node to XML." } ;
ARTICLE: "farkup-ast" "Farkup syntax tree nodes" 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 } "." "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 } "."

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test namespaces xml 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 IN: farkup.tests
relative-link-prefix off relative-link-prefix off
@ -92,22 +92,22 @@ link-no-follow? off
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test [ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=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 [ "[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\"/></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><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\">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=\"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><a href=\"Foo/Bar\">Bar</a></p>" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
"/wiki/view/" relative-link-prefix [ "/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 ] with-variable
[ ] [ "[{}]" convert-farkup drop ] unit-test [ ] [ "[{}]" 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>" "<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 ] [ "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." "This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server."
convert-farkup convert-farkup
] unit-test ] 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 [ "<p>&lt;foo&gt;</p>" ] [ "<foo>" convert-farkup ] unit-test
@ -138,10 +138,10 @@ link-no-follow? off
[ "<hr/>" ] [ "___" convert-farkup ] unit-test [ "<hr/>" ] [ "___" convert-farkup ] unit-test
[ "<hr/>\n" ] [ "___\n" 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 [ "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 [ "[[Factor]]-rific!" convert-farkup ] unit-test
[ "<p>[ factor { 1 2 3 }]</p>" ] [ "<p>[ factor { 1 2 3 }]</p>" ]
@ -161,9 +161,9 @@ link-no-follow? off
: check-link-escaping ( string -- link ) : check-link-escaping ( string -- link )
convert-farkup string>xml-chunk 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 [ "<foo>" ] [ "[[<foo>]]" check-link-escaping ] unit-test
[ "&blah;" ] [ "[[&blah;]]" 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 io.streams.string kernel math namespaces peg peg.ebnf
sequences sequences.deep strings xml.entities sequences sequences.deep strings xml.entities xml.literals
vectors splitting xmode.code2html urls.encoding ; vectors splitting xmode.code2html urls.encoding xml.data
xml.writer ;
IN: farkup IN: farkup
SYMBOL: relative-link-prefix SYMBOL: relative-link-prefix
@ -33,7 +34,7 @@ TUPLE: line ;
TUPLE: line-break ; TUPLE: line-break ;
: absolute-url? ( string -- ? ) : absolute-url? ( string -- ? )
{ "http://" "https://" "ftp://" } [ head? ] with contains? ; { "http://" "https://" "ftp://" } [ head? ] with any? ;
: simple-link-title ( string -- string' ) : simple-link-title ( string -- string' )
dup absolute-url? [ "/" split1-last swap or ] unless ; dup absolute-url? [ "/" split1-last swap or ] unless ;
@ -74,6 +75,7 @@ inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]] => [[ second >string inline-code boa ]]
link-content = (!("|"|"]").)+ link-content = (!("|"|"]").)+
=> [[ >string ]]
image-link = "[[image:" link-content "|" link-content "]]" image-link = "[[image:" link-content "|" link-content "]]"
=> [[ [ second >string ] [ fourth >string ] bi image boa ]] => [[ [ second >string ] [ fourth >string ] bi image boa ]]
@ -146,7 +148,7 @@ named-code
simple-code simple-code
= "[{" (!("}]").)+ "}]" = "[{" (!("}]").)+ "}]"
=> [[ second f swap code boa ]] => [[ second >string f swap code boa ]]
code = named-code | simple-code code = named-code | simple-code
@ -160,69 +162,81 @@ stand-alone
: check-url ( href -- href' ) : check-url ( href -- href' )
{ {
{ [ dup empty? ] [ drop invalid-url ] } { [ dup empty? ] [ drop invalid-url ] }
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] } { [ dup [ 127 > ] any? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] } { [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] } { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
[ relative-link-prefix get prepend ] [ relative-link-prefix get prepend "" like ]
} cond ; } cond url-encode ;
: escape-link ( href text -- href-esc text-esc ) : write-link ( href text -- xml )
[ check-url ] dip escape-string ; [ check-url link-no-follow? get "true" and ] dip
[XML <a href=<-> nofollow=<->><-></a> XML] ;
: write-link ( href text -- ) : write-image-link ( href text -- xml )
escape-link
[ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
[ write </a> ]
bi* ;
: write-image-link ( href text -- )
disable-images? get [ disable-images? get [
2drop 2drop
<strong> "Images are not allowed" write </strong> [XML <strong>Images are not allowed</strong> XML]
] [ ] [
escape-link [ check-url ] [ f like ] bi*
[ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi* [XML <img src=<-> alt=<->/> XML]
] if ; ] if ;
: render-code ( string mode -- string' ) : render-code ( string mode -- xml )
[ string-lines ] dip [ string-lines ] dip htmlize-lines
[ [XML <pre><-></pre> XML] ;
<pre>
htmlize-lines
</pre>
] with-string-writer write ;
GENERIC: (write-farkup) ( farkup -- ) GENERIC: (write-farkup) ( farkup -- xml )
: <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 ;
: 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) ; parse-farkup (write-farkup) ;
: write-farkup ( string -- )
farkup>xml write-xml ;
: convert-farkup ( string -- string' ) : convert-farkup ( string -- string' )
parse-farkup [ (write-farkup) ] with-string-writer ; [ write-farkup ] with-string-writer ;

View File

@ -7,7 +7,7 @@ HELP: printf
{ $values { "format-string" string } } { $values { "format-string" string } }
{ $description { $description
"Writes the arguments (specified on the stack) formatted according to the format string.\n" "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 " "Several format specifications exist for handling arguments of different types, and "
"specifying attributes for the result string, including such things as maximum width, " "specifying attributes for the result string, including such things as maximum width, "
"padding, and decimals.\n" "padding, and decimals.\n"
@ -23,11 +23,13 @@ HELP: printf
{ "%+P.Df" "Fixed format" "fixnum, float" } { "%+P.Df" "Fixed format" "fixnum, float" }
{ "%+Px" "Hexadecimal" "hex" } { "%+Px" "Hexadecimal" "hex" }
{ "%+PX" "Hexadecimal uppercase" "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 " "A plus sign ('+') is used to optionally specify that the number should be "
"formatted with a '+' preceeding it if positive.\n" "formatted with a '+' preceeding it if positive.\n"
"\n" $nl
"Padding ('P') is used to optionally specify the minimum width of the result " "Padding ('P') is used to optionally specify the minimum width of the result "
"string, the padding character, and the alignment. By default, the padding " "string, the padding character, and the alignment. By default, the padding "
"character defaults to a space and the alignment defaults to right-aligned. " "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." "\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
"\"%-10d\" formats an integer to 10 characters wide and left-aligns." "\"%-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 " "Digits ('D') is used to optionally specify the maximum digits in the result "
"string. For example:\n" "string. For example:\n"
{ $list { $list
"\"%.3s\" formats a string to truncate at 3 characters (from the left)." "\"%.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." "\"%.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 ;" "USING: formatting ;"
"1234 \"%+d\" printf" "1234 \"%+d\" printf"
"+1234" } "+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 HELP: sprintf
@ -83,7 +93,7 @@ HELP: strftime
{ $values { "format-string" string } } { $values { "format-string" string } }
{ $description { $description
"Writes the timestamp (specified on the stack) formatted according to the format string.\n" "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" "Different attributes of the timestamp can be retrieved using format specifications.\n"
{ $table { $table
{ "%a" "Abbreviated weekday name." } { "%a" "Abbreviated weekday name." }
@ -118,7 +128,7 @@ HELP: strftime
} ; } ;
ARTICLE: "formatting" "Formatted printing" 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 printf }
{ $subsection sprintf } { $subsection sprintf }
{ $subsection strftime } { $subsection strftime }

View File

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

View File

@ -69,18 +69,18 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"'[ [ _ key? ] all? ] filter" "'[ [ _ key? ] all? ] filter"
"[ [ key? ] curry all? ] curry 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 { $code
"'[ 3 _ + 4 _ / ]" "'[ 3 _ + 4 _ / ]"
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]" "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
} ; } ;
ARTICLE: "fry" "Fried quotations" 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 $nl
"Fried quotations are started by a special parsing word:" "Fried quotations are started by a special parsing word:"
{ $subsection POSTPONE: '[ } { $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 _ }
{ $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." "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."

View File

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

View File

@ -34,7 +34,7 @@ WW DEFINES ${W}${W}
WHERE WHERE
: WW W twice ; inline : WW ( a -- b ) \ W twice ; inline
;FUNCTOR ;FUNCTOR
@ -45,3 +45,21 @@ WHERE
\ sqsq must-infer \ sqsq must-infer
[ 16 ] [ 2 sqsq ] unit-test [ 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

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

View File

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

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:" "Instances of subclasses of " { $link realm } " have the following slots which may be set:"
{ $table { $table
{ { $slot "name" } "A string identifying the realm for user interface purposes" } { { $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 "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." } } { { $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." } }
} ; } ;
@ -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." ; "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" 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 { $code
<" <protected> <" <protected>
"view your todo list" >>description"> "view your todo list" >>description">

View File

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

View File

@ -27,7 +27,7 @@ SYMBOL: lost-password-from
over email>> 1array >>to over email>> 1array >>to
[ [
"This e-mail was sent by the application server on " % current-host % "\n" % "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 ``" % "login form, and requested a new password for the user named ``" %
over username>> % "''.\n" % over username>> % "''.\n" %
"\n" % "\n" %

View File

@ -16,7 +16,7 @@ IN: furnace.auth.login
SYMBOL: permit-id SYMBOL: permit-id
: permit-id-key ( realm -- string ) : 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 ; "__p_" prepend ;
: client-permit-id ( realm -- id/f ) : client-permit-id ( realm -- id/f )

View File

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

View File

@ -29,7 +29,7 @@ HELP: feed-entry-date
HELP: feed-entry-description HELP: feed-entry-description
{ $values { $values
{ "object" object } { "object" object }
{ "description" null } { "description" string }
} }
{ $contract "Outputs a feed entry description." } ; { $contract "Outputs a feed entry description." } ;

View File

@ -57,7 +57,7 @@ HELP: modify-redirect-query
HELP: nested-responders HELP: nested-responders
{ $values { "seq" "a sequence of 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 HELP: referrer
{ $values { "referrer/f" { $maybe string } } } { $values { "referrer/f" { $maybe string } } }
@ -69,11 +69,11 @@ HELP: request-params
HELP: resolve-base-path HELP: resolve-base-path
{ $values { "string" string } { "string'" string } } { $values { "string" string } { "string'" string } }
{ $description "" } ; { $description "Resolves a responder-relative URL." } ;
HELP: resolve-template-path HELP: resolve-template-path
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } } { $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
{ $description "" } ; { $description "Resolves a responder-relative template path." } ;
HELP: same-host? HELP: same-host?
{ $values { "url" url } { "?" "a boolean" } } { $values { "url" url } { "?" "a boolean" } }
@ -85,7 +85,7 @@ HELP: user-agent
HELP: vocab-path HELP: vocab-path
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } } { $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
{ $description "" } ; { $description "Outputs the full pathname of the vocabulary's source directory." } ;
HELP: exit-with HELP: exit-with
{ $values { "value" object } } { $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 ) : base-path ( string -- pair )
dup responder-nesting get 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 ; [ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' ) : resolve-base-path ( string -- string' )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences USING: kernel math math.order strings arrays vectors sequences
sequences.private accessors ; sequences.private accessors fry ;
IN: grouping IN: grouping
<PRIVATE <PRIVATE
@ -94,7 +94,7 @@ INSTANCE: sliced-clumps slice-chunking
[ first2-unsafe ] dip call [ first2-unsafe ] dip call
] [ ] [
[ 2 <sliced-clumps> ] dip [ 2 <sliced-clumps> ] dip
[ first2-unsafe ] prepose all? '[ first2-unsafe @ ] all?
] if ] if
] if ; inline ] if ; inline

View File

@ -162,7 +162,8 @@ ARTICLE: "encodings-introduction" "An introduction to encodings"
{ $code "\"file.txt\" utf16 file-contents" } { $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." "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 $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" ARTICLE: "io" "Input and output"
{ $heading "Streams" } { $heading "Streams" }

View File

@ -36,6 +36,7 @@ ARTICLE: "block-elements" "Block elements"
"Elements used in " { $link $values } " forms:" "Elements used in " { $link $values } " forms:"
{ $subsection $instance } { $subsection $instance }
{ $subsection $maybe } { $subsection $maybe }
{ $subsection $or }
{ $subsection $quotation } { $subsection $quotation }
"Boilerplate paragraphs:" "Boilerplate paragraphs:"
{ $subsection $low-level-note } { $subsection $low-level-note }
@ -88,6 +89,12 @@ $nl
{ "an array of markup elements," } { "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" } { "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 "element-types" }
{ $subsection "printing-elements" } { $subsection "printing-elements" }
"Related words can be cross-referenced:" "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." "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 "browsing-help" }
{ $subsection "writing-help" } { $subsection "writing-help" }
{ $vocab-subsection "Help lint tool" "help.lint" } { $subsection "help.lint" }
{ $subsection "help-impl" } ; { $subsection "help-impl" } ;
IN: help IN: help

View File

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

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

113
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. ! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors sequences parser kernel help help.markup USING: fry accessors sequences parser kernel help help.markup
help.topics words strings classes tools.vocabs namespaces make 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 combinators combinators.short-circuit splitting debugger
hashtables sorting effects vocabs vocabs.loader assocs editors hashtables sorting effects vocabs vocabs.loader assocs editors
continuations classes.predicate macros math sets eval 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 IN: help.lint
SYMBOL: vocabs-quot
: check-example ( element -- ) : check-example ( element -- )
[
rest [ rest [
but-last "\n" join 1vector but-last "\n" join 1vector
[ [ (eval>string) ] with-datastack
use [ clone ] change peek "\n" ?tail drop
[ eval>string ] with-datastack
] with-scope peek "\n" ?tail drop
] keep ] keep
peek assert= ; peek assert=
] vocabs-quot get call ;
: check-examples ( word element -- ) : check-examples ( element -- )
nip \ $example swap elements [ check-example ] each ; \ $example swap elements [ check-example ] each ;
: extract-values ( element -- seq ) : extract-values ( element -- seq )
\ $values swap elements dup empty? [ \ $values swap elements dup empty? [
@ -40,7 +43,7 @@ IN: help.lint
$predicate $predicate
$class-description $class-description
$error-description $error-description
} swap '[ _ elements empty? not ] contains? ; } swap '[ _ elements empty? not ] any? ;
: don't-check-word? ( word -- ? ) : don't-check-word? ( word -- ? )
{ {
@ -64,8 +67,13 @@ IN: help.lint
] ]
} 2|| [ "$values don't match stack effect" throw ] unless ; } 2|| [ "$values don't match stack effect" throw ] unless ;
: check-see-also ( word element -- ) : check-nulls ( element -- )
nip \ $see-also swap elements [ \ $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= rest dup prune [ length ] bi@ assert=
] each ; ] each ;
@ -79,43 +87,88 @@ IN: help.lint
] each ; ] each ;
: check-rendering ( element -- ) : 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 ) : all-word-help ( words -- seq )
[ word-help ] filter ; [ word-help ] filter ;
TUPLE: help-error topic error ; TUPLE: help-error error topic ;
C: <help-error> help-error C: <help-error> help-error
M: help-error error. M: help-error error.
"In " write dup topic>> pprint nl [ "In " write topic>> pprint nl ]
error>> error. ; [ error>> error. ]
bi ;
: check-something ( obj quot -- ) : check-something ( obj quot -- )
flush [ <help-error> , ] recover ; inline flush '[ _ assert-depth ] swap '[ _ <help-error> , ] recover ; inline
: check-word ( word -- ) : check-word ( word -- )
[ with-file-vocabs ] vocabs-quot set
dup word-help [ dup word-help [
[ dup '[
dup word-help '[ _ dup word-help
_ _ {
[ check-examples ]
[ check-values ] [ check-values ]
[ check-see-also ] [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
[ [ check-rendering ] [ check-modules ] bi* ]
} 2cleave
] assert-depth
] check-something ] check-something
] [ drop ] if ; ] [ drop ] if ;
: check-words ( words -- ) [ check-word ] each ; : 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 -- ) : check-article ( article -- )
[ [ with-interactive-vocabs ] vocabs-quot set
dup article-content dup '[
'[ _ check-rendering _ check-modules ] _
assert-depth [ check-article-title ]
[ article-content check-markup ] bi
] check-something ; ] check-something ;
: files>vocabs ( -- assoc ) : files>vocabs ( -- assoc )
@ -135,7 +188,7 @@ M: help-error error.
] keep ; ] keep ;
: check-about ( vocab -- ) : check-about ( vocab -- )
[ vocab-help [ article drop ] when* ] check-something ; dup '[ _ vocab-help [ article drop ] when* ] check-something ;
: check-vocab ( vocab -- seq ) : check-vocab ( vocab -- seq )
"Checking " write dup write "..." print "Checking " write dup write "..." print

View File

@ -1,5 +1,6 @@
USING: definitions help help.markup kernel sequences tools.test 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 IN: help.markup.tests
TUPLE: blahblah quux ; TUPLE: blahblah quux ;
@ -15,3 +16,12 @@ TUPLE: blahblah quux ;
[ ] [ \ fooey print-topic ] unit-test [ ] [ \ fooey print-topic ] unit-test
[ ] [ gensym 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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions generic io kernel assocs USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces make parser prettyprint sequences strings hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots 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 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 PREDICATE: simple-element < array
[ t ] [ first word? not ] if-empty ; [ t ] [ first word? not ] if-empty ;
@ -250,8 +243,21 @@ M: f ($instance)
: $instance ( element -- ) first ($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 -- ) : $maybe ( element -- )
$instance " or " print-element { f } $instance ; f suffix $or ;
: $quotation ( element -- ) : $quotation ( element -- )
{ "a " { $link quotation } " with stack effect " } print-element { "a " { $link quotation } " with stack effect " } print-element

View File

@ -94,7 +94,7 @@ $nl
"For example, we'd like it to identify the following as a palindrome:" "For example, we'd like it to identify the following as a palindrome:"
{ $code "\"A man, a plan, a canal: Panama.\"" } { $code "\"A man, a plan, a canal: Panama.\"" }
"However, right now, the simplistic algorithm we use says this is not a palindrome:" "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" } ":" "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" } { $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:" "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:" "Start by pushing a character on the stack; notice that characters are really just integers:"
{ $code "CHAR: a" } { $code "CHAR: a" }
"Now, use the " { $link Letter? } " word to test if it is an alphabetical character, upper or lower case:" "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." "This gives the expected result."
$nl $nl
"Now try with a non-alphabetical character:" "Now try with a non-alphabetical character:"
{ $code "CHAR: #" } { $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:" "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.\"" } { $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:" "Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:"

View File

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string kernel strings USING: help.markup help.syntax io.streams.string kernel strings
urls lcs inspector present io ; urls lcs inspector present io ;
@ -70,8 +70,8 @@ HELP: render
{ $description "Renders an HTML component to the " { $link output-stream } "." } ; { $description "Renders an HTML component to the " { $link output-stream } "." } ;
HELP: render* HELP: render*
{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } } { $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } { "xml" "an XML chunk" } }
{ $contract "Renders an HTML component to the " { $link output-stream } "." } ; { $contract "Renders an HTML component, outputting an XHTML snippet." } ;
ARTICLE: "html.components" "HTML components" ARTICLE: "html.components" "HTML components"
"The " { $vocab-link "html.components" } " vocabulary provides various HTML form components." "The " { $vocab-link "html.components" } " vocabulary provides various HTML form components."
@ -100,6 +100,6 @@ $nl
{ $subsection farkup } { $subsection farkup }
"Creating custom components:" "Creating custom components:"
{ $subsection render* } { $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" ABOUT: "html.components"

View File

@ -1,7 +1,8 @@
IN: html.components.tests IN: html.components.tests
USING: tools.test kernel io.streams.string USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams 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 [ ] [ begin-form ] unit-test
@ -31,7 +32,12 @@ TUPLE: color red green blue ;
] with-string-writer ] with-string-writer
] unit-test ] 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 "red" hidden render
] with-string-writer ] with-string-writer
@ -39,13 +45,13 @@ TUPLE: color red green blue ;
[ ] [ "'jimmy'" "red" set-value ] unit-test [ ] [ "'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 "red" <field> 5 >>size render
] with-string-writer ] with-string-writer
] unit-test ] unit-test
[ "<input type='password' size='5' name='red' value=''/>" ] [ [ "<input value=\"\" name=\"red\" size=\"5\" type=\"password\"/>" ] [
[ [
"red" <password> 5 >>size render "red" <password> 5 >>size render
] with-string-writer ] with-string-writer
@ -105,7 +111,7 @@ TUPLE: color red green blue ;
[ ] [ t "delivery" set-value ] unit-test [ ] [ 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" "delivery"
<checkbox> <checkbox>
@ -116,7 +122,7 @@ TUPLE: color red green blue ;
[ ] [ f "delivery" set-value ] unit-test [ ] [ f "delivery" set-value ] unit-test
[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [ [ "<input type=\"checkbox\" name=\"delivery\">Delivery</input>" ] [
[ [
"delivery" "delivery"
<checkbox> <checkbox>
@ -133,7 +139,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ link-test "link" set-value ] unit-test [ ] [ 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 [ "link" link new render ] with-string-writer
] unit-test ] unit-test
@ -149,7 +155,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ "java" "mode" set-value ] unit-test [ ] [ "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 [ "code" <code> "mode" >>mode render ] with-string-writer
] unit-test ] unit-test
@ -163,7 +169,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ t ] [ [ t ] [
[ "object" inspector render ] with-string-writer [ "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 ] unit-test
@ -183,3 +189,9 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
} }
} }
] [ values ] unit-test ] [ values ] unit-test
[ ] [ "error" "blah" <validation-error> "error" set-value ] unit-test
[ ] [
"error" hidden render
] unit-test

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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences splitting mirrors classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings inspector hashtables combinators continuations math strings inspector
fry locals calendar calendar.format xml.entities fry locals calendar calendar.format xml.entities xml.data
validators urls present validators urls present xml.writer xml.literals xml
xmode.code2html lcs.diff2html farkup xmode.code2html lcs.diff2html farkup io.streams.string
html.elements html.streams html.forms ; html html.streams html.forms ;
IN: html.components IN: html.components
GENERIC: render* ( value name renderer -- ) GENERIC: render* ( value name renderer -- xml )
: render ( name renderer -- ) : render ( name renderer -- )
prepare-value prepare-value
[ [
dup validation-error? dup validation-error?
[ [ message>> ] [ value>> ] bi ] [ [ message>> render-error ] [ value>> ] bi ]
[ f swap ] [ f swap ]
if if
] 2dip ] 2dip
render* render*
[ render-error ] when* ; swap 2array write-xml ;
<PRIVATE
: render-input ( value name type -- )
<input =type =name present =value input/> ;
PRIVATE>
SINGLETON: label SINGLETON: label
M: label render* 2drop present escape-string write ; M: label render*
2drop present ;
SINGLETON: hidden 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 -- ) : render-field ( value name size type -- xml )
<input [XML <input value=<-> name=<-> size=<-> type=<->/> XML] ;
=type
[ present =size ] when*
=name
present =value
input/> ;
TUPLE: field size ; TUPLE: field size ;
: <field> ( -- field ) : <field> ( -- field )
field new ; field new ;
M: field render* size>> "text" render-field ; M: field render*
size>> "text" render-field ;
TUPLE: password size ; TUPLE: password size ;
@ -67,14 +58,15 @@ TUPLE: textarea rows cols ;
: <textarea> ( -- renderer ) : <textarea> ( -- renderer )
textarea new ; textarea new ;
M: textarea render* M:: textarea render* ( value name area -- xml )
area rows>> :> rows
area cols>> :> cols
[XML
<textarea <textarea
[ rows>> [ present =rows ] when* ] name=<-name->
[ cols>> [ present =cols ] when* ] bi rows=<-rows->
=name cols=<-cols->><-value-></textarea>
textarea> XML] ;
present escape-string write
</textarea> ;
! Choice ! Choice
TUPLE: choice size multiple choices ; TUPLE: choice size multiple choices ;
@ -82,24 +74,23 @@ TUPLE: choice size multiple choices ;
: <choice> ( -- choice ) : <choice> ( -- choice )
choice new ; choice new ;
: render-option ( text selected? -- ) : render-option ( text selected? -- xml )
<option [ "selected" =selected ] when option> "selected" and swap
present escape-string write [XML <option selected=<->><-></option> XML] ;
</option> ;
: render-options ( options selected -- ) : render-options ( value choice -- xml )
'[ dup _ member? render-option ] each ;
M: choice render*
<select
swap =name
dup size>> [ present =size ] when*
dup multiple>> [ "true" =multiple ] when
select>
[ choices>> value ] [ multiple>> ] bi [ choices>> value ] [ multiple>> ] bi
[ swap ] [ swap 1array ] if [ swap ] [ swap 1array ] if
render-options '[ dup _ member? render-option ] map ;
</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 ! Checkboxes
TUPLE: checkbox label ; TUPLE: checkbox label ;
@ -108,13 +99,10 @@ TUPLE: checkbox label ;
checkbox new ; checkbox new ;
M: checkbox render* M: checkbox render*
<input [ "true" and ] [ ] [ label>> ] tri*
"checkbox" =type [XML <input
swap =name type="checkbox"
swap [ "true" =checked ] when checked=<-> name=<->><-></input> XML] ;
input>
label>> escape-string write
</input> ;
! Link components ! Link components
GENERIC: link-title ( obj -- string ) GENERIC: link-title ( obj -- string )
@ -129,10 +117,9 @@ M: url link-href ;
TUPLE: link target ; TUPLE: link target ;
M: link render* M: link render*
nip nip swap
<a target>> [ =target ] when* dup link-href =href a> [ target>> ] [ [ link-href ] [ link-title ] bi ] bi*
link-title present escape-string write [XML <a target=<-> href=<->><-></a> XML] ;
</a> ;
! XMode code component ! XMode code component
TUPLE: code mode ; TUPLE: code mode ;
@ -161,7 +148,7 @@ M: farkup render*
nip nip
[ no-follow>> [ string>boolean link-no-follow? set ] when* ] [ no-follow>> [ string>boolean link-no-follow? set ] when* ]
[ disable-images>> [ string>boolean disable-images? 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 tri
] with-scope ; ] with-scope ;
@ -180,4 +167,4 @@ M: comparison render*
! HTML component ! HTML component
SINGLETON: html SINGLETON: html
M: html render* 2drop write ; M: html render* 2drop <unescaped> ;

View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io present html ;
IN: html.elements IN: html.elements
USING: help.markup help.syntax io present ;
ARTICLE: "html.elements" "HTML elements" 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." "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 =href a> \"Click me\" write </a>" }
{ $code "<a \"http://\" prepend =href a> \"click\" write </a>" } { $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
{ $code "<a [ \"http://\" % % ] \"\" make =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/>" } { $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." "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 $nl
"Writing unescaped HTML to " { $vocab-link "html.streams" } ":" "Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
{ $subsection write-html } { $subsection write-html }
{ $subsection print-html } { $subsection print-html } ;
"Writing some common HTML patterns:"
{ $subsection xhtml-preamble }
{ $subsection simple-page }
{ $subsection render-error } ;
ABOUT: "html.elements" ABOUT: "html.elements"

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