Merge branch 'master' of git://factorcode.org/git/factor
commit
b8fe50a75e
|
@ -37,9 +37,9 @@ DEFER: (tail-call?)
|
||||||
: tail-call? ( -- ? )
|
: tail-call? ( -- ? )
|
||||||
node-stack get [
|
node-stack get [
|
||||||
rest-slice
|
rest-slice
|
||||||
dup [
|
dup empty? [ drop t ] [
|
||||||
[ (tail-call?) ]
|
[ (tail-call?) ]
|
||||||
[ first #terminate? not ]
|
[ first #terminate? not ]
|
||||||
bi and
|
bi and
|
||||||
] [ drop t ] if
|
] if
|
||||||
] all? ;
|
] all? ;
|
||||||
|
|
|
@ -450,3 +450,14 @@ cell 8 = [
|
||||||
[ 8 ] [
|
[ 8 ] [
|
||||||
1 [ 3 fixnum-shift-fast ] compile-call
|
1 [ 3 fixnum-shift-fast ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
|
||||||
|
|
||||||
|
[ B{ 0 1 } ] [
|
||||||
|
B{ 0 0 } 1 alien-accessor-regression boa
|
||||||
|
dup [
|
||||||
|
{ alien-accessor-regression } declare
|
||||||
|
[ i>> ] [ b>> ] bi over set-alien-unsigned-1
|
||||||
|
] compile-call
|
||||||
|
b>>
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -3,7 +3,7 @@ stack-checker kernel kernel.private math prettyprint sequences
|
||||||
sbufs strings tools.test vectors words sequences.private
|
sbufs strings tools.test vectors words sequences.private
|
||||||
quotations classes classes.algebra classes.tuple.private
|
quotations classes classes.algebra classes.tuple.private
|
||||||
continuations growable namespaces hints alien.accessors
|
continuations growable namespaces hints alien.accessors
|
||||||
compiler.tree.builder compiler.tree.optimizer ;
|
compiler.tree.builder compiler.tree.optimizer sequences.deep ;
|
||||||
IN: optimizer.tests
|
IN: optimizer.tests
|
||||||
|
|
||||||
GENERIC: xyz ( obj -- obj )
|
GENERIC: xyz ( obj -- obj )
|
||||||
|
@ -353,3 +353,12 @@ TUPLE: some-tuple x ;
|
||||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
|
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
|
||||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
|
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
|
||||||
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
|
[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
|
||||||
|
|
||||||
|
: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
|
||||||
|
|
||||||
|
[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
|
||||||
|
[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
|
||||||
|
|
||||||
|
[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
|
||||||
|
|
||||||
|
[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
|
||||||
|
|
|
@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
|
||||||
|
|
||||||
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
|
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
|
||||||
|
|
||||||
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" print f ;" eval ] unit-test
|
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
|
||||||
|
|
||||||
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
|
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors sequences sequences.deep combinators fry
|
USING: kernel accessors sequences sequences.deep combinators fry
|
||||||
classes.algebra namespaces assocs math math.private
|
classes.algebra namespaces assocs words math math.private
|
||||||
math.partial-dispatch classes.tuple classes.tuple.private
|
math.partial-dispatch math.intervals classes classes.tuple
|
||||||
definitions stack-checker.state stack-checker.branches
|
classes.tuple.private layouts definitions stack-checker.state
|
||||||
compiler.tree
|
stack-checker.branches compiler.tree
|
||||||
compiler.tree.intrinsics
|
compiler.tree.intrinsics
|
||||||
compiler.tree.combinators
|
compiler.tree.combinators
|
||||||
compiler.tree.propagation.info
|
compiler.tree.propagation.info
|
||||||
|
@ -64,9 +64,19 @@ GENERIC: cleanup* ( node -- node/nodes )
|
||||||
{ fixnum-shift fixnum-shift-fast }
|
{ fixnum-shift fixnum-shift-fast }
|
||||||
} at ;
|
} at ;
|
||||||
|
|
||||||
|
: (remove-overflow-check?) ( #call -- ? )
|
||||||
|
node-output-infos first class>> fixnum class<= ;
|
||||||
|
|
||||||
|
: small-shift? ( #call -- ? )
|
||||||
|
node-input-infos second interval>>
|
||||||
|
cell-bits tag-bits get - [ neg ] keep [a,b] interval-subset? ;
|
||||||
|
|
||||||
: remove-overflow-check? ( #call -- ? )
|
: remove-overflow-check? ( #call -- ? )
|
||||||
dup word>> no-overflow-variant
|
{
|
||||||
[ node-output-infos first class>> fixnum class<= ] [ drop f ] if ;
|
{ [ dup word>> \ fixnum-shift eq? ] [ [ (remove-overflow-check?) ] [ small-shift? ] bi and ] }
|
||||||
|
{ [ dup word>> no-overflow-variant ] [ (remove-overflow-check?) ] }
|
||||||
|
[ drop f ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: remove-overflow-check ( #call -- #call )
|
: remove-overflow-check ( #call -- #call )
|
||||||
[ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
|
[ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
|
||||||
|
@ -92,8 +102,11 @@ M: #declare cleanup* drop f ;
|
||||||
: fold-only-branch ( #branch -- node/nodes )
|
: fold-only-branch ( #branch -- node/nodes )
|
||||||
#! If only one branch is live we don't need to branch at
|
#! If only one branch is live we don't need to branch at
|
||||||
#! all; just drop the condition value.
|
#! all; just drop the condition value.
|
||||||
dup live-children sift dup length 1 =
|
dup live-children sift dup length {
|
||||||
[ first swap in-d>> #drop prefix ] [ drop ] if ;
|
{ 0 [ 2drop f ] }
|
||||||
|
{ 1 [ first swap in-d>> #drop prefix ] }
|
||||||
|
[ 2drop ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
SYMBOL: live-branches
|
SYMBOL: live-branches
|
||||||
|
|
||||||
|
@ -108,15 +121,18 @@ M: #branch cleanup*
|
||||||
[ live-branches>> live-branches set ]
|
[ live-branches>> live-branches set ]
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
|
: output-fs ( values -- nodes )
|
||||||
|
[ f swap #push ] map ;
|
||||||
|
|
||||||
: eliminate-single-phi ( #phi -- node )
|
: eliminate-single-phi ( #phi -- node )
|
||||||
[ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
|
[ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
|
||||||
[ [ drop ] [ [ f swap #push ] map ] bi* ]
|
[ [ drop ] [ output-fs ] bi* ]
|
||||||
[ #copy ]
|
[ #copy ]
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
: eliminate-phi ( #phi -- node )
|
: eliminate-phi ( #phi -- node )
|
||||||
live-branches get sift length {
|
live-branches get sift length {
|
||||||
{ 0 [ drop f ] }
|
{ 0 [ out-d>> output-fs ] }
|
||||||
{ 1 [ eliminate-single-phi ] }
|
{ 1 [ eliminate-single-phi ] }
|
||||||
[ drop ]
|
[ drop ]
|
||||||
} case ;
|
} case ;
|
||||||
|
|
|
@ -120,7 +120,7 @@ IN: compiler.tree.dead-code.tests
|
||||||
: call-recursive-dce-1 ( a -- b )
|
: call-recursive-dce-1 ( a -- b )
|
||||||
[ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
|
[ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
|
||||||
|
|
||||||
[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
|
[ [ drop "WRAP" [ "REC" drop "REC" ] label ] ] [
|
||||||
[ call-recursive-dce-1 ] optimize-quot squish
|
[ call-recursive-dce-1 ] optimize-quot squish
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -134,7 +134,7 @@ IN: compiler.tree.dead-code.tests
|
||||||
[ f call-recursive-dce-2 drop ] optimize-quot squish
|
[ f call-recursive-dce-2 drop ] optimize-quot squish
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
|
[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
|
||||||
[ f call-recursive-dce-2 ] optimize-quot squish
|
[ f call-recursive-dce-2 ] optimize-quot squish
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -152,7 +152,7 @@ IN: compiler.tree.dead-code.tests
|
||||||
: call-recursive-dce-4 ( a -- b )
|
: call-recursive-dce-4 ( a -- b )
|
||||||
call-recursive-dce-4 ; inline recursive
|
call-recursive-dce-4 ; inline recursive
|
||||||
|
|
||||||
[ [ "WRAP" [ "REC" ] label ] ] [
|
[ [ drop "WRAP" [ "REC" ] label ] ] [
|
||||||
[ call-recursive-dce-4 ] optimize-quot squish
|
[ call-recursive-dce-4 ] optimize-quot squish
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -182,3 +182,8 @@ IN: compiler.tree.dead-code.tests
|
||||||
[ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
|
[ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
|
||||||
|
|
||||||
[ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
|
[ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
|
||||||
|
|
||||||
|
: call-recursive-dce-7 ( obj -- elt ? )
|
||||||
|
dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
|
||||||
|
|
||||||
|
[ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test
|
||||||
|
|
|
@ -13,11 +13,8 @@ M: #enter-recursive compute-live-values*
|
||||||
#! corresponding inputs to the #call-recursive are live also.
|
#! corresponding inputs to the #call-recursive are live also.
|
||||||
[ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
|
[ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
|
||||||
|
|
||||||
: return-recursive-phi-in ( #return-recursive -- phi-in )
|
|
||||||
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
|
|
||||||
|
|
||||||
M: #return-recursive compute-live-values*
|
M: #return-recursive compute-live-values*
|
||||||
[ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
|
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
|
||||||
|
|
||||||
M: #call-recursive compute-live-values*
|
M: #call-recursive compute-live-values*
|
||||||
#! If the output of a #call-recursive is live, then the
|
#! If the output of a #call-recursive is live, then the
|
||||||
|
@ -34,15 +31,6 @@ M: #call-recursive compute-live-values*
|
||||||
drop-values
|
drop-values
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
M: #recursive remove-dead-code* ( node -- nodes )
|
|
||||||
dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
|
|
||||||
{
|
|
||||||
[ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ]
|
|
||||||
[ drop [ (remove-dead-code) ] change-child drop ]
|
|
||||||
[ drop label>> [ filter-live ] change-enter-out drop ]
|
|
||||||
[ swap 2array ]
|
|
||||||
} 2cleave ;
|
|
||||||
|
|
||||||
M: #enter-recursive remove-dead-code*
|
M: #enter-recursive remove-dead-code*
|
||||||
[ filter-live ] change-out-d ;
|
[ filter-live ] change-out-d ;
|
||||||
|
|
||||||
|
@ -73,9 +61,30 @@ M: #call-recursive remove-dead-code*
|
||||||
[ drop-call-recursive-outputs ]
|
[ drop-call-recursive-outputs ]
|
||||||
tri 3array ;
|
tri 3array ;
|
||||||
|
|
||||||
M: #return-recursive remove-dead-code* ( node -- nodes )
|
:: drop-recursive-inputs ( node -- shuffle )
|
||||||
dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs
|
[let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
|
||||||
[ drop [ filter-live ] change-out-d drop ]
|
new-outputs [ shuffle out-d>> ] |
|
||||||
[ out-d>> >>in-d drop ]
|
node new-outputs
|
||||||
[ swap 2array ]
|
[ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
|
||||||
2tri ;
|
shuffle
|
||||||
|
] ;
|
||||||
|
|
||||||
|
:: drop-recursive-outputs ( node -- shuffle )
|
||||||
|
[let* | return [ node label>> return>> ]
|
||||||
|
new-inputs [ return in-d>> filter-live ]
|
||||||
|
new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
|
||||||
|
return
|
||||||
|
[ new-inputs >>in-d new-outputs >>out-d drop ]
|
||||||
|
[ drop-dead-outputs ]
|
||||||
|
bi
|
||||||
|
] ;
|
||||||
|
|
||||||
|
M:: #recursive remove-dead-code* ( node -- nodes )
|
||||||
|
[let* | drop-inputs [ node drop-recursive-inputs ]
|
||||||
|
drop-outputs [ node drop-recursive-outputs ] |
|
||||||
|
node [ (remove-dead-code) ] change-child drop
|
||||||
|
node label>> [ filter-live ] change-enter-out drop
|
||||||
|
drop-inputs node drop-outputs 3array
|
||||||
|
] ;
|
||||||
|
|
||||||
|
M: #return-recursive remove-dead-code* ;
|
||||||
|
|
|
@ -1,7 +1,9 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors words assocs sequences arrays namespaces
|
USING: kernel accessors words assocs sequences arrays namespaces
|
||||||
fry locals classes.algebra stack-checker.backend
|
fry locals definitions classes.algebra
|
||||||
|
stack-checker.state
|
||||||
|
stack-checker.backend
|
||||||
compiler.tree
|
compiler.tree
|
||||||
compiler.tree.propagation.info
|
compiler.tree.propagation.info
|
||||||
compiler.tree.dead-code.liveness ;
|
compiler.tree.dead-code.liveness ;
|
||||||
|
@ -80,11 +82,10 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
|
||||||
] ;
|
] ;
|
||||||
|
|
||||||
: drop-dead-outputs ( node -- nodes )
|
: drop-dead-outputs ( node -- nodes )
|
||||||
dup out-d>> drop-dead-values
|
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
|
||||||
[ in-d>> >>out-d drop ] [ 2array ] 2bi ;
|
|
||||||
|
|
||||||
M: #introduce remove-dead-code* ( #introduce -- nodes )
|
M: #introduce remove-dead-code* ( #introduce -- nodes )
|
||||||
drop-dead-outputs ;
|
dup drop-dead-outputs 2array ;
|
||||||
|
|
||||||
M: #>r remove-dead-code*
|
M: #>r remove-dead-code*
|
||||||
[ filter-live ] change-out-r
|
[ filter-live ] change-out-r
|
||||||
|
@ -105,7 +106,9 @@ M: #push remove-dead-code*
|
||||||
] [ drop f ] if ;
|
] [ drop f ] if ;
|
||||||
|
|
||||||
: remove-flushable-call ( #call -- node )
|
: remove-flushable-call ( #call -- node )
|
||||||
in-d>> #drop remove-dead-code* ;
|
[ word>> +inlined+ depends-on ]
|
||||||
|
[ in-d>> #drop remove-dead-code* ]
|
||||||
|
bi ;
|
||||||
|
|
||||||
: some-outputs-dead? ( #call -- ? )
|
: some-outputs-dead? ( #call -- ? )
|
||||||
out-d>> [ live-value? not ] contains? ;
|
out-d>> [ live-value? not ] contains? ;
|
||||||
|
@ -115,7 +118,7 @@ M: #call remove-dead-code*
|
||||||
remove-flushable-call
|
remove-flushable-call
|
||||||
] [
|
] [
|
||||||
dup some-outputs-dead? [
|
dup some-outputs-dead? [
|
||||||
drop-dead-outputs
|
dup drop-dead-outputs 2array
|
||||||
] when
|
] when
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
|
@ -7,7 +7,7 @@ compiler.tree.combinators compiler.tree sequences math math.private
|
||||||
kernel tools.test accessors slots.private quotations.private
|
kernel tools.test accessors slots.private quotations.private
|
||||||
prettyprint classes.tuple.private classes classes.tuple
|
prettyprint classes.tuple.private classes classes.tuple
|
||||||
compiler.tree.intrinsics namespaces compiler.tree.propagation.info
|
compiler.tree.intrinsics namespaces compiler.tree.propagation.info
|
||||||
stack-checker.errors ;
|
stack-checker.errors kernel.private ;
|
||||||
|
|
||||||
\ escape-analysis must-infer
|
\ escape-analysis must-infer
|
||||||
|
|
||||||
|
@ -316,3 +316,7 @@ C: <ro-box> ro-box
|
||||||
[ \ too-many->r boa f f \ inference-error boa ]
|
[ \ too-many->r boa f f \ inference-error boa ]
|
||||||
count-unboxed-allocations
|
count-unboxed-allocations
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ 0 ] [
|
||||||
|
[ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -125,21 +125,20 @@ SYMBOL: history
|
||||||
: remember-inlining ( word -- )
|
: remember-inlining ( word -- )
|
||||||
history [ swap suffix ] change ;
|
history [ swap suffix ] change ;
|
||||||
|
|
||||||
: inline-word ( #call word -- )
|
: inline-word ( #call word -- ? )
|
||||||
dup history get memq? [
|
dup history get memq? [
|
||||||
2drop
|
2drop f
|
||||||
] [
|
] [
|
||||||
[
|
[
|
||||||
dup remember-inlining
|
dup remember-inlining
|
||||||
dupd def>> splicing-nodes >>body
|
dupd def>> splicing-nodes >>body
|
||||||
propagate-body
|
propagate-body
|
||||||
] with-scope
|
] with-scope
|
||||||
|
t
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: inline-method-body ( #call word -- ? )
|
: inline-method-body ( #call word -- ? )
|
||||||
2dup should-inline? [ inline-word t ] [ 2drop f ] if ;
|
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: always-inline-word? ( word -- ? )
|
: always-inline-word? ( word -- ? )
|
||||||
{ curry compose } memq? ;
|
{ curry compose } memq? ;
|
||||||
|
|
||||||
: always-inline-word ( #call word -- ? ) inline-word t ;
|
|
||||||
|
|
|
@ -571,6 +571,8 @@ MIXIN: empty-mixin
|
||||||
|
|
||||||
[ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
|
[ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
|
||||||
|
|
||||||
|
[ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
|
||||||
|
|
||||||
! [ V{ string } ] [
|
! [ V{ string } ] [
|
||||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||||
! ] unit-test
|
! ] unit-test
|
||||||
|
|
|
@ -93,7 +93,7 @@ M: #declare propagate-before
|
||||||
|
|
||||||
: do-inlining ( #call word -- ? )
|
: do-inlining ( #call word -- ? )
|
||||||
{
|
{
|
||||||
{ [ dup always-inline-word? ] [ always-inline-word ] }
|
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||||
{ [ dup math-partial? ] [ inline-math-partial ] }
|
{ [ dup math-partial? ] [ inline-math-partial ] }
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors alien.c-types arrays cpu.x86.assembler
|
USING: accessors alien.c-types arrays cpu.x86.assembler
|
||||||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
||||||
cpu.x86.allot cpu.architecture kernel kernel.private math
|
cpu.x86.allot cpu.architecture kernel kernel.private math
|
||||||
namespaces sequences compiler.generator.registers
|
namespaces sequences compiler.generator compiler.generator.registers
|
||||||
compiler.generator.fixup system layouts alien alien.accessors
|
compiler.generator.fixup system layouts alien alien.accessors
|
||||||
alien.structs slots splitting assocs ;
|
alien.structs slots splitting assocs ;
|
||||||
IN: cpu.x86.64
|
IN: cpu.x86.64
|
||||||
|
|
|
@ -404,10 +404,8 @@ IN: cpu.x86.intrinsics
|
||||||
|
|
||||||
: %alien-integer-set ( quot reg -- )
|
: %alien-integer-set ( quot reg -- )
|
||||||
small-reg PUSH
|
small-reg PUSH
|
||||||
"offset" get "value" get = [
|
|
||||||
"value" operand %untag-fixnum
|
|
||||||
] unless
|
|
||||||
small-reg "value" operand MOV
|
small-reg "value" operand MOV
|
||||||
|
small-reg %untag-fixnum
|
||||||
swap %alien-accessor
|
swap %alien-accessor
|
||||||
small-reg POP ; inline
|
small-reg POP ; inline
|
||||||
|
|
||||||
|
|
|
@ -87,7 +87,7 @@ M: threaded-server handle-client* handler>> call ;
|
||||||
[ [ accept-connection ] with-semaphore ]
|
[ [ accept-connection ] with-semaphore ]
|
||||||
[ accept-connection ]
|
[ accept-connection ]
|
||||||
if*
|
if*
|
||||||
] [ accept-loop ] bi ; inline
|
] [ accept-loop ] bi ; inline recursive
|
||||||
|
|
||||||
: started-accept-loop ( server -- )
|
: started-accept-loop ( server -- )
|
||||||
threaded-server get
|
threaded-server get
|
||||||
|
|
|
@ -67,8 +67,10 @@ SYMBOL: enter-out
|
||||||
[ entry-stack-height current-stack-height swap - ]
|
[ entry-stack-height current-stack-height swap - ]
|
||||||
bi*
|
bi*
|
||||||
= [ 2drop ] [
|
= [ 2drop ] [
|
||||||
word>> current-stack-height
|
terminated? get [ 2drop ] [
|
||||||
unbalanced-recursion-error inference-error
|
word>> current-stack-height
|
||||||
|
unbalanced-recursion-error inference-error
|
||||||
|
] if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: end-recursive-word ( word label -- )
|
: end-recursive-word ( word label -- )
|
||||||
|
@ -79,7 +81,7 @@ SYMBOL: enter-out
|
||||||
: recursive-word-inputs ( label -- n )
|
: recursive-word-inputs ( label -- n )
|
||||||
entry-stack-height d-in get + ;
|
entry-stack-height d-in get + ;
|
||||||
|
|
||||||
: (inline-recursive-word) ( word -- label in out visitor )
|
: (inline-recursive-word) ( word -- label in out visitor terminated? )
|
||||||
dup prepare-stack
|
dup prepare-stack
|
||||||
[
|
[
|
||||||
init-inference
|
init-inference
|
||||||
|
@ -96,11 +98,13 @@ SYMBOL: enter-out
|
||||||
dup recursive-word-inputs
|
dup recursive-word-inputs
|
||||||
meta-d get
|
meta-d get
|
||||||
stack-visitor get
|
stack-visitor get
|
||||||
|
terminated? get
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
: inline-recursive-word ( word -- )
|
: inline-recursive-word ( word -- )
|
||||||
(inline-recursive-word)
|
(inline-recursive-word)
|
||||||
[ consume-d ] [ output-d ] [ ] tri* #recursive, ;
|
[ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip
|
||||||
|
[ terminate ] when ;
|
||||||
|
|
||||||
: check-call-height ( label -- )
|
: check-call-height ( label -- )
|
||||||
dup entry-stack-height current-stack-height >
|
dup entry-stack-height current-stack-height >
|
||||||
|
|
|
@ -331,7 +331,7 @@ SYMBOL: +primitive+
|
||||||
\ bignum-bitnot { bignum } { bignum } define-primitive
|
\ bignum-bitnot { bignum } { bignum } define-primitive
|
||||||
\ bignum-bitnot make-foldable
|
\ bignum-bitnot make-foldable
|
||||||
|
|
||||||
\ bignum-shift { bignum bignum } { bignum } define-primitive
|
\ bignum-shift { bignum fixnum } { bignum } define-primitive
|
||||||
\ bignum-shift make-foldable
|
\ bignum-shift make-foldable
|
||||||
|
|
||||||
\ bignum< { bignum bignum } { object } define-primitive
|
\ bignum< { bignum bignum } { object } define-primitive
|
||||||
|
|
|
@ -575,3 +575,8 @@ DEFER: eee'
|
||||||
: eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
|
: eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
|
||||||
|
|
||||||
[ [ eee' ] infer ] [ inference-error? ] must-fail-with
|
[ [ eee' ] infer ] [ inference-error? ] must-fail-with
|
||||||
|
|
||||||
|
: bogus-error ( x -- )
|
||||||
|
dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
|
||||||
|
|
||||||
|
[ bogus-error ] must-infer
|
||||||
|
|
|
@ -88,13 +88,12 @@ SYMBOL: prolog-data
|
||||||
: next* ( -- )
|
: next* ( -- )
|
||||||
get-char [ (next) record ] when ;
|
get-char [ (next) record ] when ;
|
||||||
|
|
||||||
: skip-until ( quot -- )
|
: skip-until ( quot: ( -- ? ) -- )
|
||||||
#! quot: ( -- ? )
|
|
||||||
get-char [
|
get-char [
|
||||||
[ call ] keep swap [ drop ] [
|
[ call ] keep swap [ drop ] [
|
||||||
next skip-until
|
next skip-until
|
||||||
] if
|
] if
|
||||||
] [ drop ] if ; inline
|
] [ drop ] if ; inline recursive
|
||||||
|
|
||||||
: take-until ( quot -- string )
|
: take-until ( quot -- string )
|
||||||
#! Take the substring of a string starting at spot
|
#! Take the substring of a string starting at spot
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel xml arrays math generic http.client combinators
|
USING: accessors kernel xml arrays math generic http.client
|
||||||
hashtables namespaces io base64 sequences strings calendar
|
combinators hashtables namespaces io base64 sequences strings
|
||||||
xml.data xml.writer xml.utilities assocs math.parser debugger
|
calendar xml.data xml.writer xml.utilities assocs math.parser
|
||||||
calendar.format math.order ;
|
debugger calendar.format math.order ;
|
||||||
IN: xml-rpc
|
IN: xml-rpc
|
||||||
|
|
||||||
! * Sending RPC requests
|
! * Sending RPC requests
|
||||||
|
@ -17,7 +17,7 @@ M: integer item>xml
|
||||||
[ "Integers must fit in 32 bits" throw ] unless
|
[ "Integers must fit in 32 bits" throw ] unless
|
||||||
number>string "i4" build-tag ;
|
number>string "i4" build-tag ;
|
||||||
|
|
||||||
PREDICATE: boolean < object { t f } member? ;
|
UNION: boolean t POSTPONE: f ;
|
||||||
|
|
||||||
M: boolean item>xml
|
M: boolean item>xml
|
||||||
"1" "0" ? "boolean" build-tag ;
|
"1" "0" ? "boolean" build-tag ;
|
||||||
|
@ -147,10 +147,10 @@ TAG: array xml>item
|
||||||
xml>item [ "faultCode" get "faultString" get ] bind ;
|
xml>item [ "faultCode" get "faultString" get ] bind ;
|
||||||
|
|
||||||
: receive-rpc ( xml -- rpc )
|
: receive-rpc ( xml -- rpc )
|
||||||
dup name-tag dup "methodCall" =
|
dup main>> dup "methodCall" =
|
||||||
[ drop parse-method <rpc-method> ] [
|
[ drop parse-method <rpc-method> ] [
|
||||||
"methodResponse" = [
|
"methodResponse" = [
|
||||||
dup first-child-tag name-tag "fault" =
|
dup first-child-tag main>> "fault" =
|
||||||
[ parse-fault <rpc-fault> ]
|
[ parse-fault <rpc-fault> ]
|
||||||
[ parse-rpc-response <rpc-response> ] if
|
[ parse-rpc-response <rpc-response> ] if
|
||||||
] [ "Bad main tag name" server-error ] if
|
] [ "Bad main tag name" server-error ] if
|
||||||
|
|
|
@ -1,25 +1,26 @@
|
||||||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sequences sequences.private assocs arrays
|
USING: kernel sequences sequences.private assocs arrays
|
||||||
delegate.protocols delegate vectors ;
|
delegate.protocols delegate vectors accessors multiline
|
||||||
|
macros words quotations combinators ;
|
||||||
IN: xml.data
|
IN: xml.data
|
||||||
|
|
||||||
TUPLE: name space tag url ;
|
TUPLE: name space main url ;
|
||||||
C: <name> name
|
C: <name> name
|
||||||
|
|
||||||
: ?= ( object/f object/f -- ? )
|
: ?= ( object/f object/f -- ? )
|
||||||
2dup and [ = ] [ 2drop t ] if ;
|
2dup and [ = ] [ 2drop t ] if ;
|
||||||
|
|
||||||
: names-match? ( name1 name2 -- ? )
|
: names-match? ( name1 name2 -- ? )
|
||||||
[ name-space swap name-space ?= ] 2keep
|
[ [ space>> ] bi@ ?= ]
|
||||||
[ name-url swap name-url ?= ] 2keep
|
[ [ url>> ] bi@ ?= ]
|
||||||
name-tag swap name-tag ?= and and ;
|
[ [ main>> ] bi@ ?= ] 2tri and and ;
|
||||||
|
|
||||||
: <name-tag> ( string -- name )
|
: <simple-name> ( string -- name )
|
||||||
f swap f <name> ;
|
f swap f <name> ;
|
||||||
|
|
||||||
: assure-name ( string/name -- name )
|
: assure-name ( string/name -- name )
|
||||||
dup name? [ <name-tag> ] unless ;
|
dup name? [ <simple-name> ] unless ;
|
||||||
|
|
||||||
TUPLE: opener name attrs ;
|
TUPLE: opener name attrs ;
|
||||||
C: <opener> opener
|
C: <opener> opener
|
||||||
|
@ -42,13 +43,11 @@ C: <instruction> instruction
|
||||||
TUPLE: prolog version encoding standalone ;
|
TUPLE: prolog version encoding standalone ;
|
||||||
C: <prolog> prolog
|
C: <prolog> prolog
|
||||||
|
|
||||||
TUPLE: tag attrs children ;
|
|
||||||
|
|
||||||
TUPLE: attrs alist ;
|
TUPLE: attrs alist ;
|
||||||
C: <attrs> attrs
|
C: <attrs> attrs
|
||||||
|
|
||||||
: attr@ ( key alist -- index {key,value} )
|
: attr@ ( key alist -- index {key,value} )
|
||||||
>r assure-name r> attrs-alist
|
>r assure-name r> alist>>
|
||||||
[ first names-match? ] with find ;
|
[ first names-match? ] with find ;
|
||||||
|
|
||||||
M: attrs at*
|
M: attrs at*
|
||||||
|
@ -58,12 +57,12 @@ M: attrs set-at
|
||||||
2nip set-second
|
2nip set-second
|
||||||
] [
|
] [
|
||||||
>r assure-name swap 2array r>
|
>r assure-name swap 2array r>
|
||||||
[ attrs-alist ?push ] keep set-attrs-alist
|
[ alist>> ?push ] keep (>>alist)
|
||||||
] if* ;
|
] if* ;
|
||||||
|
|
||||||
M: attrs assoc-size attrs-alist length ;
|
M: attrs assoc-size alist>> length ;
|
||||||
M: attrs new-assoc drop V{ } new-sequence <attrs> ;
|
M: attrs new-assoc drop V{ } new-sequence <attrs> ;
|
||||||
M: attrs >alist attrs-alist ;
|
M: attrs >alist alist>> ;
|
||||||
|
|
||||||
: >attrs ( assoc -- attrs )
|
: >attrs ( assoc -- attrs )
|
||||||
dup [
|
dup [
|
||||||
|
@ -74,61 +73,71 @@ M: attrs assoc-like
|
||||||
drop dup attrs? [ >attrs ] unless ;
|
drop dup attrs? [ >attrs ] unless ;
|
||||||
|
|
||||||
M: attrs clear-assoc
|
M: attrs clear-assoc
|
||||||
f swap set-attrs-alist ;
|
f >>alist drop ;
|
||||||
M: attrs delete-at
|
M: attrs delete-at
|
||||||
tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ;
|
tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
|
||||||
|
|
||||||
M: attrs clone
|
M: attrs clone
|
||||||
attrs-alist clone <attrs> ;
|
alist>> clone <attrs> ;
|
||||||
|
|
||||||
INSTANCE: attrs assoc
|
INSTANCE: attrs assoc
|
||||||
|
|
||||||
|
TUPLE: tag name attrs children ;
|
||||||
|
|
||||||
: <tag> ( name attrs children -- tag )
|
: <tag> ( name attrs children -- tag )
|
||||||
>r >r assure-name r> T{ attrs } assoc-like r>
|
[ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
|
||||||
{ set-delegate set-tag-attrs set-tag-children }
|
tag boa ;
|
||||||
tag construct ;
|
|
||||||
|
|
||||||
! For convenience, tags follow the assoc protocol too (for attrs)
|
! For convenience, tags follow the assoc protocol too (for attrs)
|
||||||
CONSULT: assoc-protocol tag tag-attrs ;
|
CONSULT: assoc-protocol tag tag-attrs ;
|
||||||
INSTANCE: tag assoc
|
INSTANCE: tag assoc
|
||||||
|
|
||||||
! They also follow the sequence protocol (for children)
|
! They also follow the sequence protocol (for children)
|
||||||
CONSULT: sequence-protocol tag tag-children ;
|
CONSULT: sequence-protocol tag children>> ;
|
||||||
INSTANCE: tag sequence
|
INSTANCE: tag sequence
|
||||||
|
|
||||||
|
CONSULT: name tag name>> ;
|
||||||
|
|
||||||
M: tag like
|
M: tag like
|
||||||
over tag? [ drop ] [
|
over tag? [ drop ] [
|
||||||
[ delegate ] keep tag-attrs
|
[ name>> ] keep tag-attrs
|
||||||
rot dup [ V{ } like ] when <tag>
|
rot dup [ V{ } like ] when <tag>
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
MACRO: clone-slots ( class -- tuple )
|
||||||
|
[
|
||||||
|
"slots" word-prop
|
||||||
|
[ reader>> 1quotation [ clone ] compose ] map
|
||||||
|
[ cleave ] curry
|
||||||
|
] [ [ boa ] curry ] bi compose ;
|
||||||
|
|
||||||
M: tag clone
|
M: tag clone
|
||||||
[ delegate clone ] keep [ tag-attrs clone ] keep
|
tag clone-slots ;
|
||||||
tag-children clone
|
|
||||||
{ set-delegate set-tag-attrs set-tag-children } tag construct ;
|
|
||||||
|
|
||||||
TUPLE: xml prolog before main after ;
|
TUPLE: xml prolog before body after ;
|
||||||
: <xml> ( prolog before main after -- xml )
|
C: <xml> xml
|
||||||
{ set-xml-prolog set-xml-before set-delegate set-xml-after }
|
|
||||||
xml construct ;
|
|
||||||
|
|
||||||
CONSULT: sequence-protocol xml delegate ;
|
CONSULT: sequence-protocol xml body>> ;
|
||||||
INSTANCE: xml sequence
|
INSTANCE: xml sequence
|
||||||
|
|
||||||
CONSULT: assoc-protocol xml delegate ;
|
CONSULT: assoc-protocol xml body>> ;
|
||||||
INSTANCE: xml assoc
|
INSTANCE: xml assoc
|
||||||
|
|
||||||
|
CONSULT: tag xml body>> ;
|
||||||
|
|
||||||
|
CONSULT: name xml body>> ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
: tag>xml ( xml tag -- newxml )
|
: tag>xml ( xml tag -- newxml )
|
||||||
swap [ dup xml-prolog swap xml-before rot ] keep xml-after <xml> ;
|
>r [ prolog>> ] [ before>> ] [ after>> ] tri r>
|
||||||
|
swap <xml> ;
|
||||||
|
|
||||||
: seq>xml ( xml seq -- newxml )
|
: seq>xml ( xml seq -- newxml )
|
||||||
over delegate like tag>xml ;
|
over body>> like tag>xml ;
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
M: xml clone
|
M: xml clone
|
||||||
[ xml-prolog clone ] keep [ xml-before clone ] keep
|
xml clone-slots ;
|
||||||
[ delegate clone ] keep xml-after clone <xml> ;
|
|
||||||
|
|
||||||
M: xml like
|
M: xml like
|
||||||
swap dup xml? [ nip ] [
|
swap dup xml? [ nip ] [
|
||||||
|
@ -139,5 +148,5 @@ M: xml like
|
||||||
: <contained-tag> ( name attrs -- tag )
|
: <contained-tag> ( name attrs -- tag )
|
||||||
f <tag> ;
|
f <tag> ;
|
||||||
|
|
||||||
PREDICATE: contained-tag < tag tag-children not ;
|
PREDICATE: contained-tag < tag children>> not ;
|
||||||
PREDICATE: open-tag < tag tag-children ;
|
PREDICATE: open-tag < tag children>> ;
|
||||||
|
|
|
@ -27,7 +27,7 @@ IN: xml.generator
|
||||||
|
|
||||||
! Word-based XML literal syntax
|
! Word-based XML literal syntax
|
||||||
: parsed-name ( accum -- accum )
|
: parsed-name ( accum -- accum )
|
||||||
scan ":" split1 [ f <name> ] [ <name-tag> ] if* parsed ;
|
scan ":" split1 [ f <name> ] [ <simple-name> ] if* parsed ;
|
||||||
|
|
||||||
: run-combinator ( accum quot1 quot2 -- accum )
|
: run-combinator ( accum quot1 quot2 -- accum )
|
||||||
>r [ ] like parsed r> [ parsed ] each ;
|
>r [ ] like parsed r> [ parsed ] each ;
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: kernel xml sequences assocs tools.test io arrays namespaces
|
USING: kernel xml sequences assocs tools.test io arrays namespaces
|
||||||
xml.data xml.utilities xml.writer generic sequences.deep ;
|
accessors xml.data xml.utilities xml.writer generic sequences.deep ;
|
||||||
IN: xml.tests
|
IN: xml.tests
|
||||||
|
|
||||||
: sub-tag
|
: sub-tag
|
||||||
|
@ -11,7 +11,7 @@ GENERIC: (r-ref) ( xml -- )
|
||||||
M: tag (r-ref)
|
M: tag (r-ref)
|
||||||
sub-tag over at* [
|
sub-tag over at* [
|
||||||
ref-table get at
|
ref-table get at
|
||||||
swap set-tag-children
|
>>children drop
|
||||||
] [ 2drop ] if ;
|
] [ 2drop ] if ;
|
||||||
M: object (r-ref) drop ;
|
M: object (r-ref) drop ;
|
||||||
|
|
||||||
|
@ -34,7 +34,7 @@ M: object (r-ref) drop ;
|
||||||
[
|
[
|
||||||
H{
|
H{
|
||||||
{ "foo" { "foo" } }
|
{ "foo" { "foo" } }
|
||||||
{ "bar" { "blah" T{ tag T{ name f "" "a" "" } V{ } f } } }
|
{ "bar" { "blah" T{ tag f T{ name f "" "a" "" } f f } } }
|
||||||
{ "baz" f }
|
{ "baz" f }
|
||||||
} ref-table set
|
} ref-table set
|
||||||
sample-doc string>xml dup template xml>string
|
sample-doc string>xml dup template xml>string
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
IN: xml.tests
|
IN: xml.tests
|
||||||
USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
|
USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
|
||||||
parser strings xml.data io.files xml.writer xml.utilities state-parser
|
parser strings xml.data io.files xml.writer xml.utilities state-parser
|
||||||
continuations assocs sequences.deep ;
|
continuations assocs sequences.deep accessors ;
|
||||||
|
|
||||||
! This is insufficient
|
! This is insufficient
|
||||||
\ read-xml must-infer
|
\ read-xml must-infer
|
||||||
|
@ -11,22 +11,22 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
|
||||||
SYMBOL: xml-file
|
SYMBOL: xml-file
|
||||||
[ ] [ "resource:basis/xml/tests/test.xml"
|
[ ] [ "resource:basis/xml/tests/test.xml"
|
||||||
[ file>xml ] with-html-entities xml-file set ] unit-test
|
[ file>xml ] with-html-entities xml-file set ] unit-test
|
||||||
[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
|
[ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
|
||||||
[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
|
[ f ] [ xml-file get prolog>> standalone>> ] unit-test
|
||||||
[ "a" ] [ xml-file get name-space ] unit-test
|
[ "a" ] [ xml-file get space>> ] unit-test
|
||||||
[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test
|
[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
|
||||||
[ "that" ] [
|
[ "that" ] [
|
||||||
xml-file get T{ name f "" "this" "http://d.de" } swap at
|
xml-file get T{ name f "" "this" "http://d.de" } swap at
|
||||||
] unit-test
|
] unit-test
|
||||||
[ t ] [ xml-file get tag-children second contained-tag? ] unit-test
|
[ t ] [ xml-file get children>> second contained-tag? ] unit-test
|
||||||
[ "<a></b>" string>xml ] [ xml-parse-error? ] must-fail-with
|
[ "<a></b>" string>xml ] [ xml-parse-error? ] must-fail-with
|
||||||
[ T{ comment f "This is where the fun begins!" } ] [
|
[ T{ comment f "This is where the fun begins!" } ] [
|
||||||
xml-file get xml-before [ comment? ] find nip
|
xml-file get xml-before [ comment? ] find nip
|
||||||
] unit-test
|
] unit-test
|
||||||
[ "xsl stylesheet=\"that-one.xsl\"" ] [
|
[ "xsl stylesheet=\"that-one.xsl\"" ] [
|
||||||
xml-file get xml-after [ instruction? ] find nip instruction-text
|
xml-file get after>> [ instruction? ] find nip text>>
|
||||||
] unit-test
|
] unit-test
|
||||||
[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] 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" swap at ] unit-test
|
||||||
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
|
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
|
||||||
[ "<a b='c'/>" string>xml xml>string ] unit-test
|
[ "<a b='c'/>" string>xml xml>string ] unit-test
|
||||||
|
|
|
@ -2,7 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: xml.errors xml.data xml.utilities xml.char-classes sets
|
USING: xml.errors xml.data xml.utilities xml.char-classes sets
|
||||||
xml.entities kernel state-parser kernel namespaces strings math
|
xml.entities kernel state-parser kernel namespaces strings math
|
||||||
math.parser sequences assocs arrays splitting combinators unicode.case ;
|
math.parser sequences assocs arrays splitting combinators unicode.case
|
||||||
|
accessors ;
|
||||||
IN: xml.tokenize
|
IN: xml.tokenize
|
||||||
|
|
||||||
! XML namespace processing: ns = namespace
|
! XML namespace processing: ns = namespace
|
||||||
|
@ -14,8 +15,8 @@ SYMBOL: ns-stack
|
||||||
! this should check to make sure URIs are valid
|
! this should check to make sure URIs are valid
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
swap dup name-space "xmlns" =
|
swap dup space>> "xmlns" =
|
||||||
[ name-tag set ]
|
[ main>> set ]
|
||||||
[
|
[
|
||||||
T{ name f "" "xmlns" f } names-match?
|
T{ name f "" "xmlns" f } names-match?
|
||||||
[ "" set ] [ drop ] if
|
[ "" set ] [ drop ] if
|
||||||
|
@ -24,8 +25,8 @@ SYMBOL: ns-stack
|
||||||
] { } make-assoc f like ;
|
] { } make-assoc f like ;
|
||||||
|
|
||||||
: add-ns ( name -- )
|
: add-ns ( name -- )
|
||||||
dup name-space dup ns-stack get assoc-stack
|
dup space>> dup ns-stack get assoc-stack
|
||||||
[ nip ] [ <nonexist-ns> throw ] if* swap set-name-url ;
|
[ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
|
||||||
|
|
||||||
: push-ns ( hash -- )
|
: push-ns ( hash -- )
|
||||||
ns-stack get push ;
|
ns-stack get push ;
|
||||||
|
|
|
@ -10,13 +10,13 @@ IN: xml.utilities
|
||||||
TUPLE: process-missing process tag ;
|
TUPLE: process-missing process tag ;
|
||||||
M: process-missing error.
|
M: process-missing error.
|
||||||
"Tag <" write
|
"Tag <" write
|
||||||
dup process-missing-tag print-name
|
dup tag>> print-name
|
||||||
"> not implemented on process process " write
|
"> not implemented on process process " write
|
||||||
process-missing-process name>> print ;
|
name>> print ;
|
||||||
|
|
||||||
: run-process ( tag word -- )
|
: run-process ( tag word -- )
|
||||||
2dup "xtable" word-prop
|
2dup "xtable" word-prop
|
||||||
>r dup name-tag r> at* [ 2nip call ] [
|
>r dup main>> r> at* [ 2nip call ] [
|
||||||
drop \ process-missing boa throw
|
drop \ process-missing boa throw
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
@ -48,17 +48,18 @@ M: process-missing error.
|
||||||
standard-prolog { } rot { } <xml> ;
|
standard-prolog { } rot { } <xml> ;
|
||||||
|
|
||||||
: children>string ( tag -- string )
|
: children>string ( tag -- string )
|
||||||
tag-children {
|
children>> {
|
||||||
{ [ dup empty? ] [ drop "" ] }
|
{ [ dup empty? ] [ drop "" ] }
|
||||||
{ [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
|
{ [ dup [ string? not ] contains? ]
|
||||||
|
[ "XML tag unexpectedly contains non-text children" throw ] }
|
||||||
[ concat ]
|
[ concat ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: children-tags ( tag -- sequence )
|
: children-tags ( tag -- sequence )
|
||||||
tag-children [ tag? ] filter ;
|
children>> [ tag? ] filter ;
|
||||||
|
|
||||||
: first-child-tag ( tag -- tag )
|
: first-child-tag ( tag -- tag )
|
||||||
tag-children [ tag? ] find nip ;
|
children>> [ tag? ] find nip ;
|
||||||
|
|
||||||
! * Accessing part of an XML document
|
! * Accessing part of an XML document
|
||||||
! for tag- words, a start means that it searches all children
|
! for tag- words, a start means that it searches all children
|
||||||
|
@ -91,7 +92,7 @@ M: process-missing error.
|
||||||
assure-name [ tag-with-attr? ] 2curry find nip ;
|
assure-name [ tag-with-attr? ] 2curry find nip ;
|
||||||
|
|
||||||
: tags-with-attr ( tag attr-value attr-name -- tags-seq )
|
: tags-with-attr ( tag attr-value attr-name -- tags-seq )
|
||||||
tags@ [ tag-with-attr? ] 2curry filter tag-children ;
|
tags@ [ tag-with-attr? ] 2curry filter children>> ;
|
||||||
|
|
||||||
: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
|
: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
|
||||||
assure-name [ tag-with-attr? ] 2curry deep-find ;
|
assure-name [ tag-with-attr? ] 2curry deep-find ;
|
||||||
|
@ -109,8 +110,8 @@ M: process-missing error.
|
||||||
names-match? [ "Unexpected XML tag found" throw ] unless ;
|
names-match? [ "Unexpected XML tag found" throw ] unless ;
|
||||||
|
|
||||||
: insert-children ( children tag -- )
|
: insert-children ( children tag -- )
|
||||||
dup tag-children [ push-all ]
|
dup children>> [ push-all ]
|
||||||
[ >r V{ } like r> set-tag-children ] if ;
|
[ swap V{ } like >>children drop ] if ;
|
||||||
|
|
||||||
: insert-child ( child tag -- )
|
: insert-child ( child tag -- )
|
||||||
>r 1vector r> insert-children ;
|
>r 1vector r> insert-children ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: hashtables kernel math namespaces sequences strings
|
USING: hashtables kernel math namespaces sequences strings
|
||||||
assocs combinators io io.streams.string
|
assocs combinators io io.streams.string accessors
|
||||||
xml.data wrap xml.entities unicode.categories ;
|
xml.data wrap xml.entities unicode.categories ;
|
||||||
IN: xml.writer
|
IN: xml.writer
|
||||||
|
|
||||||
|
@ -38,9 +38,9 @@ SYMBOL: indenter
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: print-name ( name -- )
|
: print-name ( name -- )
|
||||||
dup name-space f like
|
dup space>> f like
|
||||||
[ write CHAR: : write1 ] when*
|
[ write CHAR: : write1 ] when*
|
||||||
name-tag write ;
|
main>> write ;
|
||||||
|
|
||||||
: print-attrs ( assoc -- )
|
: print-attrs ( assoc -- )
|
||||||
[
|
[
|
||||||
|
@ -59,7 +59,7 @@ M: string write-item
|
||||||
|
|
||||||
: write-tag ( tag -- )
|
: write-tag ( tag -- )
|
||||||
?indent CHAR: < write1
|
?indent CHAR: < write1
|
||||||
dup print-name tag-attrs print-attrs ;
|
dup print-name attrs>> print-attrs ;
|
||||||
|
|
||||||
: write-start-tag ( tag -- )
|
: write-start-tag ( tag -- )
|
||||||
write-tag ">" write ;
|
write-tag ">" write ;
|
||||||
|
@ -68,7 +68,7 @@ M: contained-tag write-item
|
||||||
write-tag "/>" write ;
|
write-tag "/>" write ;
|
||||||
|
|
||||||
: write-children ( tag -- )
|
: write-children ( tag -- )
|
||||||
indent tag-children ?filter-children
|
indent children>> ?filter-children
|
||||||
[ write-item ] each unindent ;
|
[ write-item ] each unindent ;
|
||||||
|
|
||||||
: write-end-tag ( tag -- )
|
: write-end-tag ( tag -- )
|
||||||
|
@ -85,18 +85,18 @@ M: open-tag write-item
|
||||||
r> xml-pprint? set ;
|
r> xml-pprint? set ;
|
||||||
|
|
||||||
M: comment write-item
|
M: comment write-item
|
||||||
"<!--" write comment-text write "-->" write ;
|
"<!--" write text>> write "-->" write ;
|
||||||
|
|
||||||
M: directive write-item
|
M: directive write-item
|
||||||
"<!" write directive-text write CHAR: > write1 ;
|
"<!" write text>> write CHAR: > write1 ;
|
||||||
|
|
||||||
M: instruction write-item
|
M: instruction write-item
|
||||||
"<?" write instruction-text write "?>" write ;
|
"<?" write text>> write "?>" write ;
|
||||||
|
|
||||||
: write-prolog ( xml -- )
|
: write-prolog ( xml -- )
|
||||||
"<?xml version=\"" write dup prolog-version write
|
"<?xml version=\"" write dup version>> write
|
||||||
"\" encoding=\"" write dup prolog-encoding write
|
"\" encoding=\"" write dup encoding>> write
|
||||||
prolog-standalone [ "\" standalone=\"yes" write ] when
|
standalone>> [ "\" standalone=\"yes" write ] when
|
||||||
"\"?>" write ;
|
"\"?>" write ;
|
||||||
|
|
||||||
: write-chunk ( seq -- )
|
: write-chunk ( seq -- )
|
||||||
|
@ -104,10 +104,10 @@ M: instruction write-item
|
||||||
|
|
||||||
: write-xml ( xml -- )
|
: write-xml ( xml -- )
|
||||||
{
|
{
|
||||||
[ xml-prolog write-prolog ]
|
[ prolog>> write-prolog ]
|
||||||
[ xml-before write-chunk ]
|
[ before>> write-chunk ]
|
||||||
[ write-item ]
|
[ body>> write-item ]
|
||||||
[ xml-after write-chunk ]
|
[ after>> write-chunk ]
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
: print-xml ( xml -- )
|
: print-xml ( xml -- )
|
||||||
|
|
|
@ -38,19 +38,19 @@ M: directive process
|
||||||
add-child ;
|
add-child ;
|
||||||
|
|
||||||
M: contained process
|
M: contained process
|
||||||
[ contained-name ] keep contained-attrs
|
[ name>> ] [ attrs>> ] bi
|
||||||
<contained-tag> add-child ;
|
<contained-tag> add-child ;
|
||||||
|
|
||||||
M: opener process push-xml ;
|
M: opener process push-xml ;
|
||||||
|
|
||||||
: check-closer ( name opener -- name opener )
|
: check-closer ( name opener -- name opener )
|
||||||
dup [ <unopened> throw ] unless
|
dup [ <unopened> throw ] unless
|
||||||
2dup opener-name =
|
2dup name>> =
|
||||||
[ opener-name swap <mismatched> throw ] unless ;
|
[ name>> swap <mismatched> throw ] unless ;
|
||||||
|
|
||||||
M: closer process
|
M: closer process
|
||||||
closer-name pop-xml first2
|
name>> pop-xml first2
|
||||||
>r check-closer opener-attrs r>
|
>r check-closer attrs>> r>
|
||||||
<tag> add-child ;
|
<tag> add-child ;
|
||||||
|
|
||||||
: init-xml-stack ( -- )
|
: init-xml-stack ( -- )
|
||||||
|
@ -102,10 +102,10 @@ TUPLE: pull-xml scope ;
|
||||||
init-parser reset-prolog init-ns-stack
|
init-parser reset-prolog init-ns-stack
|
||||||
text-now? on
|
text-now? on
|
||||||
] H{ } make-assoc
|
] H{ } make-assoc
|
||||||
{ set-pull-xml-scope } pull-xml construct ;
|
pull-xml boa ;
|
||||||
|
|
||||||
: pull-event ( pull -- xml-event/f )
|
: pull-event ( pull -- xml-event/f )
|
||||||
pull-xml-scope [
|
scope>> [
|
||||||
text-now? get [ parse-text f ] [
|
text-now? get [ parse-text f ] [
|
||||||
get-char [ make-tag t ] [ f f ] if
|
get-char [ make-tag t ] [ f f ] if
|
||||||
] if text-now? set
|
] if text-now? set
|
||||||
|
@ -127,17 +127,17 @@ TUPLE: pull-xml scope ;
|
||||||
: call-under ( quot object -- quot )
|
: call-under ( quot object -- quot )
|
||||||
swap dup slip ; inline
|
swap dup slip ; inline
|
||||||
|
|
||||||
: sax-loop ( quot -- ) ! quot: xml-elem --
|
: sax-loop ( quot: ( xml-elem -- ) -- )
|
||||||
parse-text call-under
|
parse-text call-under
|
||||||
get-char [ make-tag call-under sax-loop ]
|
get-char [ make-tag call-under sax-loop ]
|
||||||
[ drop ] if ; inline
|
[ drop ] if ; inline recursive
|
||||||
|
|
||||||
: sax ( stream quot -- ) ! quot: xml-elem --
|
: sax ( stream quot: ( xml-elem -- ) -- )
|
||||||
swap [
|
swap [
|
||||||
reset-prolog init-ns-stack
|
reset-prolog init-ns-stack
|
||||||
prolog-data get call-under
|
prolog-data get call-under
|
||||||
sax-loop
|
sax-loop
|
||||||
] state-parse ; inline
|
] state-parse ; inline recursive
|
||||||
|
|
||||||
: (read-xml) ( -- )
|
: (read-xml) ( -- )
|
||||||
[ process ] sax-loop ; inline
|
[ process ] sax-loop ; inline
|
||||||
|
|
|
@ -105,3 +105,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
||||||
[ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
|
[ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
|
||||||
|
|
||||||
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
|
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
|
||||||
|
|
||||||
|
MIXIN: empty-mixin
|
||||||
|
|
||||||
|
[ f ] [ "hi" empty-mixin? ] unit-test
|
||||||
|
|
|
@ -20,7 +20,9 @@ M: mixin-class rank-class drop 3 ;
|
||||||
dup mixin-class? [
|
dup mixin-class? [
|
||||||
drop
|
drop
|
||||||
] [
|
] [
|
||||||
{ } redefine-mixin-class
|
[ { } redefine-mixin-class ]
|
||||||
|
[ update-classes ]
|
||||||
|
bi
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
TUPLE: check-mixin-class mixin ;
|
TUPLE: check-mixin-class mixin ;
|
||||||
|
|
|
@ -270,6 +270,9 @@ M: tuple-class define-tuple-class
|
||||||
tri* define-declared
|
tri* define-declared
|
||||||
] 3tri ;
|
] 3tri ;
|
||||||
|
|
||||||
|
M: tuple-class update-generic
|
||||||
|
over new-class? [ 2drop ] [ call-next-method ] if ;
|
||||||
|
|
||||||
M: tuple-class reset-class
|
M: tuple-class reset-class
|
||||||
[
|
[
|
||||||
dup "slots" word-prop [
|
dup "slots" word-prop [
|
||||||
|
|
|
@ -62,7 +62,9 @@ TUPLE: check-method class generic ;
|
||||||
[ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
|
[ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
|
||||||
values ;
|
values ;
|
||||||
|
|
||||||
: update-generic ( class generic -- )
|
GENERIC# update-generic 1 ( class generic -- )
|
||||||
|
|
||||||
|
M: class update-generic
|
||||||
affected-methods [ +called+ changed-definition ] each ;
|
affected-methods [ +called+ changed-definition ] each ;
|
||||||
|
|
||||||
: with-methods ( class generic quot -- )
|
: with-methods ( class generic quot -- )
|
||||||
|
|
|
@ -2,7 +2,9 @@ USING: io.binary tools.test classes math ;
|
||||||
IN: io.binary.tests
|
IN: io.binary.tests
|
||||||
|
|
||||||
[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
|
[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
|
||||||
|
[ B{ 0 0 0 0 0 0 4 HEX: d2 } ] [ 1234 8 >be ] unit-test
|
||||||
[ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test
|
[ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test
|
||||||
|
[ B{ HEX: d2 4 0 0 0 0 0 0 } ] [ 1234 8 >le ] unit-test
|
||||||
|
|
||||||
[ 1234 ] [ 1234 4 >be be> ] unit-test
|
[ 1234 ] [ 1234 4 >be be> ] unit-test
|
||||||
[ 1234 ] [ 1234 4 >le le> ] unit-test
|
[ 1234 ] [ 1234 4 >le le> ] unit-test
|
||||||
|
|
|
@ -24,7 +24,7 @@ t parser-notes set-global
|
||||||
|
|
||||||
: note. ( str -- )
|
: note. ( str -- )
|
||||||
parser-notes? [
|
parser-notes? [
|
||||||
file get [ path>> write ] when*
|
file get [ path>> write ":" write ] when*
|
||||||
lexer get line>> number>string write ": " write
|
lexer get line>> number>string write ": " write
|
||||||
"Note: " write dup print
|
"Note: " write dup print
|
||||||
] when drop ;
|
] when drop ;
|
||||||
|
|
|
@ -96,12 +96,12 @@ M: object execute-statement* ( statement type -- )
|
||||||
: sql-row-typed ( result-set -- seq )
|
: sql-row-typed ( result-set -- seq )
|
||||||
dup #columns [ row-column-typed ] with map ;
|
dup #columns [ row-column-typed ] with map ;
|
||||||
|
|
||||||
: query-each ( statement quot -- )
|
: query-each ( statement quot: ( statement -- ) -- )
|
||||||
over more-rows? [
|
over more-rows? [
|
||||||
[ call ] 2keep over advance-row query-each
|
[ call ] 2keep over advance-row query-each
|
||||||
] [
|
] [
|
||||||
2drop
|
2drop
|
||||||
] if ; inline
|
] if ; inline recursive
|
||||||
|
|
||||||
: query-map ( statement quot -- seq )
|
: query-map ( statement quot -- seq )
|
||||||
accumulator >r query-each r> { } like ; inline
|
accumulator >r query-each r> { } like ; inline
|
||||||
|
|
|
@ -14,7 +14,7 @@ GENERIC: where ( specs obj -- )
|
||||||
|
|
||||||
: query-make ( class quot -- )
|
: query-make ( class quot -- )
|
||||||
>r sql-props r>
|
>r sql-props r>
|
||||||
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
|
[ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
|
||||||
<simple-statement> maybe-make-retryable ; inline
|
<simple-statement> maybe-make-retryable ; inline
|
||||||
|
|
||||||
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
|
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
|
||||||
|
|
|
@ -28,6 +28,7 @@ DEFER: process-template
|
||||||
[ drop name-url chloe-ns = not ] assoc-filter ;
|
[ drop name-url chloe-ns = not ] assoc-filter ;
|
||||||
|
|
||||||
: chloe-tag? ( tag -- ? )
|
: chloe-tag? ( tag -- ? )
|
||||||
|
dup xml? [ body>> ] when
|
||||||
{
|
{
|
||||||
{ [ dup tag? not ] [ f ] }
|
{ [ dup tag? not ] [ f ] }
|
||||||
{ [ dup url>> chloe-ns = not ] [ f ] }
|
{ [ dup url>> chloe-ns = not ] [ f ] }
|
||||||
|
@ -112,12 +113,12 @@ CHLOE-TUPLE: checkbox
|
||||||
CHLOE-TUPLE: code
|
CHLOE-TUPLE: code
|
||||||
|
|
||||||
: process-chloe-tag ( tag -- )
|
: process-chloe-tag ( tag -- )
|
||||||
dup name-tag dup tags get at
|
dup main>> dup tags get at
|
||||||
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
|
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
|
||||||
|
|
||||||
: process-tag ( tag -- )
|
: process-tag ( tag -- )
|
||||||
{
|
{
|
||||||
[ name-tag >lower tag-stack get push ]
|
[ main>> >lower tag-stack get push ]
|
||||||
[ write-start-tag ]
|
[ write-start-tag ]
|
||||||
[ process-tag-children ]
|
[ process-tag-children ]
|
||||||
[ write-end-tag ]
|
[ write-end-tag ]
|
||||||
|
@ -125,7 +126,7 @@ CHLOE-TUPLE: code
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
: expand-attrs ( tag -- tag )
|
: expand-attrs ( tag -- tag )
|
||||||
dup [ tag? ] is? [
|
dup [ tag? ] [ xml? ] bi or [
|
||||||
clone [
|
clone [
|
||||||
[ "@" ?head [ value present ] when ] assoc-map
|
[ "@" ?head [ value present ] when ] assoc-map
|
||||||
] change-attrs
|
] change-attrs
|
||||||
|
@ -134,8 +135,8 @@ CHLOE-TUPLE: code
|
||||||
: process-template ( xml -- )
|
: process-template ( xml -- )
|
||||||
expand-attrs
|
expand-attrs
|
||||||
{
|
{
|
||||||
{ [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
|
{ [ dup chloe-tag? ] [ process-chloe-tag ] }
|
||||||
{ [ dup [ tag? ] is? ] [ process-tag ] }
|
{ [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
|
||||||
{ [ t ] [ write-item ] }
|
{ [ t ] [ write-item ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
|
|
@ -23,7 +23,7 @@ tags global [ H{ } clone or ] change-at
|
||||||
|
|
||||||
MEMO: chloe-name ( string -- name )
|
MEMO: chloe-name ( string -- name )
|
||||||
name new
|
name new
|
||||||
swap >>tag
|
swap >>main
|
||||||
chloe-ns >>url ;
|
chloe-ns >>url ;
|
||||||
|
|
||||||
: required-attr ( tag name -- value )
|
: required-attr ( tag name -- value )
|
||||||
|
@ -45,7 +45,7 @@ MEMO: chloe-name ( string -- name )
|
||||||
: attrs>slots ( tag tuple -- )
|
: attrs>slots ( tag tuple -- )
|
||||||
[ attrs>> ] [ <mirror> ] bi*
|
[ attrs>> ] [ <mirror> ] bi*
|
||||||
'[
|
'[
|
||||||
swap tag>> dup "name" =
|
swap main>> dup "name" =
|
||||||
[ 2drop ] [ , set-at ] if
|
[ 2drop ] [ , set-at ] if
|
||||||
] assoc-each ;
|
] assoc-each ;
|
||||||
|
|
||||||
|
|
|
@ -62,10 +62,10 @@ C: <nil> nil
|
||||||
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
|
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
|
||||||
|
|
||||||
: empty-cons ( -- cons ) cons new ;
|
: empty-cons ( -- cons ) cons new ;
|
||||||
: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
|
: cons* ( cdr car -- cons ) cons boa ;
|
||||||
|
|
||||||
[ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
|
[ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
|
||||||
[ 1 2 ] [ 2 1 <cons> [ cons* ] undo ] unit-test
|
[ 1 2 ] [ 1 2 <cons> [ cons* ] undo ] unit-test
|
||||||
|
|
||||||
[ t ] [ pi [ pi ] matches? ] unit-test
|
[ t ] [ pi [ pi ] matches? ] unit-test
|
||||||
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
|
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
USING: io.encodings.ascii sequences strings io io.files accessors
|
||||||
|
tools.test kernel io.files.unique ;
|
||||||
IN: io.files.unique.tests
|
IN: io.files.unique.tests
|
||||||
|
|
||||||
[ 123 ] [
|
[ 123 ] [
|
||||||
|
|
|
@ -1,14 +1,14 @@
|
||||||
USING: hints kernel math ;
|
USING: hints kernel math ;
|
||||||
IN: math.bitfields.lib
|
IN: math.bitfields.lib
|
||||||
|
|
||||||
: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
|
: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
|
||||||
: set-bit ( x n -- y ) 2^ bitor ; foldable
|
: set-bit ( x n -- y ) 2^ bitor ; inline
|
||||||
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
|
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
|
||||||
: unmask ( x n -- ? ) bitnot bitand ; foldable
|
: unmask ( x n -- ? ) bitnot bitand ; inline
|
||||||
: unmask? ( x n -- ? ) unmask 0 > ; foldable
|
: unmask? ( x n -- ? ) unmask 0 > ; inline
|
||||||
: mask ( x n -- ? ) bitand ; foldable
|
: mask ( x n -- ? ) bitand ; inline
|
||||||
: mask? ( x n -- ? ) mask 0 > ; foldable
|
: mask? ( x n -- ? ) mask 0 > ; inline
|
||||||
: wrap ( m n -- m' ) 1- bitand ; foldable
|
: wrap ( m n -- m' ) 1- bitand ; inline
|
||||||
: bits ( m n -- m' ) 2^ wrap ; inline
|
: bits ( m n -- m' ) 2^ wrap ; inline
|
||||||
: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
|
: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
|
||||||
|
|
||||||
|
|
|
@ -31,10 +31,10 @@ SYMBOL: matrix
|
||||||
>r over r> nth dup zero? [
|
>r over r> nth dup zero? [
|
||||||
3drop 0
|
3drop 0
|
||||||
] [
|
] [
|
||||||
>r nth dup zero? [
|
>r nth dup zero? r> swap [
|
||||||
r> 2drop 0
|
2drop 0
|
||||||
] [
|
] [
|
||||||
r> swap / neg
|
swap / neg
|
||||||
] if
|
] if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,8 @@
|
||||||
IN: namespaces.lib.tests
|
IN: namespaces.lib.tests
|
||||||
USING: namespaces.lib tools.test ;
|
USING: namespaces.lib kernel tools.test ;
|
||||||
|
|
||||||
[ ] [ [ ] { } nmake ] unit-test
|
[ ] [ [ ] { } nmake ] unit-test
|
||||||
|
|
||||||
[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test
|
[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test
|
||||||
|
|
||||||
|
[ [ ] [ call ] curry { { } } nmake ] must-infer
|
||||||
|
|
|
@ -1,8 +1,6 @@
|
||||||
|
|
||||||
! USING: kernel quotations namespaces sequences assocs.lib ;
|
|
||||||
|
|
||||||
USING: kernel namespaces namespaces.private quotations sequences
|
USING: kernel namespaces namespaces.private quotations sequences
|
||||||
assocs.lib math.parser math generalizations locals mirrors ;
|
assocs.lib math.parser math generalizations locals mirrors
|
||||||
|
macros ;
|
||||||
|
|
||||||
IN: namespaces.lib
|
IN: namespaces.lib
|
||||||
|
|
||||||
|
@ -42,22 +40,20 @@ SYMBOL: building-seq
|
||||||
: 4% ( seq -- ) 4 n% ;
|
: 4% ( seq -- ) 4 n% ;
|
||||||
: 4# ( num -- ) 4 n# ;
|
: 4# ( num -- ) 4 n# ;
|
||||||
|
|
||||||
MACRO:: nmake ( quot exemplars -- )
|
MACRO: finish-nmake ( exemplars -- )
|
||||||
[let | n [ exemplars length ] |
|
length [ firstn ] curry ;
|
||||||
[
|
|
||||||
[
|
|
||||||
exemplars
|
|
||||||
[ 0 swap new-resizable ] map
|
|
||||||
building-seq set
|
|
||||||
|
|
||||||
quot call
|
:: nmake ( quot exemplars -- )
|
||||||
|
[
|
||||||
|
exemplars
|
||||||
|
[ 0 swap new-resizable ] map
|
||||||
|
building-seq set
|
||||||
|
|
||||||
building-seq get
|
quot call
|
||||||
exemplars [ like ] 2map
|
|
||||||
n firstn
|
building-seq get
|
||||||
] with-scope
|
exemplars [ [ like ] 2map ] [ finish-nmake ] bi
|
||||||
]
|
] with-scope ; inline
|
||||||
] ;
|
|
||||||
|
|
||||||
: make-object ( quot class -- object )
|
: make-object ( quot class -- object )
|
||||||
new [ <mirror> swap bind ] keep ; inline
|
new [ <mirror> swap bind ] keep ; inline
|
||||||
|
|
|
@ -193,7 +193,7 @@ USE: continuations
|
||||||
[
|
[
|
||||||
iterate-step roll
|
iterate-step roll
|
||||||
[ 3nip ] [ iterate-next (attempt-each-integer) ] if*
|
[ 3nip ] [ iterate-next (attempt-each-integer) ] if*
|
||||||
] [ 3drop f ] if-iterate? ; inline
|
] [ 3drop f ] if-iterate? ; inline recursive
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: attempt-each ( seq quot -- result )
|
: attempt-each ( seq quot -- result )
|
||||||
|
|
|
@ -76,8 +76,8 @@ TUPLE: entry title url description date ;
|
||||||
[ "link" tag-named "href" swap at >url >>url ]
|
[ "link" tag-named "href" swap at >url >>url ]
|
||||||
[
|
[
|
||||||
{ "content" "summary" } any-tag-named
|
{ "content" "summary" } any-tag-named
|
||||||
dup tag-children [ string? not ] contains?
|
dup children>> [ string? not ] contains?
|
||||||
[ tag-children [ write-chunk ] with-string-writer ]
|
[ children>> [ write-chunk ] with-string-writer ]
|
||||||
[ children>string ] if >>description
|
[ children>string ] if >>description
|
||||||
]
|
]
|
||||||
[
|
[
|
||||||
|
@ -96,7 +96,7 @@ TUPLE: entry title url description date ;
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
: xml>feed ( xml -- feed )
|
: xml>feed ( xml -- feed )
|
||||||
dup name-tag {
|
dup main>> {
|
||||||
{ "RDF" [ rss1.0 ] }
|
{ "RDF" [ rss1.0 ] }
|
||||||
{ "rss" [ rss2.0 ] }
|
{ "rss" [ rss2.0 ] }
|
||||||
{ "feed" [ atom1.0 ] }
|
{ "feed" [ atom1.0 ] }
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
|
USING: accessors xmode.tokens xmode.rules xmode.keyword-map xml.data
|
||||||
xml.utilities xml assocs kernel combinators sequences
|
xml.utilities xml assocs kernel combinators sequences
|
||||||
math.parser namespaces parser lexer xmode.utilities regexp io.files ;
|
math.parser namespaces parser lexer xmode.utilities regexp io.files ;
|
||||||
IN: xmode.loader.syntax
|
IN: xmode.loader.syntax
|
||||||
|
@ -7,7 +7,7 @@ SYMBOL: ignore-case?
|
||||||
|
|
||||||
! Rule tag parsing utilities
|
! Rule tag parsing utilities
|
||||||
: (parse-rule-tag) ( rule-set tag specs class -- )
|
: (parse-rule-tag) ( rule-set tag specs class -- )
|
||||||
construct-rule swap init-from-tag swap add-rule ; inline
|
new swap init-from-tag swap add-rule ; inline
|
||||||
|
|
||||||
: RULE:
|
: RULE:
|
||||||
scan scan-word
|
scan scan-word
|
||||||
|
@ -98,4 +98,4 @@ TAGS>
|
||||||
: init-eol-span-tag ( -- ) [ drop init-eol-span ] , ;
|
: init-eol-span-tag ( -- ) [ drop init-eol-span ] , ;
|
||||||
|
|
||||||
: parse-keyword-tag ( tag keyword-map -- )
|
: parse-keyword-tag ( tag keyword-map -- )
|
||||||
>r dup name-tag string>token swap children>string r> set-at ;
|
>r dup main>> string>token swap children>string r> set-at ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: kernel ;
|
USING: accessors kernel ;
|
||||||
IN: xmode.marker.context
|
IN: xmode.marker.context
|
||||||
|
|
||||||
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
|
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
|
||||||
|
@ -11,10 +11,9 @@ end
|
||||||
|
|
||||||
: <line-context> ( ruleset parent -- line-context )
|
: <line-context> ( ruleset parent -- line-context )
|
||||||
over [ "no context" throw ] unless
|
over [ "no context" throw ] unless
|
||||||
{ set-line-context-in-rule-set set-line-context-parent }
|
line-context new
|
||||||
line-context construct ;
|
swap >>parent
|
||||||
|
swap >>in-rule-set ;
|
||||||
|
|
||||||
M: line-context clone
|
M: line-context clone
|
||||||
(clone)
|
call-next-method [ clone ] change-parent ;
|
||||||
dup line-context-parent clone
|
|
||||||
over set-line-context-parent ;
|
|
||||||
|
|
|
@ -66,14 +66,11 @@ delegate
|
||||||
chars
|
chars
|
||||||
;
|
;
|
||||||
|
|
||||||
: construct-rule ( class -- rule )
|
TUPLE: seq-rule < rule ;
|
||||||
>r rule new r> construct-delegate ; inline
|
|
||||||
|
|
||||||
TUPLE: seq-rule ;
|
TUPLE: span-rule < rule ;
|
||||||
|
|
||||||
TUPLE: span-rule ;
|
TUPLE: eol-span-rule < rule ;
|
||||||
|
|
||||||
TUPLE: eol-span-rule ;
|
|
||||||
|
|
||||||
: init-span ( rule -- )
|
: init-span ( rule -- )
|
||||||
dup rule-delegate [ drop ] [
|
dup rule-delegate [ drop ] [
|
||||||
|
@ -85,16 +82,15 @@ TUPLE: eol-span-rule ;
|
||||||
dup init-span
|
dup init-span
|
||||||
t swap set-rule-no-line-break? ;
|
t swap set-rule-no-line-break? ;
|
||||||
|
|
||||||
TUPLE: mark-following-rule ;
|
TUPLE: mark-following-rule < rule ;
|
||||||
|
|
||||||
TUPLE: mark-previous-rule ;
|
TUPLE: mark-previous-rule < rule ;
|
||||||
|
|
||||||
TUPLE: escape-rule ;
|
TUPLE: escape-rule < rule ;
|
||||||
|
|
||||||
: <escape-rule> ( string -- rule )
|
: <escape-rule> ( string -- rule )
|
||||||
f <string-matcher> f f f <matcher>
|
f <string-matcher> f f f <matcher>
|
||||||
escape-rule construct-rule
|
escape-rule new swap >>start ;
|
||||||
[ set-rule-start ] keep ;
|
|
||||||
|
|
||||||
GENERIC: text-hash-char ( text -- ch )
|
GENERIC: text-hash-char ( text -- ch )
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: xmode.utilities.tests
|
IN: xmode.utilities.tests
|
||||||
USING: xmode.utilities tools.test xml xml.data kernel strings
|
USING: accessors xmode.utilities tools.test xml xml.data kernel
|
||||||
vectors sequences io.files prettyprint assocs unicode.case ;
|
strings vectors sequences io.files prettyprint assocs
|
||||||
|
unicode.case ;
|
||||||
[ "hi" 3 ] [
|
[ "hi" 3 ] [
|
||||||
{ 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
|
{ 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
|
||||||
] unit-test
|
] unit-test
|
||||||
|
@ -35,7 +35,7 @@ TAGS>
|
||||||
{ { "type" >upper set-company-type } }
|
{ { "type" >upper set-company-type } }
|
||||||
init-from-tag dup
|
init-from-tag dup
|
||||||
] keep
|
] keep
|
||||||
tag-children [ tag? ] filter
|
children>> [ tag? ] filter
|
||||||
[ parse-employee-tag ] with each ;
|
[ parse-employee-tag ] with each ;
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
USING: sequences assocs kernel quotations namespaces xml.data
|
USING: accessors sequences assocs kernel quotations namespaces
|
||||||
xml.utilities combinators macros parser lexer words ;
|
xml.data xml.utilities combinators macros parser lexer words ;
|
||||||
IN: xmode.utilities
|
IN: xmode.utilities
|
||||||
|
|
||||||
: implies >r not r> or ; inline
|
: implies >r not r> or ; inline
|
||||||
|
|
||||||
: child-tags ( tag -- seq ) tag-children [ tag? ] filter ;
|
: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
|
||||||
|
|
||||||
: map-find ( seq quot -- result elt )
|
: map-find ( seq quot -- result elt )
|
||||||
f -rot
|
f -rot
|
||||||
|
@ -53,5 +53,5 @@ SYMBOL: tag-handler-word
|
||||||
|
|
||||||
: TAGS>
|
: TAGS>
|
||||||
tag-handler-word get
|
tag-handler-word get
|
||||||
tag-handlers get >alist [ >r dup name-tag r> case ] curry
|
tag-handlers get >alist [ >r dup main>> r> case ] curry
|
||||||
define ; parsing
|
define ; parsing
|
||||||
|
|
Loading…
Reference in New Issue