Merge commit 'origin/master' into emacs
Jose A. Ortega Ruiz
commit
dac0b5447c
|
|
@ -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 } ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 @@ 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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -49,7 +49,7 @@ DEFER: compile-element
|
|||
reset-buffer "@" ?head [ , [ value present ] % ] [ , ] if ;
|
||||
|
||||
: compile-attrs ( assoc -- )
|
||||
[
|
||||
attrs>> [
|
||||
" " [write]
|
||||
swap name>string [write]
|
||||
"=\"" [write]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ io.encodings.binary
|
|||
io.streams.limited
|
||||
io.servers.connection
|
||||
io.timeouts
|
||||
io.crlf
|
||||
fry logging logging.insomniac calendar urls urls.encoding
|
||||
mime.multipart
|
||||
unicode.categories
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -37,7 +37,7 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ;
|
|||
|
||||
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
|
||||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -27,8 +27,8 @@ TUPLE: A
|
|||
M: A length length>> ;
|
||||
M: A nth-unsafe underlying>> NTH call ;
|
||||
M: A set-nth-unsafe underlying>> SET-NTH call ;
|
||||
M: A like drop dup A instance? [ >A' execute ] unless ;
|
||||
M: A new-sequence drop <A'> execute ;
|
||||
M: A like drop dup A instance? [ >A' ] unless ;
|
||||
M: A new-sequence drop <A'> ;
|
||||
|
||||
INSTANCE: A sequence
|
||||
|
||||
|
|
|
|||
|
|
@ -49,9 +49,9 @@ M: A set-nth-unsafe underlying>> SET-NTH call ;
|
|||
|
||||
: >A ( seq -- specialized-array ) A new clone-like ; inline
|
||||
|
||||
M: A like drop dup A instance? [ >A execute ] unless ;
|
||||
M: A like drop dup A instance? [ >A ] unless ;
|
||||
|
||||
M: A new-sequence drop (A) execute ;
|
||||
M: A new-sequence drop (A) ;
|
||||
|
||||
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
|
|
@ -64,13 +64,13 @@ M: A resize
|
|||
|
||||
M: A byte-length underlying>> length ;
|
||||
|
||||
M: A pprint-delims drop A{ \ } ;
|
||||
M: A pprint-delims drop \ A{ \ } ;
|
||||
|
||||
M: A >pprint-sequence ;
|
||||
|
||||
M: A pprint* pprint-object ;
|
||||
|
||||
: A{ \ } [ >A execute ] parse-literal ; parsing
|
||||
: A{ \ } [ >A ] parse-literal ; parsing
|
||||
|
||||
INSTANCE: A sequence
|
||||
|
||||
|
|
|
|||
|
|
@ -18,28 +18,28 @@ WHERE
|
|||
|
||||
TUPLE: V { underlying A } { length array-capacity } ;
|
||||
|
||||
: <V> ( capacity -- vector ) <A> execute 0 V boa ; inline
|
||||
: <V> ( capacity -- vector ) <A> 0 V boa ; inline
|
||||
|
||||
M: V like
|
||||
drop dup V instance? [
|
||||
dup A instance? [ dup length V boa ] [ >V execute ] if
|
||||
dup A instance? [ dup length V boa ] [ >V ] if
|
||||
] unless ;
|
||||
|
||||
M: V new-sequence drop [ <A> execute ] [ >fixnum ] bi V boa ;
|
||||
M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
|
||||
|
||||
M: A new-resizable drop <V> execute ;
|
||||
M: A new-resizable drop <V> ;
|
||||
|
||||
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
: >V ( seq -- vector ) V new clone-like ; inline
|
||||
|
||||
M: V pprint-delims drop V{ \ } ;
|
||||
M: V pprint-delims drop \ V{ \ } ;
|
||||
|
||||
M: V >pprint-sequence ;
|
||||
|
||||
M: V pprint* pprint-object ;
|
||||
|
||||
: V{ \ } [ >V execute ] parse-literal ; parsing
|
||||
: V{ \ } [ >V ] parse-literal ; parsing
|
||||
|
||||
INSTANCE: V growable
|
||||
|
||||
|
|
|
|||
|
|
@ -70,8 +70,8 @@ TUPLE: entry title url description date ;
|
|||
tri ;
|
||||
|
||||
: atom-entry-link ( tag -- url/f )
|
||||
"link" tags-named [ "rel" swap at "alternate" = ] find nip
|
||||
dup [ "href" swap at >url ] when ;
|
||||
"link" tags-named [ "rel" attr "alternate" = ] find nip
|
||||
dup [ "href" attr >url ] when ;
|
||||
|
||||
: atom1.0-entry ( tag -- entry )
|
||||
entry new
|
||||
|
|
@ -95,7 +95,7 @@ TUPLE: entry title url description date ;
|
|||
feed new
|
||||
swap
|
||||
[ "title" tag-named children>string >>title ]
|
||||
[ "link" tag-named "href" swap at >url >>url ]
|
||||
[ "link" tag-named "href" attr >url >>url ]
|
||||
[ "entry" tags-named [ atom1.0-entry ] map set-entries ]
|
||||
tri ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
USING: help.syntax help.markup strings byte-arrays ;
|
||||
USING: help.syntax help.markup strings byte-arrays math.order ;
|
||||
IN: unicode.collation
|
||||
|
||||
ARTICLE: "unicode.collation" "Collation and weak comparison"
|
||||
"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:"
|
||||
"The " { $vocab-link "unicode.collation" "unicode.collation" } " vocabulary implements the Unicode Collation Algorithm. The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. It is far preferred over code point order when sorting for human consumption, in user interfaces. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are useful for collation directly:"
|
||||
{ $subsection sort-strings }
|
||||
{ $subsection collation-key }
|
||||
{ $subsection string<=> }
|
||||
"Predicates for weak equality testing:"
|
||||
{ $subsection primary= }
|
||||
{ $subsection secondary= }
|
||||
{ $subsection tertiary= }
|
||||
|
|
@ -14,12 +15,12 @@ ARTICLE: "unicode.collation" "Collation and weak comparison"
|
|||
ABOUT: "unicode.collation"
|
||||
|
||||
HELP: sort-strings
|
||||
{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } }
|
||||
{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ;
|
||||
{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in lexicographical order" } }
|
||||
{ $description "This word takes a sequence of strings and sorts them according to the Unicode Collation Algorithm with the default collation order described in the DUCET. It uses code point order as a tie-breaker." } ;
|
||||
|
||||
HELP: collation-key
|
||||
{ $values { "string" string } { "key" byte-array } }
|
||||
{ $description "This takes a string and gives a representation of the collation key, which can be compared with <=>" } ;
|
||||
{ $description "This takes a string and gives a representation of the collation key, which can be compared with " { $link <=> } ". The representation is according to the DUCET." } ;
|
||||
|
||||
HELP: string<=>
|
||||
{ $values { "str1" string } { "str2" string } { "<=>" "one of +lt+, +gt+ or +eq+" } }
|
||||
|
|
@ -27,16 +28,16 @@ HELP: string<=>
|
|||
|
||||
HELP: primary=
|
||||
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
|
||||
{ $description "This checks whether the first level of collation is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation and accent marks." } ;
|
||||
{ $description "This checks whether the first level of collation key is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation, whitespace and accent marks." } ;
|
||||
|
||||
HELP: secondary=
|
||||
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
|
||||
{ $description "This checks whether the first two levels of collation are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to primary=." } ;
|
||||
{ $description "This checks whether the first two levels of collation key are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to " { $link primary= } "." } ;
|
||||
|
||||
HELP: tertiary=
|
||||
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
|
||||
{ $description "Along the same lines as secondary=, but case is significant." } ;
|
||||
{ $description "This checks if the first three levels of collation key are equal. For Latin-based scripts, it can be understood as testing for what " { $link secondary= } " tests for, but case is significant." } ;
|
||||
|
||||
HELP: quaternary=
|
||||
{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
|
||||
{ $description "This is similar to tertiary= but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ;
|
||||
{ $description "This checks if the first four levels of collation key are equal. This is similar to " { $link tertiary= } " but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ;
|
||||
|
|
|
|||
|
|
@ -150,9 +150,11 @@ TUPLE: tag
|
|||
[ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
|
||||
tag boa ;
|
||||
|
||||
! For convenience, tags follow the assoc protocol too (for attrs)
|
||||
CONSULT: assoc-protocol tag attrs>> ;
|
||||
INSTANCE: tag assoc
|
||||
: attr ( tag/xml name -- string )
|
||||
swap attrs>> at ;
|
||||
|
||||
: set-attr ( tag/xml value name -- )
|
||||
rot attrs>> set-at ;
|
||||
|
||||
! They also follow the sequence protocol (for children)
|
||||
CONSULT: sequence-protocol tag children>> ;
|
||||
|
|
@ -186,9 +188,6 @@ C: <xml> xml
|
|||
CONSULT: sequence-protocol xml body>> ;
|
||||
INSTANCE: xml sequence
|
||||
|
||||
CONSULT: assoc-protocol xml body>> ;
|
||||
INSTANCE: xml assoc
|
||||
|
||||
CONSULT: tag xml body>> ;
|
||||
|
||||
CONSULT: name xml body>> ;
|
||||
|
|
@ -217,8 +216,14 @@ M: xml like
|
|||
PREDICATE: contained-tag < tag children>> not ;
|
||||
PREDICATE: open-tag < tag children>> ;
|
||||
|
||||
UNION: xml-data
|
||||
tag comment string directive instruction ;
|
||||
|
||||
TUPLE: unescaped string ;
|
||||
C: <unescaped> unescaped
|
||||
|
||||
UNION: xml-data
|
||||
tag comment string directive instruction unescaped ;
|
||||
|
||||
TUPLE: xml-chunk seq ;
|
||||
C: <xml-chunk> xml-chunk
|
||||
|
||||
CONSULT: sequence-protocol xml-chunk seq>> ;
|
||||
INSTANCE: xml-chunk sequence
|
||||
|
|
|
|||
|
|
@ -65,11 +65,12 @@ IN: xml.elements
|
|||
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
|
||||
|
||||
: prolog-version ( alist -- version )
|
||||
T{ name f "" "version" f } swap at
|
||||
T{ name { space "" } { main "version" } } swap at
|
||||
[ good-version ] [ versionless-prolog ] if* ;
|
||||
|
||||
: prolog-encoding ( alist -- encoding )
|
||||
T{ name f "" "encoding" f } swap at "UTF-8" or ;
|
||||
T{ name { space "" } { main "encoding" } } swap at
|
||||
"UTF-8" or ;
|
||||
|
||||
: yes/no>bool ( string -- t/f )
|
||||
{
|
||||
|
|
@ -79,7 +80,7 @@ IN: xml.elements
|
|||
} case ;
|
||||
|
||||
: prolog-standalone ( alist -- version )
|
||||
T{ name f "" "standalone" f } swap at
|
||||
T{ name { space "" } { main "standalone" } } swap at
|
||||
[ yes/no>bool ] [ f ] if* ;
|
||||
|
||||
: prolog-attrs ( alist -- prolog )
|
||||
|
|
|
|||
|
|
@ -2,14 +2,14 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test xml.interpolate multiline kernel assocs
|
||||
sequences accessors xml.writer xml.interpolate.private
|
||||
locals splitting urls ;
|
||||
locals splitting urls xml.data classes ;
|
||||
IN: xml.interpolate.tests
|
||||
|
||||
[ "a" "c" { "a" "c" f } ] [
|
||||
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
|
||||
string>doc
|
||||
[ second var>> ]
|
||||
[ fourth "val" swap at var>> ]
|
||||
[ fourth "val" attr var>> ]
|
||||
[ extract-variables ] tri
|
||||
] unit-test
|
||||
|
||||
|
|
@ -54,6 +54,15 @@ IN: xml.interpolate.tests
|
|||
[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml-chunk>string ] unit-test
|
||||
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml-chunk>string ] unit-test
|
||||
|
||||
\ parse-def must-infer
|
||||
[ "" interpolate-chunk ] must-infer
|
||||
\ <XML must-infer
|
||||
[ { } "" interpolate-xml ] must-infer
|
||||
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
|
||||
|
||||
[ xml-chunk ] [ [ [XML <foo/> XML] ] first class ] unit-test
|
||||
[ xml ] [ [ <XML <foo/> XML> ] first class ] unit-test
|
||||
[ xml-chunk ] [ [ [XML <foo val=<->/> XML] ] third class ] unit-test
|
||||
[ xml ] [ [ <XML <foo val=<->/> XML> ] third class ] unit-test
|
||||
[ 1 ] [ [ [XML <foo/> XML] ] length ] unit-test
|
||||
[ 1 ] [ [ <XML <foo/> XML> ] length ] unit-test
|
||||
|
||||
[ "" ] [ [XML XML] concat ] unit-test
|
||||
|
|
|
|||
|
|
@ -33,8 +33,9 @@ M: string push-item , ;
|
|||
M: xml-data push-item , ;
|
||||
M: object push-item present , ;
|
||||
M: sequence push-item
|
||||
[ dup array? [ % ] [ , ] if ] each ;
|
||||
dup xml-data? [ , ] [ [ push-item ] each ] if ;
|
||||
M: number push-item present , ;
|
||||
M: xml-chunk push-item % ;
|
||||
|
||||
GENERIC: interpolate-item ( table item -- )
|
||||
M: object interpolate-item nip , ;
|
||||
|
|
@ -63,14 +64,18 @@ M: interpolated interpolate-item
|
|||
|
||||
: number<-> ( doc -- dup )
|
||||
0 over [
|
||||
dup var>> [ over >>var [ 1+ ] dip ] unless drop
|
||||
dup var>> [
|
||||
over >>var [ 1+ ] dip
|
||||
] unless drop
|
||||
] each-interpolated drop ;
|
||||
|
||||
MACRO: interpolate-xml ( string -- doc )
|
||||
string>doc number<-> '[ _ interpolate-xml-doc ] ;
|
||||
GENERIC: interpolate-xml ( table xml -- xml )
|
||||
|
||||
MACRO: interpolate-chunk ( string -- chunk )
|
||||
string>chunk number<-> '[ _ interpolate-sequence ] ;
|
||||
M: xml interpolate-xml
|
||||
interpolate-xml-doc ;
|
||||
|
||||
M: xml-chunk interpolate-xml
|
||||
interpolate-sequence <xml-chunk> ;
|
||||
|
||||
: >search-hash ( seq -- hash )
|
||||
[ dup search ] H{ } map>assoc ;
|
||||
|
|
@ -81,26 +86,24 @@ MACRO: interpolate-chunk ( string -- chunk )
|
|||
: nenum ( ... n -- assoc )
|
||||
narray <enum> ; inline
|
||||
|
||||
: collect ( accum seq -- accum )
|
||||
: collect ( accum variables -- accum ? )
|
||||
{
|
||||
{ [ dup [ ] all? ] [ >search-hash parsed ] } ! locals
|
||||
{ [ dup [ not ] all? ] [ ! fry
|
||||
length parsed \ nenum parsed
|
||||
] }
|
||||
{ [ dup empty? ] [ drop f ] } ! Just a literal
|
||||
{ [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
|
||||
{ [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
|
||||
[ drop "XML interpolation contains both fry and locals" throw ] ! mixed
|
||||
} cond ;
|
||||
|
||||
: parse-def ( accum delimiter word -- accum )
|
||||
[
|
||||
parse-multiline-string but-last
|
||||
[ string>chunk extract-variables collect ] keep
|
||||
parsed
|
||||
] dip parsed ;
|
||||
: parse-def ( accum delimiter quot -- accum )
|
||||
[ parse-multiline-string 1 short head* ] dip call
|
||||
[ extract-variables collect ] keep swap
|
||||
[ number<-> parsed ] dip
|
||||
[ \ interpolate-xml parsed ] when ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <XML
|
||||
"XML>" \ interpolate-xml parse-def ; parsing
|
||||
"XML>" [ string>doc ] parse-def ; parsing
|
||||
|
||||
: [XML
|
||||
"XML]" \ interpolate-chunk parse-def ; parsing
|
||||
"XML]" [ string>chunk ] parse-def ; parsing
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ SYMBOL: xml-file
|
|||
[ "a" ] [ xml-file get space>> ] unit-test
|
||||
[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
|
||||
[ "that" ] [
|
||||
xml-file get T{ name f "" "this" "http://d.de" } swap at
|
||||
xml-file get T{ name f "" "this" "http://d.de" } attr
|
||||
] unit-test
|
||||
[ t ] [ xml-file get children>> second contained-tag? ] unit-test
|
||||
[ "<a></b>" string>xml ] [ xml-error? ] must-fail-with
|
||||
|
|
@ -30,7 +30,7 @@ SYMBOL: xml-file
|
|||
xml-file get after>> [ instruction? ] find nip text>>
|
||||
] unit-test
|
||||
[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
|
||||
[ "that" ] [ xml-file get "this" swap at ] unit-test
|
||||
[ "that" ] [ xml-file get "this" attr ] unit-test
|
||||
[ "abcd" ] [
|
||||
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
|
||||
[ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make
|
||||
|
|
@ -43,9 +43,11 @@ SYMBOL: xml-file
|
|||
"<a><b id='c'>foo</b><d id='e'/></a>" string>xml
|
||||
"c" get-id children>string
|
||||
] unit-test
|
||||
[ "foo" ] [ "<x y='foo'/>" string>xml "y" over
|
||||
at swap "z" [ tuck ] dip swap set-at
|
||||
T{ name f "blah" "z" f } swap at ] unit-test
|
||||
[ "foo" ] [
|
||||
"<x y='foo'/>" string>xml
|
||||
dup dup "y" attr "z" set-attr
|
||||
T{ name { space "blah" } { main "z" } } attr
|
||||
] unit-test
|
||||
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
|
||||
[ "<!-- B+, B, or B--->" string>xml ] must-fail
|
||||
[ ] [ "<?xml version='1.0'?><!-- declarations for <head> & <body> --><foo/>" string>xml drop ] unit-test
|
||||
|
|
@ -58,5 +60,6 @@ SYMBOL: xml-file
|
|||
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first ] unit-test
|
||||
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk first ] unit-test
|
||||
[ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test
|
||||
[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test
|
||||
[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test
|
||||
[ "foo" ] [ "<!DOCTYPE foo [<!ENTITY bar 'foo'>]><x>&bar;</x>" string>xml children>string ] unit-test
|
||||
[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,16 +1,16 @@
|
|||
USING: accessors assocs combinators continuations fry generalizations
|
||||
io.pathnames kernel macros sequences stack-checker tools.test xml
|
||||
xml.utilities xml.writer arrays ;
|
||||
xml.utilities xml.writer arrays xml.data ;
|
||||
IN: xml.tests.suite
|
||||
|
||||
TUPLE: xml-test id uri sections description type ;
|
||||
|
||||
: >xml-test ( tag -- test )
|
||||
xml-test new swap {
|
||||
[ "TYPE" swap at >>type ]
|
||||
[ "ID" swap at >>id ]
|
||||
[ "URI" swap at >>uri ]
|
||||
[ "SECTIONS" swap at >>sections ]
|
||||
[ "TYPE" attr >>type ]
|
||||
[ "ID" attr >>id ]
|
||||
[ "URI" attr >>uri ]
|
||||
[ "SECTIONS" attr >>sections ]
|
||||
[ children>> xml-chunk>string >>description ]
|
||||
} cleave ;
|
||||
|
||||
|
|
@ -51,3 +51,5 @@ MACRO: drop-input ( quot -- newquot )
|
|||
|
||||
: failing-valids ( -- tests )
|
||||
partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ;
|
||||
|
||||
[ ] [ partition-xml-tests 2drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -52,7 +52,6 @@ IN: xml.writer.tests
|
|||
<x>&foo;</x>"} pprint-reprints-as
|
||||
|
||||
[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk xml-chunk>string = ] unit-test
|
||||
[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test
|
||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
|
||||
[ "<a b='c'/>" string>xml xml>string ] unit-test
|
||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
|
||||
|
|
|
|||
|
|
@ -162,7 +162,8 @@ PRIVATE>
|
|||
|
||||
: read-xml-chunk ( stream -- seq )
|
||||
1 depth
|
||||
[ (read-xml-chunk) nip ] with-variable ;
|
||||
[ (read-xml-chunk) nip ] with-variable
|
||||
<xml-chunk> ;
|
||||
|
||||
: string>xml ( string -- xml )
|
||||
t string-input?
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: xmode.loader xmode.utilities xmode.rules namespaces
|
||||
strings splitting assocs sequences kernel io.files xml memoize
|
||||
words globs combinators io.encodings.utf8 sorting accessors ;
|
||||
words globs combinators io.encodings.utf8 sorting accessors xml.data ;
|
||||
IN: xmode.catalog
|
||||
|
||||
TUPLE: mode file file-name-glob first-line-glob ;
|
||||
|
|
@ -8,7 +8,7 @@ TUPLE: mode file file-name-glob first-line-glob ;
|
|||
<TAGS: parse-mode-tag ( modes tag -- )
|
||||
|
||||
TAG: MODE
|
||||
"NAME" over at [
|
||||
dup "NAME" attr [
|
||||
mode new {
|
||||
{ "FILE" f (>>file) }
|
||||
{ "FILE_NAME_GLOB" f (>>file-name-glob) }
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
IN: xmode.code2html.tests
|
||||
USING: xmode.code2html xmode.catalog
|
||||
tools.test multiline splitting memoize
|
||||
kernel ;
|
||||
|
||||
[ ] [ \ (load-mode) reset-memoized ] unit-test
|
||||
|
||||
[ ] [
|
||||
<" <style type="text/css" media="screen" >
|
||||
* {margin:0; padding:0; border:0;} ">
|
||||
string-lines "html" htmlize-lines drop
|
||||
] unit-test
|
||||
|
|
@ -13,10 +13,10 @@ TAG: PROPS
|
|||
parse-props-tag >>props drop ;
|
||||
|
||||
TAG: IMPORT
|
||||
"DELEGATE" swap at swap import-rule-set ;
|
||||
"DELEGATE" attr swap import-rule-set ;
|
||||
|
||||
TAG: TERMINATE
|
||||
"AT_CHAR" swap at string>number >>terminate-char drop ;
|
||||
"AT_CHAR" attr string>number >>terminate-char drop ;
|
||||
|
||||
RULE: SEQ seq-rule
|
||||
shared-tag-attrs delegate-attr literal-start ;
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ IN: xmode.utilities
|
|||
] }
|
||||
{ [ dup length 3 = ] [
|
||||
first3 '[
|
||||
_ tag get at
|
||||
tag get _ attr
|
||||
_ [ execute ] when* object get _ execute
|
||||
]
|
||||
] }
|
||||
|
|
|
|||
|
|
@ -79,16 +79,16 @@ M: tuple-class slots>tuple
|
|||
|
||||
ERROR: bad-superclass class ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tuple= ( tuple1 tuple2 -- ? )
|
||||
2dup [ layout-of ] bi@ eq? [
|
||||
[ drop tuple-size ]
|
||||
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
|
||||
2bi all-integers?
|
||||
] [
|
||||
2drop f
|
||||
] if ; inline
|
||||
2dup [ tuple? ] both? [
|
||||
2dup [ layout-of ] bi@ eq? [
|
||||
[ drop tuple-size ]
|
||||
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
|
||||
2bi all-integers?
|
||||
] [ 2drop f ] if
|
||||
] [ 2drop f ] if ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tuple-predicate-quot/1 ( class -- quot )
|
||||
#! Fast path for tuples with no superclass
|
||||
|
|
@ -328,7 +328,9 @@ M: tuple clone (clone) ;
|
|||
|
||||
M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
|
||||
|
||||
M: tuple hashcode*
|
||||
GENERIC: tuple-hashcode ( n tuple -- x )
|
||||
|
||||
M: tuple tuple-hashcode
|
||||
[
|
||||
[ class hashcode ] [ tuple-size ] [ ] tri
|
||||
[ rot ] dip [
|
||||
|
|
@ -336,6 +338,8 @@ M: tuple hashcode*
|
|||
] 2curry each
|
||||
] recursive-hashcode ;
|
||||
|
||||
M: tuple hashcode* tuple-hashcode ;
|
||||
|
||||
M: tuple-class new
|
||||
dup "prototype" word-prop
|
||||
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io strings arrays io.backend
|
||||
io.files.private quotations ;
|
||||
io.files.private quotations sequences ;
|
||||
IN: io.files
|
||||
|
||||
ARTICLE: "io.files" "Reading and writing files"
|
||||
|
|
@ -22,16 +22,19 @@ ABOUT: "io.files"
|
|||
HELP: <file-reader>
|
||||
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an input stream" } }
|
||||
{ $description "Outputs an input stream for reading from the specified pathname using the given encoding." }
|
||||
{ $notes "Most code should use " { $link with-file-reader } " instead, to ensure the stream is properly disposed of after." }
|
||||
{ $errors "Throws an error if the file is unreadable." } ;
|
||||
|
||||
HELP: <file-writer>
|
||||
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } }
|
||||
{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The file's length is truncated to zero." }
|
||||
{ $notes "Most code should use " { $link with-file-writer } " instead, to ensure the stream is properly disposed of after." }
|
||||
{ $errors "Throws an error if the file cannot be opened for writing." } ;
|
||||
|
||||
HELP: <file-appender>
|
||||
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an output stream" } }
|
||||
{ $description "Outputs an output stream for writing to the specified pathname using the given encoding. The stream begins writing at the end of the file." }
|
||||
{ $notes "Most code should use " { $link with-file-appender } " instead, to ensure the stream is properly disposed of after." }
|
||||
{ $errors "Throws an error if the file cannot be opened for writing." } ;
|
||||
|
||||
HELP: with-file-reader
|
||||
|
|
@ -60,13 +63,13 @@ HELP: file-lines
|
|||
{ $errors "Throws an error if the file cannot be opened for reading." } ;
|
||||
|
||||
HELP: set-file-contents
|
||||
{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
|
||||
{ $description "Sets the contents of a file to a string with the given encoding." }
|
||||
{ $values { "seq" sequence } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
|
||||
{ $description "Sets the contents of a file to a sequence with the given encoding." }
|
||||
{ $errors "Throws an error if the file cannot be opened for writing." } ;
|
||||
|
||||
HELP: file-contents
|
||||
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } }
|
||||
{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." }
|
||||
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" sequence } }
|
||||
{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a sequence." }
|
||||
{ $errors "Throws an error if the file cannot be opened for reading." } ;
|
||||
|
||||
{ set-file-lines file-lines set-file-contents file-contents } related-words
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
USING: tools.test io.files io.files.private io.files.temp
|
||||
io.directories io.encodings.8-bit arrays make system
|
||||
io.encodings.binary io
|
||||
threads kernel continuations io.encodings.ascii sequences
|
||||
strings accessors io.encodings.utf8 math destructors namespaces
|
||||
;
|
||||
io.encodings.binary io threads kernel continuations
|
||||
io.encodings.ascii sequences strings accessors
|
||||
io.encodings.utf8 math destructors namespaces ;
|
||||
IN: io.files.tests
|
||||
|
||||
\ exists? must-infer
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
|
|||
: with-file-reader ( path encoding quot -- )
|
||||
[ <file-reader> ] dip with-input-stream ; inline
|
||||
|
||||
: file-contents ( path encoding -- str )
|
||||
: file-contents ( path encoding -- seq )
|
||||
<file-reader> contents ;
|
||||
|
||||
: with-file-writer ( path encoding quot -- )
|
||||
|
|
@ -34,7 +34,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
|
|||
: set-file-lines ( seq path encoding -- )
|
||||
[ [ print ] each ] with-file-writer ;
|
||||
|
||||
: set-file-contents ( str path encoding -- )
|
||||
: set-file-contents ( seq path encoding -- )
|
||||
[ write ] with-file-writer ;
|
||||
|
||||
: with-file-appender ( path encoding quot -- )
|
||||
|
|
@ -58,4 +58,4 @@ PRIVATE>
|
|||
13 getenv cwd prepend-path \ image set-global
|
||||
14 getenv cwd prepend-path \ vm set-global
|
||||
image parent-directory "resource-path" set-global
|
||||
] "io.files" add-init-hook
|
||||
] "io.files" add-init-hook
|
||||
|
|
|
|||
|
|
@ -14,6 +14,10 @@ $nl
|
|||
"Quotations implement the " { $link "sequence-protocol" } ", and existing sequences can be converted into quotations:"
|
||||
{ $subsection >quotation }
|
||||
{ $subsection 1quotation }
|
||||
"Wrappers:"
|
||||
{ $subsection "wrappers" } ;
|
||||
|
||||
ARTICLE: "wrappers" "Wrappers"
|
||||
"Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:"
|
||||
{ $subsection wrapper }
|
||||
{ $subsection literalize }
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ IN: bootstrap.syntax
|
|||
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
|
||||
|
||||
"POSTPONE:" [ scan-word parsed ] define-syntax
|
||||
"\\" [ scan-word literalize parsed ] define-syntax
|
||||
"\\" [ scan-word <wrapper> parsed ] define-syntax
|
||||
"inline" [ word make-inline ] define-syntax
|
||||
"recursive" [ word make-recursive ] define-syntax
|
||||
"foldable" [ word make-foldable ] define-syntax
|
||||
|
|
|
|||
Loading…
Reference in New Issue