Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
4f25c756ec
8
Makefile
8
Makefile
|
|
@ -3,6 +3,7 @@ AR = ar
|
|||
LD = ld
|
||||
|
||||
EXECUTABLE = factor
|
||||
CONSOLE_EXECUTABLE = factor-console
|
||||
VERSION = 0.92
|
||||
|
||||
IMAGE = factor.image
|
||||
|
|
@ -138,9 +139,11 @@ zlib1.dll:
|
|||
|
||||
winnt-x86-32: freetype6.dll zlib1.dll
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
|
||||
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
|
||||
|
||||
winnt-x86-64:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
|
||||
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
|
||||
|
||||
wince-arm:
|
||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
|
||||
|
|
@ -161,6 +164,11 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
|
|||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
factor-console: $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) $(CFLAGS_CONSOLE) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
clean:
|
||||
rm -f vm/*.o
|
||||
rm -f factor*.dll libfactor.{a,so,dylib}
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators io io.binary io.encodings.binary
|
||||
io.streams.byte-array io.streams.string kernel math namespaces
|
||||
sequences strings ;
|
||||
sequences strings io.crlf ;
|
||||
IN: base64
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -32,7 +32,7 @@ SYMBOL: column
|
|||
: write1-lines ( ch -- )
|
||||
write1
|
||||
column get [
|
||||
1+ [ 76 = [ "\r\n" write ] when ]
|
||||
1+ [ 76 = [ crlf ] when ]
|
||||
[ 76 mod column set ] bi
|
||||
] when* ;
|
||||
|
||||
|
|
@ -45,8 +45,8 @@ SYMBOL: column
|
|||
] with each ; inline
|
||||
|
||||
: encode-pad ( seq n -- )
|
||||
[ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
|
||||
[ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
|
||||
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
|
||||
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
|
||||
|
||||
ERROR: malformed-base64 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
parsing
|
||||
web
|
||||
|
|
@ -351,7 +351,7 @@ M: wrapper '
|
|||
bootstrap-cell <groups> native> emit-seq ;
|
||||
|
||||
: pad-bytes ( seq -- newseq )
|
||||
dup length bootstrap-cell align 0 pad-right ;
|
||||
dup length bootstrap-cell align 0 pad-tail ;
|
||||
|
||||
: extended-part ( str -- str' )
|
||||
dup [ 128 < ] all? [ drop f ] [
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ SYMBOL: core-bootstrap-time
|
|||
SYMBOL: bootstrap-time
|
||||
|
||||
: default-image-name ( -- string )
|
||||
vm file-name os windows? [ "." split1 drop ] when
|
||||
vm file-name os windows? [ "." split1-last drop ] when
|
||||
".image" append resource-path ;
|
||||
|
||||
: do-crossref ( -- )
|
||||
|
|
|
|||
|
|
@ -5,11 +5,11 @@ sequences io accessors arrays io.streams.string splitting
|
|||
combinators accessors calendar calendar.format.macros present ;
|
||||
IN: calendar.format
|
||||
|
||||
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;
|
||||
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
|
||||
|
||||
: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;
|
||||
: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
|
||||
|
||||
: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;
|
||||
: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
|
||||
|
||||
: write-00 ( n -- ) pad-00 write ;
|
||||
|
||||
|
|
|
|||
|
|
@ -128,7 +128,7 @@ M: sha1 checksum-stream ( stream -- sha1 )
|
|||
[ zip concat ] keep like ;
|
||||
|
||||
: sha1-interleave ( string -- seq )
|
||||
[ zero? ] trim-left
|
||||
[ zero? ] trim-head
|
||||
dup length odd? [ rest ] when
|
||||
seq>2seq [ sha1 checksum-bytes ] bi@
|
||||
2seq>seq ;
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
|
|||
[ + + w+ ] 2dip swap set-nth ; inline
|
||||
|
||||
: prepare-message-schedule ( seq -- w-seq )
|
||||
word-size get group [ be> ] map block-size get 0 pad-right
|
||||
word-size get group [ be> ] map block-size get 0 pad-tail
|
||||
dup 16 64 dup <slice> [
|
||||
process-M-256
|
||||
] with each ;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ IN: compiler.cfg.alias-analysis.tests
|
|||
|
||||
[ ] [
|
||||
{
|
||||
T{ ##load-indirect f V int-regs 1 "hello" }
|
||||
T{ ##load-reference f V int-regs 1 "hello" }
|
||||
T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
|
||||
} alias-analysis drop
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -224,7 +224,7 @@ GENERIC: analyze-aliases* ( insn -- insn' )
|
|||
M: ##load-immediate analyze-aliases*
|
||||
dup [ val>> ] [ dst>> ] bi constants get set-at ;
|
||||
|
||||
M: ##load-indirect analyze-aliases*
|
||||
M: ##load-reference analyze-aliases*
|
||||
dup dst>> set-heap-ac ;
|
||||
|
||||
M: ##alien-global analyze-aliases*
|
||||
|
|
|
|||
|
|
@ -36,13 +36,13 @@ TUPLE: ##alien-setter < ##effect { value vreg } ;
|
|||
|
||||
! Stack operations
|
||||
INSN: ##load-immediate < ##pure { val integer } ;
|
||||
INSN: ##load-indirect < ##pure obj ;
|
||||
INSN: ##load-reference < ##pure obj ;
|
||||
|
||||
GENERIC: ##load-literal ( dst value -- )
|
||||
|
||||
M: fixnum ##load-literal tag-fixnum ##load-immediate ;
|
||||
M: f ##load-literal drop \ f tag-number ##load-immediate ;
|
||||
M: object ##load-literal ##load-indirect ;
|
||||
M: object ##load-literal ##load-reference ;
|
||||
|
||||
INSN: ##peek < ##read { loc loc } ;
|
||||
INSN: ##replace < ##write { loc loc } ;
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ M: ##compare-float-branch linearize-insn
|
|||
##box-float
|
||||
##box-alien
|
||||
} memq?
|
||||
] contains? ;
|
||||
] any? ;
|
||||
|
||||
: linearize-basic-block ( bb -- )
|
||||
[ number>> _label ]
|
||||
|
|
|
|||
|
|
@ -39,8 +39,6 @@ GENERIC: >expr ( insn -- expr )
|
|||
|
||||
M: ##load-immediate >expr val>> <constant> ;
|
||||
|
||||
M: ##load-indirect >expr obj>> <constant> ;
|
||||
|
||||
M: ##unary >expr
|
||||
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;
|
||||
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@ sequences ;
|
|||
|
||||
[
|
||||
{
|
||||
T{ ##load-indirect f V int-regs 1 + }
|
||||
T{ ##load-reference f V int-regs 1 + }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
|
||||
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
|
||||
|
|
@ -89,7 +89,7 @@ sequences ;
|
|||
}
|
||||
] [
|
||||
{
|
||||
T{ ##load-indirect f V int-regs 1 + }
|
||||
T{ ##load-reference f V int-regs 1 + }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
|
||||
|
|
@ -99,7 +99,7 @@ sequences ;
|
|||
|
||||
[
|
||||
{
|
||||
T{ ##load-indirect f V int-regs 1 + }
|
||||
T{ ##load-reference f V int-regs 1 + }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
|
||||
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
|
||||
|
|
@ -107,7 +107,7 @@ sequences ;
|
|||
}
|
||||
] [
|
||||
{
|
||||
T{ ##load-indirect f V int-regs 1 + }
|
||||
T{ ##load-reference f V int-regs 1 + }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
|
||||
|
|
|
|||
|
|
@ -70,8 +70,8 @@ SYMBOL: labels
|
|||
M: ##load-immediate generate-insn
|
||||
[ dst>> register ] [ val>> ] bi %load-immediate ;
|
||||
|
||||
M: ##load-indirect generate-insn
|
||||
[ dst>> register ] [ obj>> ] bi %load-indirect ;
|
||||
M: ##load-reference generate-insn
|
||||
[ dst>> register ] [ obj>> ] bi %load-reference ;
|
||||
|
||||
M: ##peek generate-insn
|
||||
[ dst>> register ] [ loc>> ] bi %peek ;
|
||||
|
|
@ -400,7 +400,7 @@ M: no-such-symbol compiler-error-type
|
|||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
dup dll-valid? [
|
||||
dupd '[ _ dlsym ] contains?
|
||||
dupd '[ _ dlsym ] any?
|
||||
[ drop ] [ no-such-symbol ] if
|
||||
] [
|
||||
dll-path no-such-library drop
|
||||
|
|
|
|||
|
|
@ -276,3 +276,9 @@ TUPLE: id obj ;
|
|||
|
||||
[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
|
||||
[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
|
||||
|
||||
TUPLE: cucumber ;
|
||||
|
||||
M: cucumber equal? "The cucumber has no equal" throw ;
|
||||
|
||||
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
|
||||
|
|
@ -19,14 +19,14 @@ words splitting grouping sorting accessors ;
|
|||
|
||||
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
|
||||
|
||||
: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
|
||||
: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ;
|
||||
|
||||
[ t ] [
|
||||
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
|
||||
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
|
||||
] unit-test
|
||||
|
||||
[ t f ] [
|
||||
[ { "hi" } bleh ] ignore-errors
|
||||
\ + stack-trace-contains?
|
||||
\ > stack-trace-contains?
|
||||
\ + stack-trace-any?
|
||||
\ > stack-trace-any?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -8,4 +8,4 @@ compiler.tree ;
|
|||
|
||||
: inline-recursive ( -- ) inline-recursive ; inline recursive
|
||||
|
||||
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test
|
||||
[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? nip ] unit-test
|
||||
|
|
|
|||
|
|
@ -175,7 +175,7 @@ M: #branch check-stack-flow*
|
|||
branch-out get [ ] find nip swap head* >vector datastack set ;
|
||||
|
||||
M: #phi check-stack-flow*
|
||||
branch-out get [ ] contains? [
|
||||
branch-out get [ ] any? [
|
||||
[ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
|
||||
] [ drop terminated? on ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -498,7 +498,7 @@ cell-bits 32 = [
|
|||
|
||||
[ t ] [
|
||||
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
|
||||
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
|
||||
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -34,14 +34,14 @@ IN: compiler.tree.combinators
|
|||
dup dup '[
|
||||
_ keep swap [ drop t ] [
|
||||
dup #branch? [
|
||||
children>> [ _ contains-node? ] contains?
|
||||
children>> [ _ contains-node? ] any?
|
||||
] [
|
||||
dup #recursive? [
|
||||
child>> _ contains-node?
|
||||
] [ drop f ] if
|
||||
] if
|
||||
] if
|
||||
] contains? ; inline recursive
|
||||
] any? ; inline recursive
|
||||
|
||||
: select-children ( seq flags -- seq' )
|
||||
[ [ drop f ] unless ] 2map ;
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
|
|||
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
|
||||
|
||||
: some-outputs-dead? ( #call -- ? )
|
||||
out-d>> [ live-value? not ] contains? ;
|
||||
out-d>> [ live-value? not ] any? ;
|
||||
|
||||
: maybe-drop-dead-outputs ( node -- nodes )
|
||||
dup some-outputs-dead? [
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ M: #branch normalize*
|
|||
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
|
||||
[
|
||||
[ nip ] [
|
||||
dup [ +bottom+ eq? ] trim-left
|
||||
dup [ +bottom+ eq? ] trim-head
|
||||
[ [ length ] bi@ - tail* ] keep append
|
||||
] if
|
||||
] 3map ;
|
||||
|
|
|
|||
|
|
@ -124,7 +124,7 @@ DEFER: (flat-length)
|
|||
[ class-types length 1 = ]
|
||||
[ union-class? not ]
|
||||
bi and
|
||||
] contains? ;
|
||||
] any? ;
|
||||
|
||||
: node-count-bias ( -- n )
|
||||
45 node-count get [-] 8 /i ;
|
||||
|
|
|
|||
|
|
@ -118,7 +118,7 @@ M: #return-recursive unbox-tuples*
|
|||
! These nodes never participate in unboxing
|
||||
: assert-not-unboxed ( values -- )
|
||||
dup array?
|
||||
[ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if
|
||||
[ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if
|
||||
[ "Unboxing wrong value" throw ] when ;
|
||||
|
||||
M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ M: mailbox dispose* threads>> notify-all ;
|
|||
|
||||
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )
|
||||
mailbox check-disposed
|
||||
mailbox data>> pred dlist-contains? [
|
||||
mailbox data>> pred dlist-any? [
|
||||
mailbox timeout wait-for-mailbox
|
||||
mailbox timeout pred block-unless-pred
|
||||
] unless ; inline recursive
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ M: object param-reg param-regs nth ;
|
|||
HOOK: two-operand? cpu ( -- ? )
|
||||
|
||||
HOOK: %load-immediate cpu ( reg obj -- )
|
||||
HOOK: %load-indirect cpu ( reg obj -- )
|
||||
HOOK: %load-reference cpu ( reg obj -- )
|
||||
|
||||
HOOK: %peek cpu ( vreg loc -- )
|
||||
HOOK: %replace cpu ( vreg loc -- )
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ M: ppc two-operand? f ;
|
|||
|
||||
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
|
||||
|
||||
M: ppc %load-indirect ( reg obj -- )
|
||||
M: ppc %load-reference ( reg obj -- )
|
||||
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
|
||||
|
||||
M: ppc %alien-global ( register symbol dll -- )
|
||||
|
|
@ -261,7 +261,7 @@ M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
|
|||
M:: ppc %integer>bignum ( dst src temp -- )
|
||||
[
|
||||
"end" define-label
|
||||
dst 0 >bignum %load-indirect
|
||||
dst 0 >bignum %load-reference
|
||||
! Is it zero? Then just go to the end and return this zero
|
||||
0 src 0 CMPI
|
||||
"end" get BEQ
|
||||
|
|
@ -321,7 +321,7 @@ M:: ppc %integer>float ( dst src -- )
|
|||
scratch-reg dup HEX: 8000 XORIS
|
||||
scratch-reg 1 4 scratch@ STW
|
||||
dst 1 0 scratch@ LFD
|
||||
scratch-reg 4503601774854144.0 %load-indirect
|
||||
scratch-reg 4503601774854144.0 %load-reference
|
||||
fp-scratch-reg scratch-reg float-offset LFD
|
||||
dst dst fp-scratch-reg FSUB ;
|
||||
|
||||
|
|
@ -488,7 +488,7 @@ M: ppc %epilogue ( n -- )
|
|||
"end" define-label
|
||||
dst \ f tag-number %load-immediate
|
||||
"end" get word execute
|
||||
dst \ t %load-indirect
|
||||
dst \ t %load-reference
|
||||
"end" get resolve-label ; inline
|
||||
|
||||
: %boolean ( dst temp cc -- )
|
||||
|
|
@ -637,7 +637,7 @@ M: ppc %alien-invoke ( symbol dll -- )
|
|||
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
|
||||
|
||||
M: ppc %alien-callback ( quot -- )
|
||||
3 swap %load-indirect "c_to_factor" f %alien-invoke ;
|
||||
3 swap %load-reference "c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: ppc %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
|
|
|
|||
|
|
@ -237,7 +237,7 @@ M: x86.32 %alien-indirect ( -- )
|
|||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
4 [
|
||||
EAX swap %load-indirect
|
||||
EAX swap %load-reference
|
||||
EAX PUSH
|
||||
"c_to_factor" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
|
|
|||
|
|
@ -176,7 +176,7 @@ M: x86.64 %alien-indirect ( -- )
|
|||
RBP CALL ;
|
||||
|
||||
M: x86.64 %alien-callback ( quot -- )
|
||||
param-reg-1 swap %load-indirect
|
||||
param-reg-1 swap %load-reference
|
||||
"c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %callback-value ( ctype -- )
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ HOOK: param-reg-2 cpu ( -- reg )
|
|||
|
||||
M: x86 %load-immediate MOV ;
|
||||
|
||||
M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ;
|
||||
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
|
||||
|
||||
HOOK: ds-reg cpu ( -- reg )
|
||||
HOOK: rs-reg cpu ( -- reg )
|
||||
|
|
@ -188,7 +188,7 @@ M:: x86 %integer>bignum ( dst src temp -- )
|
|||
[
|
||||
"end" define-label
|
||||
! Load cached zero value
|
||||
dst 0 >bignum %load-indirect
|
||||
dst 0 >bignum %load-reference
|
||||
src 0 CMP
|
||||
! Is it zero? Then just go to the end and return this zero
|
||||
"end" get JE
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ DEFER: quoted-field ( -- endchar )
|
|||
delimiter swap with-variable ; inline
|
||||
|
||||
: needs-escaping? ( cell -- ? )
|
||||
[ [ "\n\"" member? ] [ delimiter get = ] bi or ] contains? ; inline ! "
|
||||
[ [ "\n\"" member? ] [ delimiter get = ] bi or ] any? ; inline
|
||||
|
||||
: escape-quotes ( cell -- cell' )
|
||||
[ [ dup , CHAR: " = [ CHAR: " , ] when ] each ] "" make ; inline
|
||||
|
|
|
|||
|
|
@ -244,13 +244,13 @@ ARTICLE: "db-protocol" "Low-level database protocol"
|
|||
! { $subsection bind-tuple }
|
||||
|
||||
ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
|
||||
"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "."
|
||||
"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." $nl
|
||||
"Executing a SQL command:"
|
||||
{ $subsection sql-command }
|
||||
"Executing a query directly:"
|
||||
{ $subsection sql-query }
|
||||
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
|
||||
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
|
||||
"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
|
||||
{ $code <"
|
||||
USING: db.sqlite db io.files ;
|
||||
: with-book-db ( quot -- )
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ SINGLETON: retryable
|
|||
] if ;
|
||||
|
||||
: maybe-make-retryable ( statement -- statement )
|
||||
dup in-params>> [ generator-bind? ] contains?
|
||||
dup in-params>> [ generator-bind? ] any?
|
||||
[ make-retryable ] when ;
|
||||
|
||||
: regenerate-params ( statement -- statement )
|
||||
|
|
|
|||
|
|
@ -294,7 +294,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
] with-string-writer ;
|
||||
|
||||
: can-be-null? ( -- ? )
|
||||
"sql-spec" get modifiers>> [ +not-null+ = ] contains? not ;
|
||||
"sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
|
||||
|
||||
: delete-cascade? ( -- ? )
|
||||
"sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ HELP: ensure-table
|
|||
|
||||
HELP: ensure-tables
|
||||
{ $values
|
||||
{ "classes" null } }
|
||||
{ "classes" "a sequence of classes" } }
|
||||
{ $description "Creates a SQL table from a mapping defined by " { $link define-persistent } ". If a table already exists, the error is silently ignored." } ;
|
||||
|
||||
HELP: recreate-table
|
||||
|
|
@ -199,7 +199,7 @@ ARTICLE: "db-tuples-protocol" "Tuple database protocol"
|
|||
{ $subsection <count-statement> } ;
|
||||
|
||||
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
|
||||
"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
|
||||
"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
|
||||
"We're going to store books in this tutorial."
|
||||
{ $code "TUPLE: book id title author date-published edition cover-price condition ;" }
|
||||
"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
|
||||
|
|
@ -246,7 +246,7 @@ T{ book
|
|||
{ $code <" [
|
||||
book get update-tuple
|
||||
] with-book-tutorial "> }
|
||||
"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
|
||||
"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
|
||||
{ $code <" [
|
||||
T{ book { title "Factor for Sheeple" } } select-tuples
|
||||
] with-book-tutorial "> }
|
||||
|
|
|
|||
|
|
@ -4,39 +4,24 @@ USING: classes hashtables help.markup help.syntax io.streams.string
|
|||
kernel sequences strings math ;
|
||||
IN: db.types
|
||||
|
||||
HELP: +autoincrement+
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: +db-assigned-id+
|
||||
{ $description "The database assigns a primary key to the object. The primary key is most likely a big integer, but is database-dependent." } ;
|
||||
|
||||
HELP: +default+
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: +foreign-id+
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: +has-many+
|
||||
{ $description "" } ;
|
||||
{ $description "Allows a default value for a column to be provided." } ;
|
||||
|
||||
HELP: +not-null+
|
||||
{ $description "" } ;
|
||||
{ $description "Ensures that a column is not null." } ;
|
||||
|
||||
HELP: +null+
|
||||
{ $description "" } ;
|
||||
{ $description "Allows a column to be null." } ;
|
||||
|
||||
HELP: +primary-key+
|
||||
{ $description "" } ;
|
||||
{ $description "Makes a column a primary key. Only one column may be a primary key." } ;
|
||||
|
||||
HELP: +random-id+
|
||||
{ $description "Factor chooses a random number and tries to insert the tuple into the database with this number as its primary key. The default number of retries to find a unique random number is 10, though in practice it will almost certainly succeed on the first try." } ;
|
||||
|
||||
HELP: +serial+
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: +unique+
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: +user-assigned-id+
|
||||
{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
|
||||
|
||||
|
|
@ -114,12 +99,12 @@ HELP: user-assigned-id-spec?
|
|||
|
||||
HELP: bind#
|
||||
{ $values
|
||||
{ "spec" null } { "obj" object } }
|
||||
{ "spec" "a sql spec" } { "obj" object } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: bind%
|
||||
{ $values
|
||||
{ "spec" null } }
|
||||
{ "spec" "a sql spec" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: compound
|
||||
|
|
@ -176,7 +161,7 @@ HELP: low-level-binding
|
|||
|
||||
HELP: modifiers
|
||||
{ $values
|
||||
{ "spec" null }
|
||||
{ "spec" "a sql spec" }
|
||||
{ "string" string } }
|
||||
{ $description "" } ;
|
||||
|
||||
|
|
@ -187,7 +172,7 @@ HELP: no-sql-type
|
|||
|
||||
HELP: normalize-spec
|
||||
{ $values
|
||||
{ "spec" null } }
|
||||
{ "spec" "a sql spec" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: offset-of-slot
|
||||
|
|
@ -204,7 +189,7 @@ HELP: persistent-table
|
|||
|
||||
HELP: primary-key?
|
||||
{ $values
|
||||
{ "spec" null }
|
||||
{ "spec" "a sql spec" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "" } ;
|
||||
|
||||
|
|
@ -213,37 +198,31 @@ HELP: random-id-generator
|
|||
|
||||
HELP: relation?
|
||||
{ $values
|
||||
{ "spec" null }
|
||||
{ "spec" "a sql spec" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: remove-db-assigned-id
|
||||
{ $values
|
||||
{ "specs" null }
|
||||
{ "specs" "a sequence of sql specs" }
|
||||
{ "obj" object } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: remove-id
|
||||
{ $values
|
||||
{ "specs" null }
|
||||
{ "specs" "a sequence of sql specs" }
|
||||
{ "obj" object } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: remove-relations
|
||||
{ $values
|
||||
{ "specs" null }
|
||||
{ "newcolumns" null } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: set-slot-named
|
||||
{ $values
|
||||
{ "value" null } { "name" null } { "obj" object } }
|
||||
{ "value" object } { "name" string } { "obj" object } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: spec>tuple
|
||||
{ $values
|
||||
{ "class" class } { "spec" null }
|
||||
{ "tuple" null } }
|
||||
{ "class" class } { "spec" "a sql spec" }
|
||||
{ "tuple" tuple } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: sql-spec
|
||||
|
|
|
|||
|
|
@ -71,10 +71,10 @@ ERROR: not-persistent class ;
|
|||
primary-key>> +primary-key+? ;
|
||||
|
||||
: db-assigned-id-spec? ( specs -- ? )
|
||||
[ primary-key>> +db-assigned-id+? ] contains? ;
|
||||
[ primary-key>> +db-assigned-id+? ] any? ;
|
||||
|
||||
: user-assigned-id-spec? ( specs -- ? )
|
||||
[ primary-key>> +user-assigned-id+? ] contains? ;
|
||||
[ primary-key>> +user-assigned-id+? ] any? ;
|
||||
|
||||
: normalize-spec ( spec -- )
|
||||
dup type>> dup +primary-key+? [
|
||||
|
|
@ -105,7 +105,7 @@ FACTOR-BLOB NULL URL ;
|
|||
dup normalize-spec ;
|
||||
|
||||
: spec>tuple ( class spec -- tuple )
|
||||
3 f pad-right [ first3 ] keep 3 tail <sql-spec> ;
|
||||
3 f pad-tail [ first3 ] keep 3 tail <sql-spec> ;
|
||||
|
||||
: number>string* ( n/string -- string )
|
||||
dup number? [ number>string ] when ;
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ $nl
|
|||
"Iterating over elements:"
|
||||
{ $subsection dlist-each }
|
||||
{ $subsection dlist-find }
|
||||
{ $subsection dlist-contains? }
|
||||
{ $subsection dlist-any? }
|
||||
"Deleting a node matching a predicate:"
|
||||
{ $subsection delete-node-if* }
|
||||
{ $subsection delete-node-if }
|
||||
|
|
@ -40,7 +40,7 @@ HELP: dlist-find
|
|||
"This operation is O(n)."
|
||||
} ;
|
||||
|
||||
HELP: dlist-contains?
|
||||
HELP: dlist-any?
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
|
||||
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
|
||||
{ $notes "This operation is O(n)." } ;
|
||||
|
|
|
|||
|
|
@ -46,8 +46,8 @@ IN: dlists.tests
|
|||
[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
|
||||
[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
|
||||
[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
|
||||
[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
|
||||
[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-any? ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-any? ] unit-test
|
||||
|
||||
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
|
||||
[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop deque-empty? ] unit-test
|
||||
|
|
|
|||
|
|
@ -117,11 +117,11 @@ M: dlist pop-back* ( dlist -- )
|
|||
: dlist-find ( dlist quot -- obj/f ? )
|
||||
'[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
|
||||
|
||||
: dlist-contains? ( dlist quot -- ? )
|
||||
: dlist-any? ( dlist quot -- ? )
|
||||
dlist-find nip ; inline
|
||||
|
||||
M: dlist deque-member? ( value dlist -- ? )
|
||||
[ = ] with dlist-contains? ;
|
||||
[ = ] with dlist-any? ;
|
||||
|
||||
M: dlist delete-node ( dlist-node dlist -- )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
|
||||
urls.encoding assocs xml.utilities ;
|
||||
urls.encoding assocs xml.utilities xml.data ;
|
||||
IN: farkup.tests
|
||||
|
||||
relative-link-prefix off
|
||||
|
|
@ -161,7 +161,7 @@ link-no-follow? off
|
|||
|
||||
: check-link-escaping ( string -- link )
|
||||
convert-farkup string>xml-chunk
|
||||
"a" deep-tag-named "href" swap at url-decode ;
|
||||
"a" deep-tag-named "href" attr url-decode ;
|
||||
|
||||
[ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test
|
||||
[ "<foo>" ] [ "[[<foo>]]" check-link-escaping ] unit-test
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ TUPLE: line ;
|
|||
TUPLE: line-break ;
|
||||
|
||||
: absolute-url? ( string -- ? )
|
||||
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
|
||||
{ "http://" "https://" "ftp://" } [ head? ] with any? ;
|
||||
|
||||
: simple-link-title ( string -- string' )
|
||||
dup absolute-url? [ "/" split1-last swap or ] unless ;
|
||||
|
|
@ -162,7 +162,7 @@ stand-alone
|
|||
: check-url ( href -- href' )
|
||||
{
|
||||
{ [ dup empty? ] [ drop invalid-url ] }
|
||||
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
|
||||
{ [ dup [ 127 > ] any? ] [ drop invalid-url ] }
|
||||
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
|
||||
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
|
||||
[ relative-link-prefix get prepend "" like ]
|
||||
|
|
@ -236,7 +236,7 @@ M: f (write-farkup) ;
|
|||
parse-farkup (write-farkup) ;
|
||||
|
||||
: write-farkup ( string -- )
|
||||
farkup>xml write-xml-chunk ;
|
||||
farkup>xml write-xml ;
|
||||
|
||||
: convert-farkup ( string -- string' )
|
||||
[ write-farkup ] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ HELP: printf
|
|||
"string. For example:\n"
|
||||
{ $list
|
||||
"\"%.3s\" formats a string to truncate at 3 characters (from the left)."
|
||||
"\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
|
||||
"\"%.10f\" formats a float to pad-tail with zeros up to 10 digits beyond the decimal point."
|
||||
"\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ IN: formatting
|
|||
[ 0 ] [ string>number ] if-empty ;
|
||||
|
||||
: pad-digits ( string digits -- string' )
|
||||
[ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
|
||||
[ "." split1 ] dip [ CHAR: 0 pad-tail ] [ head-slice ] bi "." glue ;
|
||||
|
||||
: max-digits ( n digits -- n' )
|
||||
10 swap ^ [ * round ] keep / ; inline
|
||||
|
|
@ -48,7 +48,7 @@ IN: formatting
|
|||
[ max-digits ] keep -rot
|
||||
[
|
||||
[ 0 < "-" "+" ? ]
|
||||
[ abs number>string 2 CHAR: 0 pad-left ] bi
|
||||
[ abs number>string 2 CHAR: 0 pad-head ] bi
|
||||
"e" -rot 3append
|
||||
]
|
||||
[ number>string ] bi*
|
||||
|
|
@ -60,7 +60,7 @@ zero = "0" => [[ CHAR: 0 ]]
|
|||
char = "'" (.) => [[ second ]]
|
||||
|
||||
pad-char = (zero|char)? => [[ CHAR: \s or ]]
|
||||
pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
|
||||
pad-align = ("-")? => [[ \ pad-tail \ pad-head ? ]]
|
||||
pad-width = ([0-9])* => [[ >digits ]]
|
||||
pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
|
||||
|
||||
|
|
@ -110,9 +110,9 @@ MACRO: printf ( format-string -- )
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-left ; inline
|
||||
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
|
||||
|
||||
: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline
|
||||
: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-head ; inline
|
||||
|
||||
: >time ( timestamp -- string )
|
||||
[ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ name target ;
|
|||
|
||||
: parse-list-11 ( lines -- seq )
|
||||
[
|
||||
11 f pad-right
|
||||
11 f pad-tail
|
||||
<remote-file> swap {
|
||||
[ 0 swap nth parse-permissions ]
|
||||
[ 1 swap nth string>number >>links ]
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ WW DEFINES ${W}${W}
|
|||
|
||||
WHERE
|
||||
|
||||
: WW W twice ; inline
|
||||
: WW ( a -- b ) \ W twice ; inline
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
|
@ -45,3 +45,21 @@ WHERE
|
|||
\ sqsq must-infer
|
||||
|
||||
[ 16 ] [ 2 sqsq ] unit-test
|
||||
|
||||
<<
|
||||
|
||||
FUNCTOR: wrapper-test-2 ( W -- )
|
||||
|
||||
W DEFINES ${W}
|
||||
|
||||
WHERE
|
||||
|
||||
: W ( a b -- c ) \ + execute ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
"blah" wrapper-test-2
|
||||
|
||||
>>
|
||||
|
||||
[ 4 ] [ 1 3 blah ] unit-test
|
||||
|
|
@ -1,17 +1,43 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel quotations classes.tuple make combinators generic
|
||||
words interpolate namespaces sequences io.streams.string fry
|
||||
classes.mixin effects lexer parser classes.tuple.parser
|
||||
effects.parser locals.types locals.parser
|
||||
locals.rewrite.closures vocabs.parser ;
|
||||
locals.rewrite.closures vocabs.parser arrays accessors ;
|
||||
IN: functors
|
||||
|
||||
: scan-param ( -- obj )
|
||||
scan-object dup special? [ literalize ] unless ;
|
||||
! This is a hack
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: scan-param ( -- obj ) scan-object literalize ;
|
||||
|
||||
: define* ( word def effect -- ) pick set-word define-declared ;
|
||||
|
||||
TUPLE: fake-quotation seq ;
|
||||
|
||||
GENERIC: >fake-quotations ( quot -- fake )
|
||||
|
||||
M: callable >fake-quotations
|
||||
>array >fake-quotations fake-quotation boa ;
|
||||
|
||||
M: array >fake-quotations [ >fake-quotations ] { } map-as ;
|
||||
|
||||
M: object >fake-quotations ;
|
||||
|
||||
GENERIC: fake-quotations> ( fake -- quot )
|
||||
|
||||
M: fake-quotation fake-quotations>
|
||||
seq>> [ fake-quotations> ] map >quotation ;
|
||||
|
||||
M: array fake-quotations> [ fake-quotations> ] map ;
|
||||
|
||||
M: object fake-quotations> ;
|
||||
|
||||
: parse-definition* ( -- )
|
||||
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
|
||||
|
||||
: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
|
||||
|
||||
: `TUPLE:
|
||||
|
|
@ -32,7 +58,7 @@ IN: functors
|
|||
scan-param parsed
|
||||
scan-param parsed
|
||||
\ create-method parsed
|
||||
parse-definition parsed
|
||||
parse-definition*
|
||||
DEFINE* ; parsing
|
||||
|
||||
: `C:
|
||||
|
|
@ -45,7 +71,7 @@ IN: functors
|
|||
: `:
|
||||
effect off
|
||||
scan-param parsed
|
||||
parse-definition parsed
|
||||
parse-definition*
|
||||
DEFINE* ; parsing
|
||||
|
||||
: `INSTANCE:
|
||||
|
|
@ -64,12 +90,16 @@ IN: functors
|
|||
[ scan interpolate-locals ] dip
|
||||
'[ _ with-string-writer @ ] parsed ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
|
||||
|
||||
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
|
||||
|
||||
DEFER: ;FUNCTOR delimiter
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: functor-words ( -- assoc )
|
||||
H{
|
||||
{ "TUPLE:" POSTPONE: `TUPLE: }
|
||||
|
|
@ -104,4 +134,6 @@ DEFER: ;FUNCTOR delimiter
|
|||
parse-functor-body swap pop-locals <lambda>
|
||||
rewrite-closures first ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: FUNCTOR: (FUNCTOR:) define ; parsing
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ IN: furnace.auth.features.edit-profile
|
|||
} validate-params
|
||||
|
||||
{ "password" "new-password" "verify-password" }
|
||||
[ value empty? not ] contains? [
|
||||
[ value empty? not ] any? [
|
||||
"password" value username check-login
|
||||
[ "incorrect password" validation-error ] unless
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: furnace.auth.login
|
|||
SYMBOL: permit-id
|
||||
|
||||
: permit-id-key ( realm -- string )
|
||||
[ >hex 2 CHAR: 0 pad-left ] { } map-as concat
|
||||
[ >hex 2 CHAR: 0 pad-head ] { } map-as concat
|
||||
"__p_" prepend ;
|
||||
|
||||
: client-permit-id ( realm -- id/f )
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ ERROR: no-such-word name vocab ;
|
|||
|
||||
: base-path ( string -- pair )
|
||||
dup responder-nesting get
|
||||
[ second class superclasses [ name>> = ] with contains? ] with find nip
|
||||
[ second class superclasses [ name>> = ] with any? ] with find nip
|
||||
[ first ] [ "No such responder: " swap append throw ] ?if ;
|
||||
|
||||
: resolve-base-path ( string -- string' )
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ SYMBOL: vocabs-quot
|
|||
$predicate
|
||||
$class-description
|
||||
$error-description
|
||||
} swap '[ _ elements empty? not ] contains? ;
|
||||
} swap '[ _ elements empty? not ] any? ;
|
||||
|
||||
: don't-check-word? ( word -- ? )
|
||||
{
|
||||
|
|
@ -103,7 +103,7 @@ SYMBOL: vocabs-quot
|
|||
[ "Missing whitespace between strings" throw ] unless ;
|
||||
|
||||
: check-bogus-nl ( element -- )
|
||||
{ { $nl } { { $nl } } } [ head? ] with contains?
|
||||
{ { $nl } { { $nl } } } [ head? ] with any?
|
||||
[ "Simple element should not begin with a paragraph break" throw ] when ;
|
||||
|
||||
: check-elements ( element -- )
|
||||
|
|
@ -114,12 +114,22 @@ SYMBOL: vocabs-quot
|
|||
[ 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 )
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ GENERIC: render* ( value name renderer -- xml )
|
|||
[ f swap ]
|
||||
if
|
||||
] 2dip
|
||||
render* write-xml-chunk
|
||||
render* write-xml
|
||||
[ render-error ] when* ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -176,4 +176,4 @@ M: comparison render*
|
|||
! HTML component
|
||||
SINGLETON: html
|
||||
|
||||
M: html render* 2drop string>xml-chunk ;
|
||||
M: html render* 2drop <unescaped> ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,9 @@
|
|||
! cont-html v0.6
|
||||
!
|
||||
! Copyright (C) 2004 Chris Double.
|
||||
! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: io io.styles kernel namespaces prettyprint quotations
|
||||
sequences strings words xml.entities compiler.units effects
|
||||
urls math math.parser combinators present fry ;
|
||||
xml.data xml.interpolate urls math math.parser combinators
|
||||
present fry io.streams.string xml.writer ;
|
||||
|
||||
IN: html.elements
|
||||
|
||||
|
|
@ -135,17 +133,18 @@ SYMBOL: html
|
|||
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
|
||||
|
||||
: simple-page ( title head-quot body-quot -- )
|
||||
#! Call the quotation, with all output going to the
|
||||
#! body of an html page with the given title.
|
||||
spin
|
||||
xhtml-preamble
|
||||
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
|
||||
<head>
|
||||
<title> write </title>
|
||||
call
|
||||
</head>
|
||||
<body> call </body>
|
||||
</html> ; inline
|
||||
[ with-string-writer <unescaped> ] bi@
|
||||
<XML
|
||||
<?xml version="1.0"?>
|
||||
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
|
||||
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
|
||||
<head>
|
||||
<title><-></title>
|
||||
<->
|
||||
</head>
|
||||
<body><-></body>
|
||||
</html>
|
||||
XML> write-xml ; inline
|
||||
|
||||
: render-error ( message -- )
|
||||
<span "error" =class span> escape-string write </span> ;
|
||||
[XML <span class="error"><-></span> XML] write-xml ;
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ TUPLE: html-sub-stream < html-stream style parent ;
|
|||
|
||||
: hex-color, ( color -- )
|
||||
[ red>> ] [ green>> ] [ blue>> ] tri
|
||||
[ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
|
||||
[ 255 * >fixnum >hex 2 CHAR: 0 pad-head % ] tri@ ;
|
||||
|
||||
: fg-css, ( color -- )
|
||||
"color: #" % hex-color, "; " % ;
|
||||
|
|
|
|||
|
|
@ -7,16 +7,16 @@ html.templates html.templates.chloe.syntax continuations ;
|
|||
IN: html.templates.chloe.compiler
|
||||
|
||||
: chloe-attrs-only ( assoc -- assoc' )
|
||||
[ drop url>> chloe-ns = ] assoc-filter ;
|
||||
[ drop chloe-name? ] assoc-filter ;
|
||||
|
||||
: non-chloe-attrs-only ( assoc -- assoc' )
|
||||
[ drop url>> chloe-ns = not ] assoc-filter ;
|
||||
[ drop chloe-name? not ] assoc-filter ;
|
||||
|
||||
: chloe-tag? ( tag -- ? )
|
||||
dup xml? [ body>> ] when
|
||||
{
|
||||
{ [ dup tag? not ] [ f ] }
|
||||
{ [ dup url>> chloe-ns = not ] [ f ] }
|
||||
{ [ dup chloe-name? not ] [ f ] }
|
||||
[ t ]
|
||||
} cond nip ;
|
||||
|
||||
|
|
@ -59,7 +59,7 @@ DEFER: compile-element
|
|||
|
||||
: compile-start-tag ( tag -- )
|
||||
"<" [write]
|
||||
[ name>string [write] ] [ compile-attrs ] bi
|
||||
[ name>string [write] ] [ attrs>> compile-attrs ] bi
|
||||
">" [write] ;
|
||||
|
||||
: compile-end-tag ( tag -- )
|
||||
|
|
@ -90,7 +90,7 @@ ERROR: unknown-chloe-tag tag ;
|
|||
{ [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
|
||||
{ [ dup string? ] [ escape-string [write] ] }
|
||||
{ [ dup comment? ] [ drop ] }
|
||||
[ [ write-xml-chunk ] [code-with] ]
|
||||
[ [ write-xml ] [code-with] ]
|
||||
} cond ;
|
||||
|
||||
: with-compiler ( quot -- quot' )
|
||||
|
|
@ -126,7 +126,7 @@ ERROR: unknown-chloe-tag tag ;
|
|||
|
||||
: compile-prologue ( xml -- )
|
||||
[
|
||||
[ prolog>> [ write-prolog ] [code-with] ]
|
||||
[ prolog>> [ write-xml ] [code-with] ]
|
||||
[ before>> compile-chunk ]
|
||||
bi
|
||||
] compile-quot
|
||||
|
|
|
|||
|
|
@ -21,14 +21,14 @@ tags global [ H{ } clone or ] change-at
|
|||
|
||||
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
|
||||
|
||||
: chloe-name ( string -- name )
|
||||
name new
|
||||
swap >>main
|
||||
chloe-ns >>url ;
|
||||
: chloe-name? ( name -- ? )
|
||||
url>> chloe-ns = ;
|
||||
|
||||
XML-NS: chloe-name http://factorcode.org/chloe/1.0
|
||||
|
||||
: required-attr ( tag name -- value )
|
||||
dup chloe-name rot at*
|
||||
[ nip ] [ drop " attribute is required" append throw ] if ;
|
||||
tuck chloe-name attr
|
||||
[ nip ] [ " attribute is required" append throw ] if* ;
|
||||
|
||||
: optional-attr ( tag name -- value )
|
||||
chloe-name swap at ;
|
||||
chloe-name attr ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ sequences strings splitting calendar continuations accessors vectors
|
|||
math.order hashtables byte-arrays destructors
|
||||
io io.sockets io.streams.string io.files io.timeouts
|
||||
io.pathnames io.encodings io.encodings.string io.encodings.ascii
|
||||
io.encodings.utf8 io.encodings.8-bit io.encodings.binary
|
||||
io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf
|
||||
io.streams.duplex fry ascii urls urls.encoding present
|
||||
http http.parsers http.client.post-data ;
|
||||
IN: http.client
|
||||
|
|
@ -86,7 +86,7 @@ SYMBOL: redirects
|
|||
] [ too-many-redirects ] if ; inline recursive
|
||||
|
||||
: read-chunk-size ( -- n )
|
||||
read-crlf ";" split1 drop [ blank? ] trim-right
|
||||
read-crlf ";" split1 drop [ blank? ] trim-tail
|
||||
hex> [ "Bad chunk size" throw ] unless* ;
|
||||
|
||||
: read-chunked ( quot: ( chunk -- ) -- )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: http http.server http.client http.client.private tools.test multiline
|
|||
io.streams.string io.encodings.utf8 io.encodings.8-bit
|
||||
io.encodings.binary io.encodings.string kernel arrays splitting
|
||||
sequences assocs io.sockets db db.sqlite continuations urls
|
||||
hashtables accessors namespaces ;
|
||||
hashtables accessors namespaces xml.data ;
|
||||
IN: http.tests
|
||||
|
||||
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
|
||||
|
|
@ -322,7 +322,7 @@ SYMBOL: a
|
|||
|
||||
3 a set-global
|
||||
|
||||
: test-a string>xml "input" tag-named "value" swap at ;
|
||||
: test-a string>xml "input" tag-named "value" attr ;
|
||||
|
||||
[ "3" ] [
|
||||
"http://localhost/" add-port http-get
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ quotations arrays byte-arrays math.parser calendar
|
|||
calendar.format present urls
|
||||
|
||||
io io.encodings io.encodings.iana io.encodings.binary
|
||||
io.encodings.8-bit
|
||||
io.encodings.8-bit io.crlf
|
||||
|
||||
unicode.case unicode.categories
|
||||
|
||||
|
|
@ -16,12 +16,6 @@ EXCLUDE: fry => , ;
|
|||
|
||||
IN: http
|
||||
|
||||
: crlf ( -- ) "\r\n" write ;
|
||||
|
||||
: read-crlf ( -- bytes )
|
||||
"\r" read-until
|
||||
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
|
||||
|
||||
: (read-header) ( -- alist )
|
||||
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,8 +12,10 @@ io.encodings.utf8
|
|||
io.encodings.ascii
|
||||
io.encodings.binary
|
||||
io.streams.limited
|
||||
io.streams.string
|
||||
io.servers.connection
|
||||
io.timeouts
|
||||
io.crlf
|
||||
fry logging logging.insomniac calendar urls urls.encoding
|
||||
mime.multipart
|
||||
unicode.categories
|
||||
|
|
|
|||
|
|
@ -45,9 +45,9 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
[ file-responder get hook>> call ] [ 2drop <304> ] if ;
|
||||
|
||||
: serving-path ( filename -- filename )
|
||||
file-responder get root>> trim-right-separators
|
||||
file-responder get root>> trim-tail-separators
|
||||
"/"
|
||||
rot "" or trim-left-separators 3append ;
|
||||
rot "" or trim-head-separators 3append ;
|
||||
|
||||
: serve-file ( filename -- response )
|
||||
dup mime-type
|
||||
|
|
|
|||
|
|
@ -164,10 +164,10 @@ M: stdin refill
|
|||
size-read-fd <fd> init-fd <input-port> >>size
|
||||
data-read-fd <fd> >>data ;
|
||||
|
||||
M: unix (init-stdio) ( -- )
|
||||
M: unix (init-stdio)
|
||||
<stdin> <input-port>
|
||||
1 <fd> <output-port>
|
||||
2 <fd> <output-port> ;
|
||||
2 <fd> <output-port> t ;
|
||||
|
||||
! mx io-task for embedding an fd-based mx inside another mx
|
||||
TUPLE: mx-port < port mx ;
|
||||
|
|
|
|||
|
|
@ -120,6 +120,9 @@ M: winnt (wait-to-read) ( port -- )
|
|||
tri
|
||||
] with-destructors ;
|
||||
|
||||
M: winnt (init-stdio) init-c-stdio ;
|
||||
: console-app? ( -- ? ) GetConsoleWindow >boolean ;
|
||||
|
||||
M: winnt (init-stdio)
|
||||
console-app? [ init-c-stdio t ] [ f f f f ] if ;
|
||||
|
||||
winnt set-io-backend
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
Daniel Ehrenberg
|
||||
Slava Pestov
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup sequences ;
|
||||
IN: io.crlf
|
||||
|
||||
HELP: crlf
|
||||
{ $values }
|
||||
{ $description "Prints a carriage return and line feed to the current output stream, used to indicate a newline for certain network protocols." } ;
|
||||
|
||||
HELP: read-crlf
|
||||
{ $values { "seq" sequence } }
|
||||
{ $description "Reads until the next CRLF (carriage return followed by line feed) from the current input stream, throwing an error if there is not a CRLF remaining, or if CR is present without immediately being followed by LF." } ;
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io kernel ;
|
||||
IN: io.crlf
|
||||
|
||||
: crlf ( -- )
|
||||
"\r\n" write ;
|
||||
|
||||
: read-crlf ( -- seq )
|
||||
"\r" read-until
|
||||
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Writing and reading until \r\n
|
||||
|
|
@ -15,7 +15,7 @@ IN: io.directories
|
|||
HOOK: make-directory io-backend ( path -- )
|
||||
|
||||
: make-directories ( path -- )
|
||||
normalize-path trim-right-separators {
|
||||
normalize-path trim-tail-separators {
|
||||
{ [ dup "." = ] [ ] }
|
||||
{ [ dup root-directory? ] [ ] }
|
||||
{ [ dup empty? ] [ ] }
|
||||
|
|
@ -87,4 +87,4 @@ M: object copy-file
|
|||
{
|
||||
{ [ os unix? ] [ "io.directories.unix" require ] }
|
||||
{ [ os windows? ] [ "io.directories.windows" require ] }
|
||||
} cond
|
||||
} cond
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ HELP: find-all-in-directories
|
|||
|
||||
{ find-file find-all-files find-in-directories find-all-in-directories } related-words
|
||||
|
||||
ARTICLE: "io.directories.search" "io.directories.search"
|
||||
ARTICLE: "io.directories.search" "Searching directories"
|
||||
"The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl
|
||||
"Traversing directories:"
|
||||
{ $subsection recursive-directory }
|
||||
|
|
|
|||
|
|
@ -25,8 +25,8 @@ IN: io.files.windows.nt.tests
|
|||
[ t ] [ "\\\\" root-directory? ] unit-test
|
||||
[ t ] [ "/" root-directory? ] unit-test
|
||||
[ t ] [ "//" root-directory? ] unit-test
|
||||
[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test
|
||||
[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test
|
||||
[ t ] [ "c:\\" trim-tail-separators root-directory? ] unit-test
|
||||
[ t ] [ "Z:\\" trim-tail-separators root-directory? ] unit-test
|
||||
[ f ] [ "c:\\foo" root-directory? ] unit-test
|
||||
[ f ] [ "." root-directory? ] unit-test
|
||||
[ f ] [ ".." root-directory? ] unit-test
|
||||
|
|
|
|||
|
|
@ -22,10 +22,10 @@ M: winnt root-directory? ( path -- ? )
|
|||
{
|
||||
{ [ dup empty? ] [ drop f ] }
|
||||
{ [ dup [ path-separator? ] all? ] [ drop t ] }
|
||||
{ [ dup trim-right-separators { [ length 2 = ]
|
||||
{ [ dup trim-tail-separators { [ length 2 = ]
|
||||
[ second CHAR: : = ] } 1&& ] [ drop t ] }
|
||||
{ [ dup unicode-prefix head? ]
|
||||
[ trim-right-separators length unicode-prefix length 2 + = ] }
|
||||
[ trim-tail-separators length unicode-prefix length 2 + = ] }
|
||||
[ drop f ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,9 +20,9 @@ with-mapped-A-file DEFINES with-mapped-${T}-file
|
|||
WHERE
|
||||
|
||||
: <mapped-A> ( mapped-file -- direct-array )
|
||||
T mapped-file>direct <A> execute ; inline
|
||||
T mapped-file>direct <A> ; inline
|
||||
|
||||
: with-mapped-A-file ( path length quot -- )
|
||||
'[ <mapped-A> execute @ ] with-mapped-file ; inline
|
||||
'[ <mapped-A> @ ] with-mapped-file ; inline
|
||||
|
||||
;FUNCTOR
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ HELP: <mapped-file>
|
|||
HELP: with-mapped-file
|
||||
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
|
||||
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
|
||||
{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: close-mapped-file
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ IN: io.monitors.linux.tests
|
|||
USING: io.monitors tools.test io.files io.files.temp
|
||||
io.directories system sequences continuations namespaces
|
||||
concurrency.count-downs kernel io threads calendar prettyprint
|
||||
destructors io.timeouts ;
|
||||
destructors io.timeouts accessors ;
|
||||
|
||||
! On Linux, a notification on the directory itself would report an invalid
|
||||
! path name
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ os { winnt linux macosx } member? [
|
|||
"m" get next-change path>>
|
||||
dup print flush
|
||||
dup parent-directory
|
||||
[ trim-right-separators "xyz" tail? ] either? not
|
||||
[ trim-tail-separators "xyz" tail? ] either? not
|
||||
] loop
|
||||
|
||||
"c1" get count-down
|
||||
|
|
@ -65,7 +65,7 @@ os { winnt linux macosx } member? [
|
|||
"m" get next-change path>>
|
||||
dup print flush
|
||||
dup parent-directory
|
||||
[ trim-right-separators "yxy" tail? ] either? not
|
||||
[ trim-tail-separators "yxy" tail? ] either? not
|
||||
] loop
|
||||
|
||||
"c2" get count-down
|
||||
|
|
|
|||
|
|
@ -118,7 +118,7 @@ M: plain-writer make-block-stream
|
|||
: format-column ( seq ? -- seq )
|
||||
[
|
||||
[ 0 [ length max ] reduce ] keep
|
||||
swap [ CHAR: \s pad-right ] curry map
|
||||
swap [ CHAR: \s pad-tail ] curry map
|
||||
] unless ;
|
||||
|
||||
: map-last ( seq quot -- seq )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel calendar alarms io io.encodings accessors
|
||||
namespaces fry ;
|
||||
namespaces fry io.streams.null ;
|
||||
IN: io.timeouts
|
||||
|
||||
GENERIC: timeout ( obj -- dt/f )
|
||||
|
|
@ -27,3 +27,5 @@ GENERIC: cancel-operation ( obj -- )
|
|||
: timeouts ( dt -- )
|
||||
[ input-stream get set-timeout ]
|
||||
[ output-stream get set-timeout ] bi ;
|
||||
|
||||
M: null-stream set-timeout 2drop ;
|
||||
|
|
|
|||
|
|
@ -3,4 +3,4 @@
|
|||
USING: lcs.diff2html lcs kernel tools.test strings sequences xml.writer ;
|
||||
IN: lcs.diff2html.tests
|
||||
|
||||
[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml-chunk>string drop ] unit-test
|
||||
[ ] [ "hello" "heyo" [ 1string ] { } map-as diff htmlize-diff xml>string drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -113,7 +113,7 @@ HELP: MEMO::
|
|||
|
||||
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
|
||||
|
||||
ARTICLE: "locals-literals" "Locals in array and hashtable literals"
|
||||
ARTICLE: "locals-literals" "Locals in literals"
|
||||
"Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
|
||||
$nl
|
||||
"The data types which receive this special handling are the following:"
|
||||
|
|
@ -122,7 +122,9 @@ $nl
|
|||
{ $link "hashtables" }
|
||||
{ $link "vectors" }
|
||||
{ $link "tuples" }
|
||||
{ $link "wrappers" }
|
||||
}
|
||||
{ $heading "Object identity" }
|
||||
"This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:"
|
||||
{ $example
|
||||
"IN: scratchpad"
|
||||
|
|
@ -143,7 +145,7 @@ $nl
|
|||
"f"
|
||||
}
|
||||
"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
|
||||
$nl
|
||||
{ $heading "Example" }
|
||||
"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
|
||||
{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -494,4 +494,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
|||
|
||||
! Discovered by littledan
|
||||
[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
|
||||
[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
|
||||
[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
|
||||
|
||||
[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test
|
||||
|
||||
[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test
|
||||
|
||||
[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
|
||||
|
|
@ -40,7 +40,7 @@ M: object localize 1quotation ;
|
|||
! We special-case all the :> at the start of a quotation
|
||||
: load-locals-quot ( args -- quot )
|
||||
[ [ ] ] [
|
||||
dup [ local-reader? ] contains? [
|
||||
dup [ local-reader? ] any? [
|
||||
dup [ local-reader? [ 1array ] [ ] ? ] map
|
||||
spread>quot
|
||||
] [ [ ] ] if swap length [ load-locals ] curry append
|
||||
|
|
|
|||
|
|
@ -33,11 +33,11 @@ GENERIC: rewrite-literal? ( obj -- ? )
|
|||
|
||||
M: special rewrite-literal? drop t ;
|
||||
|
||||
M: array rewrite-literal? [ rewrite-literal? ] contains? ;
|
||||
M: array rewrite-literal? [ rewrite-literal? ] any? ;
|
||||
|
||||
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
|
||||
M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
|
||||
|
||||
M: wrapper rewrite-literal? drop t ;
|
||||
M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
|
||||
|
||||
M: hashtable rewrite-literal? drop t ;
|
||||
|
||||
|
|
@ -53,7 +53,7 @@ GENERIC: rewrite-element ( obj -- )
|
|||
[ rewrite-element ] each ;
|
||||
|
||||
: rewrite-sequence ( seq -- )
|
||||
[ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
|
||||
[ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ;
|
||||
|
||||
M: array rewrite-element
|
||||
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
|
||||
|
|
@ -63,7 +63,7 @@ M: vector rewrite-element rewrite-sequence ;
|
|||
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
|
||||
|
||||
M: tuple rewrite-element
|
||||
[ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
|
||||
[ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ;
|
||||
|
||||
M: quotation rewrite-element rewrite-sugar* ;
|
||||
|
||||
|
|
@ -81,10 +81,14 @@ M: local-writer rewrite-element
|
|||
M: local-word rewrite-element
|
||||
local-word-in-literal-error ;
|
||||
|
||||
M: word rewrite-element literalize , ;
|
||||
M: word rewrite-element <wrapper> , ;
|
||||
|
||||
: rewrite-wrapper ( wrapper -- )
|
||||
dup rewrite-literal?
|
||||
[ wrapped>> rewrite-element ] [ , ] if ;
|
||||
|
||||
M: wrapper rewrite-element
|
||||
dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
|
||||
rewrite-wrapper \ <wrapper> , ;
|
||||
|
||||
M: object rewrite-element , ;
|
||||
|
||||
|
|
@ -98,7 +102,8 @@ M: def rewrite-sugar* , ;
|
|||
|
||||
M: hashtable rewrite-sugar* rewrite-element ;
|
||||
|
||||
M: wrapper rewrite-sugar* rewrite-element ;
|
||||
M: wrapper rewrite-sugar*
|
||||
rewrite-wrapper ;
|
||||
|
||||
M: word rewrite-sugar*
|
||||
dup { load-locals get-local drop-locals } memq?
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators kernel sequences words ;
|
||||
USING: accessors combinators kernel sequences words
|
||||
quotations ;
|
||||
IN: locals.types
|
||||
|
||||
TUPLE: lambda vars body ;
|
||||
|
|
@ -38,6 +39,8 @@ PREDICATE: local < word "local?" word-prop ;
|
|||
f <word>
|
||||
dup t "local?" set-word-prop ;
|
||||
|
||||
M: local literalize ;
|
||||
|
||||
PREDICATE: local-word < word "local-word?" word-prop ;
|
||||
|
||||
: <local-word> ( name -- word )
|
||||
|
|
@ -49,6 +52,8 @@ PREDICATE: local-reader < word "local-reader?" word-prop ;
|
|||
f <word>
|
||||
dup t "local-reader?" set-word-prop ;
|
||||
|
||||
M: local-reader literalize ;
|
||||
|
||||
PREDICATE: local-writer < word "local-writer?" word-prop ;
|
||||
|
||||
: <local-writer> ( reader -- word )
|
||||
|
|
|
|||
|
|
@ -1,3 +1,2 @@
|
|||
math
|
||||
bindings
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -268,28 +268,28 @@ TUPLE: MATRIX < blas-matrix-base ;
|
|||
M: MATRIX element-type
|
||||
drop TYPE ;
|
||||
M: MATRIX (blas-matrix-like)
|
||||
drop <MATRIX> execute ;
|
||||
drop <MATRIX> ;
|
||||
M: VECTOR (blas-matrix-like)
|
||||
drop <MATRIX> execute ;
|
||||
drop <MATRIX> ;
|
||||
M: MATRIX (blas-vector-like)
|
||||
drop <VECTOR> execute ;
|
||||
drop <VECTOR> ;
|
||||
|
||||
: >MATRIX ( arrays -- matrix )
|
||||
[ >ARRAY execute underlying>> ] (>matrix)
|
||||
<MATRIX> execute ;
|
||||
[ >ARRAY underlying>> ] (>matrix)
|
||||
<MATRIX> ;
|
||||
|
||||
M: VECTOR n*M.V+n*V!
|
||||
[ TYPE>ARG execute ] (prepare-gemv)
|
||||
[ XGEMV execute ] dip ;
|
||||
[ TYPE>ARG ] (prepare-gemv)
|
||||
[ XGEMV ] dip ;
|
||||
M: MATRIX n*M.M+n*M!
|
||||
[ TYPE>ARG execute ] (prepare-gemm)
|
||||
[ XGEMM execute ] dip ;
|
||||
[ TYPE>ARG ] (prepare-gemm)
|
||||
[ XGEMM ] dip ;
|
||||
M: MATRIX n*V(*)V+M!
|
||||
[ TYPE>ARG execute ] (prepare-ger)
|
||||
[ XGERU execute ] dip ;
|
||||
[ TYPE>ARG ] (prepare-ger)
|
||||
[ XGERU ] dip ;
|
||||
M: MATRIX n*V(*)Vconj+M!
|
||||
[ TYPE>ARG execute ] (prepare-ger)
|
||||
[ XGERC execute ] dip ;
|
||||
[ TYPE>ARG ] (prepare-ger)
|
||||
[ XGERC ] dip ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,2 @@
|
|||
math
|
||||
bindings
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel math.blas.vectors math.blas.matrices parser
|
||||
arrays prettyprint.backend sequences ;
|
||||
arrays prettyprint.backend prettyprint.custom sequences ;
|
||||
IN: math.blas.syntax
|
||||
|
||||
: svector{
|
||||
|
|
|
|||
|
|
@ -1,2 +1 @@
|
|||
math
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -1,2 +1 @@
|
|||
math
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -144,26 +144,26 @@ TUPLE: VECTOR < blas-vector-base ;
|
|||
: <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
|
||||
|
||||
: >VECTOR ( seq -- v )
|
||||
[ >ARRAY execute underlying>> ] [ length ] bi 1 <VECTOR> execute ;
|
||||
[ >ARRAY underlying>> ] [ length ] bi 1 <VECTOR> ;
|
||||
|
||||
M: VECTOR clone
|
||||
TYPE heap-size (prepare-copy)
|
||||
[ XCOPY execute ] 3dip <VECTOR> execute ;
|
||||
[ XCOPY ] 3dip <VECTOR> ;
|
||||
|
||||
M: VECTOR element-type
|
||||
drop TYPE ;
|
||||
M: VECTOR Vswap
|
||||
(prepare-swap) [ XSWAP execute ] 2dip ;
|
||||
(prepare-swap) [ XSWAP ] 2dip ;
|
||||
M: VECTOR Viamax
|
||||
(prepare-nrm2) IXAMAX execute ;
|
||||
(prepare-nrm2) IXAMAX ;
|
||||
|
||||
M: VECTOR (blas-vector-like)
|
||||
drop <VECTOR> execute ;
|
||||
drop <VECTOR> ;
|
||||
|
||||
M: VECTOR (blas-direct-array)
|
||||
[ underlying>> ]
|
||||
[ [ length>> ] [ inc>> ] bi * ] bi
|
||||
<DIRECT-ARRAY> execute ;
|
||||
<DIRECT-ARRAY> ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
|
@ -180,17 +180,17 @@ XSCAL IS cblas_${T}scal
|
|||
WHERE
|
||||
|
||||
M: VECTOR V.
|
||||
(prepare-dot) XDOT execute ;
|
||||
(prepare-dot) XDOT ;
|
||||
M: VECTOR V.conj
|
||||
(prepare-dot) XDOT execute ;
|
||||
(prepare-dot) XDOT ;
|
||||
M: VECTOR Vnorm
|
||||
(prepare-nrm2) XNRM2 execute ;
|
||||
(prepare-nrm2) XNRM2 ;
|
||||
M: VECTOR Vasum
|
||||
(prepare-nrm2) XASUM execute ;
|
||||
(prepare-nrm2) XASUM ;
|
||||
M: VECTOR n*V+V!
|
||||
(prepare-axpy) [ XAXPY execute ] dip ;
|
||||
(prepare-axpy) [ XAXPY ] dip ;
|
||||
M: VECTOR n*V!
|
||||
(prepare-scal) [ XSCAL execute ] dip ;
|
||||
(prepare-scal) [ XSCAL ] dip ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
|
@ -207,13 +207,13 @@ COMPLEX>ARG DEFINES ${TYPE}-complex>arg
|
|||
WHERE
|
||||
|
||||
: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
|
||||
1 shift <DIRECT-ARRAY> execute <complex-sequence> ;
|
||||
1 shift <DIRECT-ARRAY> <complex-sequence> ;
|
||||
: >COMPLEX-ARRAY ( sequence -- sequence )
|
||||
<complex-components> >ARRAY execute ;
|
||||
<complex-components> >ARRAY ;
|
||||
: COMPLEX>ARG ( complex -- alien )
|
||||
>rect 2array >ARRAY execute underlying>> ;
|
||||
>rect 2array >ARRAY underlying>> ;
|
||||
: ARG>COMPLEX ( alien -- complex )
|
||||
2 <DIRECT-ARRAY> execute first2 rect> ;
|
||||
2 <DIRECT-ARRAY> first2 rect> ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
|
@ -234,22 +234,22 @@ WHERE
|
|||
|
||||
M: VECTOR V.
|
||||
(prepare-dot) TYPE <c-object>
|
||||
[ XDOTU_SUB execute ] keep
|
||||
ARG>TYPE execute ;
|
||||
[ XDOTU_SUB ] keep
|
||||
ARG>TYPE ;
|
||||
M: VECTOR V.conj
|
||||
(prepare-dot) TYPE <c-object>
|
||||
[ XDOTC_SUB execute ] keep
|
||||
ARG>TYPE execute ;
|
||||
[ XDOTC_SUB ] keep
|
||||
ARG>TYPE ;
|
||||
M: VECTOR Vnorm
|
||||
(prepare-nrm2) XXNRM2 execute ;
|
||||
(prepare-nrm2) XXNRM2 ;
|
||||
M: VECTOR Vasum
|
||||
(prepare-nrm2) XXASUM execute ;
|
||||
(prepare-nrm2) XXASUM ;
|
||||
M: VECTOR n*V+V!
|
||||
[ TYPE>ARG execute ] 2dip
|
||||
(prepare-axpy) [ XAXPY execute ] dip ;
|
||||
[ TYPE>ARG ] 2dip
|
||||
(prepare-axpy) [ XAXPY ] dip ;
|
||||
M: VECTOR n*V!
|
||||
[ TYPE>ARG execute ] dip
|
||||
(prepare-scal) [ XSCAL execute ] dip ;
|
||||
[ TYPE>ARG ] dip
|
||||
(prepare-scal) [ XSCAL ] dip ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ IN: math.combinatorics
|
|||
reverse 1 cut [ (>permutation) ] each ;
|
||||
|
||||
: permutation-indices ( n seq -- permutation )
|
||||
length [ factoradic ] dip 0 pad-left >permutation ;
|
||||
length [ factoradic ] dip 0 pad-head >permutation ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ TUPLE: interval { from read-only } { to read-only } ;
|
|||
[ from>> ] [ to>> ] bi ;
|
||||
|
||||
: points>interval ( seq -- interval )
|
||||
dup [ first fp-nan? ] contains?
|
||||
dup [ first fp-nan? ] any?
|
||||
[ drop [-inf,inf] ] [
|
||||
dup first
|
||||
[ [ endpoint-min ] reduce ]
|
||||
|
|
|
|||
|
|
@ -6,10 +6,10 @@ IN: math.polynomials
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: 2pad-left ( p q n -- p q ) [ 0 pad-left ] curry bi@ ;
|
||||
: 2pad-right ( p q n -- p q ) [ 0 pad-right ] curry bi@ ;
|
||||
: pextend ( p q -- p q ) 2dup [ length ] bi@ max 2pad-right ;
|
||||
: pextend-left ( p q -- p q ) 2dup [ length ] bi@ max 2pad-left ;
|
||||
: 2pad-head ( p q n -- p q ) [ 0 pad-head ] curry bi@ ;
|
||||
: 2pad-tail ( p q n -- p q ) [ 0 pad-tail ] curry bi@ ;
|
||||
: pextend ( p q -- p q ) 2dup [ length ] bi@ max 2pad-tail ;
|
||||
: pextend-left ( p q -- p q ) 2dup [ length ] bi@ max 2pad-head ;
|
||||
: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
|
||||
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
|
||||
|
||||
|
|
@ -21,7 +21,7 @@ PRIVATE>
|
|||
: p= ( p q -- ? ) pextend = ;
|
||||
|
||||
: ptrim ( p -- p )
|
||||
dup length 1 = [ [ zero? ] trim-right ] unless ;
|
||||
dup length 1 = [ [ zero? ] trim-tail ] unless ;
|
||||
|
||||
: 2ptrim ( p q -- p q ) [ ptrim ] bi@ ;
|
||||
: p+ ( p q -- r ) pextend v+ ;
|
||||
|
|
@ -29,7 +29,7 @@ PRIVATE>
|
|||
: n*p ( n p -- n*p ) n*v ;
|
||||
|
||||
: pextend-conv ( p q -- p q )
|
||||
2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
|
||||
2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ;
|
||||
|
||||
: p* ( p q -- r )
|
||||
2unempty pextend-conv <reversed> dup length
|
||||
|
|
@ -44,7 +44,7 @@ PRIVATE>
|
|||
2ptrim
|
||||
2dup [ length ] bi@ -
|
||||
dup 1 < [ drop 1 ] when
|
||||
[ over length + 0 pad-left pextend ] keep 1+ ;
|
||||
[ over length + 0 pad-head pextend ] keep 1+ ;
|
||||
|
||||
: /-last ( seq seq -- a )
|
||||
#! divide the last two numbers in the sequences
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: math.ranges sequences tools.test arrays ;
|
||||
USING: math math.ranges sequences sets tools.test arrays ;
|
||||
IN: math.ranges.tests
|
||||
|
||||
[ { } ] [ 1 1 (a,b) >array ] unit-test
|
||||
|
|
@ -11,7 +11,7 @@ IN: math.ranges.tests
|
|||
[ { 1 } ] [ 1 2 [a,b) >array ] unit-test
|
||||
[ { 1 2 } ] [ 1 2 [a,b] >array ] unit-test
|
||||
|
||||
[ { } ] [ 2 1 (a,b) >array ] unit-test
|
||||
[ { } ] [ 2 1 (a,b) >array ] unit-test
|
||||
[ { 1 } ] [ 2 1 (a,b] >array ] unit-test
|
||||
[ { 2 } ] [ 2 1 [a,b) >array ] unit-test
|
||||
[ { 2 1 } ] [ 2 1 [a,b] >array ] unit-test
|
||||
|
|
@ -32,3 +32,7 @@ IN: math.ranges.tests
|
|||
[ 0 ] [ -1 5 [0,b] clamp-to-range ] unit-test
|
||||
[ 5 ] [ 6 5 [0,b] clamp-to-range ] unit-test
|
||||
[ { 0 1 2 3 4 } ] [ 5 sequence-index-range >array ] unit-test
|
||||
|
||||
[ 100 ] [
|
||||
1 100 [a,b] [ 2^ [1,b] ] map prune length
|
||||
] unit-test
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts math math.order namespaces sequences
|
||||
sequences.private accessors ;
|
||||
sequences.private accessors classes.tuple arrays ;
|
||||
IN: math.ranges
|
||||
|
||||
TUPLE: range
|
||||
|
|
@ -18,6 +18,12 @@ M: range length ( seq -- n )
|
|||
M: range nth-unsafe ( n range -- obj )
|
||||
[ step>> * ] keep from>> + ;
|
||||
|
||||
! For ranges with many elements, the default element-wise methods
|
||||
! sequences define are unsuitable because they're O(n)
|
||||
M: range equal? over range? [ tuple= ] [ 2drop f ] if ;
|
||||
|
||||
M: range hashcode* tuple-hashcode ;
|
||||
|
||||
INSTANCE: range immutable-sequence
|
||||
|
||||
: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
|
||||
|
|
|
|||
|
|
@ -356,6 +356,10 @@ CONSTANT: GL_DITHER HEX: 0BD0
|
|||
CONSTANT: GL_RGB HEX: 1907
|
||||
CONSTANT: GL_RGBA HEX: 1908
|
||||
|
||||
! GL_BGRA_ext: http://www.opengl.org/registry/specs/EXT/bgra.txt
|
||||
CONSTANT: GL_BGR_EXT HEX: 80E0
|
||||
CONSTANT: GL_BGRA_EXT HEX: 80E1
|
||||
|
||||
! Implementation limits
|
||||
CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31
|
||||
CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35
|
||||
|
|
|
|||
|
|
@ -509,7 +509,7 @@ TUPLE: sp-parser p1 ;
|
|||
|
||||
M: sp-parser (compile) ( peg -- quot )
|
||||
p1>> compile-parser 1quotation '[
|
||||
input-slice [ blank? ] trim-left-slice input-from pos set @
|
||||
input-slice [ blank? ] trim-head-slice input-from pos set @
|
||||
] ;
|
||||
|
||||
TUPLE: delay-parser quot ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue