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

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

db4
Doug Coleman 2008-08-29 09:29:23 -05:00
parent 80f67f1ca7 783d0fcabf
commit b8fe50a75e
51 changed files with 319 additions and 235 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/generator/iterator/iterator.factor
View File

@ -37,9 +37,9 @@ DEFER: (tail-call?)
: tail-call? ( -- ? )
node-stack get [
rest-slice
dup [
dup empty? [ drop t ] [
[ (tail-call?) ]
[ first #terminate? not ]
bi and
] [ drop t ] if
] if
] all? ;

11
basis/compiler/tests/intrinsics.factor
View File

@ -450,3 +450,14 @@ cell 8 = [
[ 8 ] [
1 [ 3 fixnum-shift-fast ] compile-call
] 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

11
basis/compiler/tests/optimizer.factor
View File

@ -3,7 +3,7 @@ stack-checker kernel kernel.private math prettyprint sequences
sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer ;
compiler.tree.builder compiler.tree.optimizer sequences.deep ;
IN: optimizer.tests
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-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
: 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

2
basis/compiler/tests/redefine4.factor
View File

@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ 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

36
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sequences.deep combinators fry
classes.algebra namespaces assocs math math.private
math.partial-dispatch classes.tuple classes.tuple.private
definitions stack-checker.state stack-checker.branches
compiler.tree
classes.algebra namespaces assocs words math math.private
math.partial-dispatch math.intervals classes classes.tuple
classes.tuple.private layouts definitions stack-checker.state
stack-checker.branches compiler.tree
compiler.tree.intrinsics
compiler.tree.combinators
compiler.tree.propagation.info
@ -64,9 +64,19 @@ GENERIC: cleanup* ( node -- node/nodes )
{ fixnum-shift fixnum-shift-fast }
} 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 -- ? )
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 )
[ 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 )
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
dup live-children sift dup length 1 =
[ first swap in-d>> #drop prefix ] [ drop ] if ;
dup live-children sift dup length {
{ 0 [ 2drop f ] }
{ 1 [ first swap in-d>> #drop prefix ] }
[ 2drop ]
} case ;
SYMBOL: live-branches
@ -108,15 +121,18 @@ M: #branch cleanup*
[ live-branches>> live-branches set ]
} cleave ;
: output-fs ( values -- nodes )
[ f swap #push ] map ;
: eliminate-single-phi ( #phi -- node )
[ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
[ [ drop ] [ [ f swap #push ] map ] bi* ]
[ [ drop ] [ output-fs ] bi* ]
[ #copy ]
if ;
: eliminate-phi ( #phi -- node )
live-branches get sift length {
{ 0 [ drop f ] }
{ 0 [ out-d>> output-fs ] }
{ 1 [ eliminate-single-phi ] }
[ drop ]
} case ;

11
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -120,7 +120,7 @@ IN: compiler.tree.dead-code.tests
: call-recursive-dce-1 ( a -- b )
[ 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
] unit-test
@ -134,7 +134,7 @@ IN: compiler.tree.dead-code.tests
[ f call-recursive-dce-2 drop ] optimize-quot squish
] unit-test
[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
[ f call-recursive-dce-2 ] optimize-quot squish
] unit-test
@ -152,7 +152,7 @@ IN: compiler.tree.dead-code.tests
: call-recursive-dce-4 ( a -- b )
call-recursive-dce-4 ; inline recursive
[ [ "WRAP" [ "REC" ] label ] ] [
[ [ drop "WRAP" [ "REC" ] label ] ] [
[ call-recursive-dce-4 ] optimize-quot squish
] unit-test
@ -182,3 +182,8 @@ IN: compiler.tree.dead-code.tests
[ [ drop ] ] [ [ { integer } declare 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

47
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -13,11 +13,8 @@ M: #enter-recursive compute-live-values*
#! corresponding inputs to the #call-recursive are live also.
[ 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*
[ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
M: #call-recursive compute-live-values*
#! If the output of a #call-recursive is live, then the
@ -34,15 +31,6 @@ M: #call-recursive compute-live-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*
[ filter-live ] change-out-d ;
@ -73,9 +61,30 @@ M: #call-recursive remove-dead-code*
[ drop-call-recursive-outputs ]
tri 3array ;
M: #return-recursive remove-dead-code* ( node -- nodes )
dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs
[ drop [ filter-live ] change-out-d drop ]
[ out-d>> >>in-d drop ]
[ swap 2array ]
2tri ;
:: drop-recursive-inputs ( node -- shuffle )
[let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
new-outputs [ shuffle out-d>> ] |
node new-outputs
[ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
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* ;

15
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -1,7 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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.propagation.info
compiler.tree.dead-code.liveness ;
@ -80,11 +82,10 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
] ;
: drop-dead-outputs ( node -- nodes )
dup out-d>> drop-dead-values
[ in-d>> >>out-d drop ] [ 2array ] 2bi ;
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
M: #introduce remove-dead-code* ( #introduce -- nodes )
drop-dead-outputs ;
dup drop-dead-outputs 2array ;
M: #>r remove-dead-code*
[ filter-live ] change-out-r
@ -105,7 +106,9 @@ M: #push remove-dead-code*
] [ drop f ] if ;
: 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 -- ? )
out-d>> [ live-value? not ] contains? ;
@ -115,7 +118,7 @@ M: #call remove-dead-code*
remove-flushable-call
] [
dup some-outputs-dead? [
drop-dead-outputs
dup drop-dead-outputs 2array
] when
] if ;

6
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -7,7 +7,7 @@ compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple
compiler.tree.intrinsics namespaces compiler.tree.propagation.info
stack-checker.errors ;
stack-checker.errors kernel.private ;
\ escape-analysis must-infer
@ -316,3 +316,7 @@ C: <ro-box> ro-box
[ \ too-many->r boa f f \ inference-error boa ]
count-unboxed-allocations
] unit-test
[ 0 ] [
[ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
] unit-test

9
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -125,21 +125,20 @@ SYMBOL: history
: remember-inlining ( word -- )
history [ swap suffix ] change ;
: inline-word ( #call word -- )
: inline-word ( #call word -- ? )
dup history get memq? [
2drop
2drop f
] [
[
dup remember-inlining
dupd def>> splicing-nodes >>body
propagate-body
] with-scope
t
] if ;
: 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 -- ? )
{ curry compose } memq? ;
: always-inline-word ( #call word -- ? ) inline-word t ;

2
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -571,6 +571,8 @@ MIXIN: empty-mixin
[ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
[ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test

2
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -93,7 +93,7 @@ M: #declare propagate-before
: do-inlining ( #call word -- ? )
{
{ [ dup always-inline-word? ] [ always-inline-word ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }

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

@ -3,7 +3,7 @@
USING: accessors alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
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
alien.structs slots splitting assocs ;
IN: cpu.x86.64

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

@ -404,10 +404,8 @@ IN: cpu.x86.intrinsics
: %alien-integer-set ( quot reg -- )
small-reg PUSH
"offset" get "value" get = [
"value" operand %untag-fixnum
] unless
small-reg "value" operand MOV
small-reg %untag-fixnum
swap %alien-accessor
small-reg POP ; inline

2
basis/io/servers/connection/connection.factor
View File

@ -87,7 +87,7 @@ M: threaded-server handle-client* handler>> call ;
[ [ accept-connection ] with-semaphore ]
[ accept-connection ]
if*
] [ accept-loop ] bi ; inline
] [ accept-loop ] bi ; inline recursive
: started-accept-loop ( server -- )
threaded-server get

12
basis/stack-checker/inlining/inlining.factor
View File

@ -67,8 +67,10 @@ SYMBOL: enter-out
[ entry-stack-height current-stack-height swap - ]
bi*
= [ 2drop ] [
word>> current-stack-height
unbalanced-recursion-error inference-error
terminated? get [ 2drop ] [
word>> current-stack-height
unbalanced-recursion-error inference-error
] if
] if ;
: end-recursive-word ( word label -- )
@ -79,7 +81,7 @@ SYMBOL: enter-out
: recursive-word-inputs ( label -- n )
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
[
init-inference
@ -96,11 +98,13 @@ SYMBOL: enter-out
dup recursive-word-inputs
meta-d get
stack-visitor get
terminated? get
] with-scope ;
: inline-recursive-word ( word -- )
(inline-recursive-word)
[ consume-d ] [ output-d ] [ ] tri* #recursive, ;
[ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip
[ terminate ] when ;
: check-call-height ( label -- )
dup entry-stack-height current-stack-height >

2
basis/stack-checker/known-words/known-words.factor
View File

@ -331,7 +331,7 @@ SYMBOL: +primitive+
\ bignum-bitnot { bignum } { bignum } define-primitive
\ bignum-bitnot make-foldable
\ bignum-shift { bignum bignum } { bignum } define-primitive
\ bignum-shift { bignum fixnum } { bignum } define-primitive
\ bignum-shift make-foldable
\ bignum< { bignum bignum } { object } define-primitive

5
basis/stack-checker/stack-checker-tests.factor
View File

@ -575,3 +575,8 @@ DEFER: eee'
: eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
[ [ eee' ] infer ] [ inference-error? ] must-fail-with
: bogus-error ( x -- )
dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
[ bogus-error ] must-infer

5
basis/state-parser/state-parser.factor
View File

@ -88,13 +88,12 @@ SYMBOL: prolog-data
: next* ( -- )
get-char [ (next) record ] when ;
: skip-until ( quot -- )
#! quot: ( -- ? )
: skip-until ( quot: ( -- ? ) -- )
get-char [
[ call ] keep swap [ drop ] [
next skip-until
] if
] [ drop ] if ; inline
] [ drop ] if ; inline recursive
: take-until ( quot -- string )
#! Take the substring of a string starting at spot

14
basis/xml-rpc/xml-rpc.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel xml arrays math generic http.client combinators
hashtables namespaces io base64 sequences strings calendar
xml.data xml.writer xml.utilities assocs math.parser debugger
calendar.format math.order ;
USING: accessors kernel xml arrays math generic http.client
combinators hashtables namespaces io base64 sequences strings
calendar xml.data xml.writer xml.utilities assocs math.parser
debugger calendar.format math.order ;
IN: xml-rpc
! * Sending RPC requests
@ -17,7 +17,7 @@ M: integer item>xml
[ "Integers must fit in 32 bits" throw ] unless
number>string "i4" build-tag ;
PREDICATE: boolean < object { t f } member? ;
UNION: boolean t POSTPONE: f ;
M: boolean item>xml
"1" "0" ? "boolean" build-tag ;
@ -147,10 +147,10 @@ TAG: array xml>item
xml>item [ "faultCode" get "faultString" get ] bind ;
: receive-rpc ( xml -- rpc )
dup name-tag dup "methodCall" =
dup main>> dup "methodCall" =
[ drop parse-method <rpc-method> ] [
"methodResponse" = [
dup first-child-tag name-tag "fault" =
dup first-child-tag main>> "fault" =
[ parse-fault <rpc-fault> ]
[ parse-rpc-response <rpc-response> ] if
] [ "Bad main tag name" server-error ] if

81
basis/xml/data/data.factor
View File

@ -1,25 +1,26 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private assocs arrays
delegate.protocols delegate vectors ;
delegate.protocols delegate vectors accessors multiline
macros words quotations combinators ;
IN: xml.data
TUPLE: name space tag url ;
TUPLE: name space main url ;
C: <name> name
: ?= ( object/f object/f -- ? )
2dup and [ = ] [ 2drop t ] if ;
: names-match? ( name1 name2 -- ? )
[ name-space swap name-space ?= ] 2keep
[ name-url swap name-url ?= ] 2keep
name-tag swap name-tag ?= and and ;
[ [ space>> ] bi@ ?= ]
[ [ url>> ] bi@ ?= ]
[ [ main>> ] bi@ ?= ] 2tri and and ;
: <name-tag> ( string -- name )
: <simple-name> ( string -- name )
f swap f <name> ;
: assure-name ( string/name -- name )
dup name? [ <name-tag> ] unless ;
dup name? [ <simple-name> ] unless ;
TUPLE: opener name attrs ;
C: <opener> opener
@ -42,13 +43,11 @@ C: <instruction> instruction
TUPLE: prolog version encoding standalone ;
C: <prolog> prolog
TUPLE: tag attrs children ;
TUPLE: attrs alist ;
C: <attrs> attrs
: attr@ ( key alist -- index {key,value} )
>r assure-name r> attrs-alist
>r assure-name r> alist>>
[ first names-match? ] with find ;
M: attrs at*
@ -58,12 +57,12 @@ M: attrs set-at
2nip set-second
] [
>r assure-name swap 2array r>
[ attrs-alist ?push ] keep set-attrs-alist
[ alist>> ?push ] keep (>>alist)
] 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 >alist attrs-alist ;
M: attrs >alist alist>> ;
: >attrs ( assoc -- attrs )
dup [
@ -74,61 +73,71 @@ M: attrs assoc-like
drop dup attrs? [ >attrs ] unless ;
M: attrs clear-assoc
f swap set-attrs-alist ;
f >>alist drop ;
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
attrs-alist clone <attrs> ;
alist>> clone <attrs> ;
INSTANCE: attrs assoc
TUPLE: tag name attrs children ;
: <tag> ( name attrs children -- tag )
>r >r assure-name r> T{ attrs } assoc-like r>
{ set-delegate set-tag-attrs set-tag-children }
tag construct ;
[ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
tag boa ;
! For convenience, tags follow the assoc protocol too (for attrs)
CONSULT: assoc-protocol tag tag-attrs ;
INSTANCE: tag assoc
! They also follow the sequence protocol (for children)
CONSULT: sequence-protocol tag tag-children ;
CONSULT: sequence-protocol tag children>> ;
INSTANCE: tag sequence
CONSULT: name tag name>> ;
M: tag like
over tag? [ drop ] [
[ delegate ] keep tag-attrs
[ name>> ] keep tag-attrs
rot dup [ V{ } like ] when <tag>
] if ;
MACRO: clone-slots ( class -- tuple )
[
"slots" word-prop
[ reader>> 1quotation [ clone ] compose ] map
[ cleave ] curry
] [ [ boa ] curry ] bi compose ;
M: tag clone
[ delegate clone ] keep [ tag-attrs clone ] keep
tag-children clone
{ set-delegate set-tag-attrs set-tag-children } tag construct ;
tag clone-slots ;
TUPLE: xml prolog before main after ;
: <xml> ( prolog before main after -- xml )
{ set-xml-prolog set-xml-before set-delegate set-xml-after }
xml construct ;
TUPLE: xml prolog before body after ;
C: <xml> xml
CONSULT: sequence-protocol xml delegate ;
CONSULT: sequence-protocol xml body>> ;
INSTANCE: xml sequence
CONSULT: assoc-protocol xml delegate ;
CONSULT: assoc-protocol xml body>> ;
INSTANCE: xml assoc
CONSULT: tag xml body>> ;
CONSULT: name xml body>> ;
<PRIVATE
: 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 )
over delegate like tag>xml ;
over body>> like tag>xml ;
PRIVATE>
M: xml clone
[ xml-prolog clone ] keep [ xml-before clone ] keep
[ delegate clone ] keep xml-after clone <xml> ;
xml clone-slots ;
M: xml like
swap dup xml? [ nip ] [
@ -139,5 +148,5 @@ M: xml like
: <contained-tag> ( name attrs -- tag )
f <tag> ;
PREDICATE: contained-tag < tag tag-children not ;
PREDICATE: open-tag < tag tag-children ;
PREDICATE: contained-tag < tag children>> not ;
PREDICATE: open-tag < tag children>> ;

2
basis/xml/generator/generator.factor
View File

@ -27,7 +27,7 @@ IN: xml.generator
! Word-based XML literal syntax
: 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 )
>r [ ] like parsed r> [ parsed ] each ;

6
basis/xml/tests/templating.factor
View File

@ -1,5 +1,5 @@
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
: sub-tag
@ -11,7 +11,7 @@ GENERIC: (r-ref) ( xml -- )
M: tag (r-ref)
sub-tag over at* [
ref-table get at
swap set-tag-children
>>children drop
] [ 2drop ] if ;
M: object (r-ref) drop ;
@ -34,7 +34,7 @@ M: object (r-ref) drop ;
[
H{
{ "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 }
} ref-table set
sample-doc string>xml dup template xml>string

16
basis/xml/tests/test.factor
View File

@ -3,7 +3,7 @@
IN: xml.tests
USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
parser strings xml.data io.files xml.writer xml.utilities state-parser
continuations assocs sequences.deep ;
continuations assocs sequences.deep accessors ;
! This is insufficient
\ read-xml must-infer
@ -11,22 +11,22 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
SYMBOL: xml-file
[ ] [ "resource:basis/xml/tests/test.xml"
[ file>xml ] with-html-entities xml-file set ] unit-test
[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
[ "a" ] [ xml-file get name-space ] unit-test
[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test
[ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
[ f ] [ xml-file get prolog>> standalone>> ] unit-test
[ "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
] 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
[ T{ comment f "This is where the fun begins!" } ] [
xml-file get xml-before [ comment? ] find nip
] unit-test
[ "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
[ 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
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
[ "<a b='c'/>" string>xml xml>string ] unit-test

11
basis/xml/tokenize/tokenize.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: xml.errors xml.data xml.utilities xml.char-classes sets
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
! XML namespace processing: ns = namespace
@ -14,8 +15,8 @@ SYMBOL: ns-stack
! this should check to make sure URIs are valid
[
[
swap dup name-space "xmlns" =
[ name-tag set ]
swap dup space>> "xmlns" =
[ main>> set ]
[
T{ name f "" "xmlns" f } names-match?
[ "" set ] [ drop ] if
@ -24,8 +25,8 @@ SYMBOL: ns-stack
] { } make-assoc f like ;
: add-ns ( name -- )
dup name-space dup ns-stack get assoc-stack
[ nip ] [ <nonexist-ns> throw ] if* swap set-name-url ;
dup space>> dup ns-stack get assoc-stack
[ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
: push-ns ( hash -- )
ns-stack get push ;

21
basis/xml/utilities/utilities.factor
View File

@ -10,13 +10,13 @@ IN: xml.utilities
TUPLE: process-missing process tag ;
M: process-missing error.
"Tag <" write
dup process-missing-tag print-name
dup tag>> print-name
"> not implemented on process process " write
process-missing-process name>> print ;
name>> print ;
: run-process ( tag word -- )
2dup "xtable" word-prop
>r dup name-tag r> at* [ 2nip call ] [
>r dup main>> r> at* [ 2nip call ] [
drop \ process-missing boa throw
] if ;
@ -48,17 +48,18 @@ M: process-missing error.
standard-prolog { } rot { } <xml> ;
: children>string ( tag -- string )
tag-children {
children>> {
{ [ 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 ]
} cond ;
: children-tags ( tag -- sequence )
tag-children [ tag? ] filter ;
children>> [ tag? ] filter ;
: first-child-tag ( tag -- tag )
tag-children [ tag? ] find nip ;
children>> [ tag? ] find nip ;
! * Accessing part of an XML document
! 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 ;
: 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 )
assure-name [ tag-with-attr? ] 2curry deep-find ;
@ -109,8 +110,8 @@ M: process-missing error.
names-match? [ "Unexpected XML tag found" throw ] unless ;
: insert-children ( children tag -- )
dup tag-children [ push-all ]
[ >r V{ } like r> set-tag-children ] if ;
dup children>> [ push-all ]
[ swap V{ } like >>children drop ] if ;
: insert-child ( child tag -- )
>r 1vector r> insert-children ;

30
basis/xml/writer/writer.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
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 ;
IN: xml.writer
@ -38,9 +38,9 @@ SYMBOL: indenter
] when ;
: print-name ( name -- )
dup name-space f like
dup space>> f like
[ write CHAR: : write1 ] when*
name-tag write ;
main>> write ;
: print-attrs ( assoc -- )
[
@ -59,7 +59,7 @@ M: string write-item
: write-tag ( tag -- )
?indent CHAR: < write1
dup print-name tag-attrs print-attrs ;
dup print-name attrs>> print-attrs ;
: write-start-tag ( tag -- )
write-tag ">" write ;
@ -68,7 +68,7 @@ M: contained-tag write-item
write-tag "/>" write ;
: write-children ( tag -- )
indent tag-children ?filter-children
indent children>> ?filter-children
[ write-item ] each unindent ;
: write-end-tag ( tag -- )
@ -85,18 +85,18 @@ M: open-tag write-item
r> xml-pprint? set ;
M: comment write-item
"<!--" write comment-text write "-->" write ;
"<!--" write text>> write "-->" write ;
M: directive write-item
"<!" write directive-text write CHAR: > write1 ;
"<!" write text>> write CHAR: > write1 ;
M: instruction write-item
"<?" write instruction-text write "?>" write ;
"<?" write text>> write "?>" write ;
: write-prolog ( xml -- )
"<?xml version=\"" write dup prolog-version write
"\" encoding=\"" write dup prolog-encoding write
prolog-standalone [ "\" standalone=\"yes" write ] when
"<?xml version=\"" write dup version>> write
"\" encoding=\"" write dup encoding>> write
standalone>> [ "\" standalone=\"yes" write ] when
"\"?>" write ;
: write-chunk ( seq -- )
@ -104,10 +104,10 @@ M: instruction write-item
: write-xml ( xml -- )
{
[ xml-prolog write-prolog ]
[ xml-before write-chunk ]
[ write-item ]
[ xml-after write-chunk ]
[ prolog>> write-prolog ]
[ before>> write-chunk ]
[ body>> write-item ]
[ after>> write-chunk ]
} cleave ;
: print-xml ( xml -- )

22
basis/xml/xml.factor
View File

@ -38,19 +38,19 @@ M: directive process
add-child ;
M: contained process
[ contained-name ] keep contained-attrs
[ name>> ] [ attrs>> ] bi
<contained-tag> add-child ;
M: opener process push-xml ;
: check-closer ( name opener -- name opener )
dup [ <unopened> throw ] unless
2dup opener-name =
[ opener-name swap <mismatched> throw ] unless ;
2dup name>> =
[ name>> swap <mismatched> throw ] unless ;
M: closer process
closer-name pop-xml first2
>r check-closer opener-attrs r>
name>> pop-xml first2
>r check-closer attrs>> r>
<tag> add-child ;
: init-xml-stack ( -- )
@ -102,10 +102,10 @@ TUPLE: pull-xml scope ;
init-parser reset-prolog init-ns-stack
text-now? on
] H{ } make-assoc
{ set-pull-xml-scope } pull-xml construct ;
pull-xml boa ;
: pull-event ( pull -- xml-event/f )
pull-xml-scope [
scope>> [
text-now? get [ parse-text f ] [
get-char [ make-tag t ] [ f f ] if
] if text-now? set
@ -127,17 +127,17 @@ TUPLE: pull-xml scope ;
: call-under ( quot object -- quot )
swap dup slip ; inline
: sax-loop ( quot -- ) ! quot: xml-elem --
: sax-loop ( quot: ( xml-elem -- ) -- )
parse-text call-under
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 [
reset-prolog init-ns-stack
prolog-data get call-under
sax-loop
] state-parse ; inline
] state-parse ; inline recursive
: (read-xml) ( -- )
[ process ] sax-loop ; inline

4
core/classes/mixin/mixin-tests.factor
View File

@ -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
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
MIXIN: empty-mixin
[ f ] [ "hi" empty-mixin? ] unit-test

4
core/classes/mixin/mixin.factor
View File

@ -20,7 +20,9 @@ M: mixin-class rank-class drop 3 ;
dup mixin-class? [
drop
] [
{ } redefine-mixin-class
[ { } redefine-mixin-class ]
[ update-classes ]
bi
] if ;
TUPLE: check-mixin-class mixin ;

3
core/classes/tuple/tuple.factor
View File

@ -270,6 +270,9 @@ M: tuple-class define-tuple-class
tri* define-declared
] 3tri ;
M: tuple-class update-generic
over new-class? [ 2drop ] [ call-next-method ] if ;
M: tuple-class reset-class
[
dup "slots" word-prop [

4
core/generic/generic.factor
View File

@ -62,7 +62,9 @@ TUPLE: check-method class generic ;
[ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
values ;
: update-generic ( class generic -- )
GENERIC# update-generic 1 ( class generic -- )
M: class update-generic
affected-methods [ +called+ changed-definition ] each ;
: with-methods ( class generic quot -- )

2
core/io/binary/binary-tests.factor
View File

@ -2,7 +2,9 @@ USING: io.binary tools.test classes math ;
IN: io.binary.tests
[ 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 0 0 0 0 } ] [ 1234 8 >le ] unit-test
[ 1234 ] [ 1234 4 >be be> ] unit-test
[ 1234 ] [ 1234 4 >le le> ] unit-test

2
core/parser/parser.factor
View File

@ -24,7 +24,7 @@ t parser-notes set-global
: note. ( str -- )
parser-notes? [
file get [ path>> write ] when*
file get [ path>> write ":" write ] when*
lexer get line>> number>string write ": " write
"Note: " write dup print
] when drop ;

4
extra/db/db.factor
View File

@ -96,12 +96,12 @@ M: object execute-statement* ( statement type -- )
: sql-row-typed ( result-set -- seq )
dup #columns [ row-column-typed ] with map ;
: query-each ( statement quot -- )
: query-each ( statement quot: ( statement -- ) -- )
over more-rows? [
[ call ] 2keep over advance-row query-each
] [
2drop
] if ; inline
] if ; inline recursive
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline

2
extra/db/queries/queries.factor
View File

@ -14,7 +14,7 @@ GENERIC: where ( specs obj -- )
: query-make ( class quot -- )
>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
M: db begin-transaction ( -- ) "BEGIN" sql-command ;

11
extra/html/templates/chloe/chloe.factor
View File

@ -28,6 +28,7 @@ DEFER: process-template
[ drop name-url chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
dup xml? [ body>> ] when
{
{ [ dup tag? not ] [ f ] }
{ [ dup url>> chloe-ns = not ] [ f ] }
@ -112,12 +113,12 @@ CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
: process-chloe-tag ( tag -- )
dup name-tag dup tags get at
dup main>> dup tags get at
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
: process-tag ( tag -- )
{
[ name-tag >lower tag-stack get push ]
[ main>> >lower tag-stack get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
@ -125,7 +126,7 @@ CHLOE-TUPLE: code
} cleave ;
: expand-attrs ( tag -- tag )
dup [ tag? ] is? [
dup [ tag? ] [ xml? ] bi or [
clone [
[ "@" ?head [ value present ] when ] assoc-map
] change-attrs
@ -134,8 +135,8 @@ CHLOE-TUPLE: code
: process-template ( xml -- )
expand-attrs
{
{ [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] is? ] [ process-tag ] }
{ [ dup chloe-tag? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
{ [ t ] [ write-item ] }
} cond ;

4
extra/html/templates/chloe/syntax/syntax.factor
View File

@ -23,7 +23,7 @@ tags global [ H{ } clone or ] change-at
MEMO: chloe-name ( string -- name )
name new
swap >>tag
swap >>main
chloe-ns >>url ;
: required-attr ( tag name -- value )
@ -45,7 +45,7 @@ MEMO: chloe-name ( string -- name )
: attrs>slots ( tag tuple -- )
[ attrs>> ] [ <mirror> ] bi*
'[
swap tag>> dup "name" =
swap main>> dup "name" =
[ 2drop ] [ , set-at ] if
] assoc-each ;

4
extra/inverse/inverse-tests.factor
View File

@ -62,10 +62,10 @@ C: <nil> nil
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
: 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
[ 1 2 ] [ 2 1 <cons> [ cons* ] undo ] unit-test
[ 1 2 ] [ 1 2 <cons> [ cons* ] undo ] unit-test
[ t ] [ pi [ pi ] matches? ] unit-test
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test

2
extra/io/files/unique/unique-tests.factor
View File

@ -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
[ 123 ] [

16
extra/math/bitfields/lib/lib.factor
View File

@ -1,14 +1,14 @@
USING: hints kernel math ;
IN: math.bitfields.lib
: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
: set-bit ( x n -- y ) 2^ bitor ; foldable
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
: unmask ( x n -- ? ) bitnot bitand ; foldable
: unmask? ( x n -- ? ) unmask 0 > ; foldable
: mask ( x n -- ? ) bitand ; foldable
: mask? ( x n -- ? ) mask 0 > ; foldable
: wrap ( m n -- m' ) 1- bitand ; foldable
: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
: set-bit ( x n -- y ) 2^ bitor ; inline
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
: unmask ( x n -- ? ) bitnot bitand ; inline
: unmask? ( x n -- ? ) unmask 0 > ; inline
: mask ( x n -- ? ) bitand ; inline
: mask? ( x n -- ? ) mask 0 > ; inline
: wrap ( m n -- m' ) 1- bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 1- 2^ mask ; inline

6
extra/math/matrices/elimination/elimination.factor
View File

@ -31,10 +31,10 @@ SYMBOL: matrix
>r over r> nth dup zero? [
3drop 0
] [
>r nth dup zero? [
r> 2drop 0
>r nth dup zero? r> swap [
2drop 0
] [
r> swap / neg
swap / neg
] if
] if ;

4
extra/namespaces/lib/lib-tests.factor
View File

@ -1,6 +1,8 @@
IN: namespaces.lib.tests
USING: namespaces.lib tools.test ;
USING: namespaces.lib kernel tools.test ;
[ ] [ [ ] { } nmake ] unit-test
[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test
[ [ ] [ call ] curry { { } } nmake ] must-infer

32
extra/namespaces/lib/lib.factor
View File

@ -1,8 +1,6 @@
! USING: kernel quotations namespaces sequences assocs.lib ;
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
@ -42,22 +40,20 @@ SYMBOL: building-seq
: 4% ( seq -- ) 4 n% ;
: 4# ( num -- ) 4 n# ;
MACRO:: nmake ( quot exemplars -- )
[let | n [ exemplars length ] |
[
[
exemplars
[ 0 swap new-resizable ] map
building-seq set
MACRO: finish-nmake ( exemplars -- )
length [ firstn ] curry ;
quot call
:: nmake ( quot exemplars -- )
[
exemplars
[ 0 swap new-resizable ] map
building-seq set
building-seq get
exemplars [ like ] 2map
n firstn
] with-scope
]
] ;
quot call
building-seq get
exemplars [ [ like ] 2map ] [ finish-nmake ] bi
] with-scope ; inline
: make-object ( quot class -- object )
new [ <mirror> swap bind ] keep ; inline

2
extra/sequences/lib/lib.factor
View File

@ -193,7 +193,7 @@ USE: continuations
[
iterate-step roll
[ 3nip ] [ iterate-next (attempt-each-integer) ] if*
] [ 3drop f ] if-iterate? ; inline
] [ 3drop f ] if-iterate? ; inline recursive
PRIVATE>
: attempt-each ( seq quot -- result )

6
extra/syndication/syndication.factor
View File

@ -76,8 +76,8 @@ TUPLE: entry title url description date ;
[ "link" tag-named "href" swap at >url >>url ]
[
{ "content" "summary" } any-tag-named
dup tag-children [ string? not ] contains?
[ tag-children [ write-chunk ] with-string-writer ]
dup children>> [ string? not ] contains?
[ children>> [ write-chunk ] with-string-writer ]
[ children>string ] if >>description
]
[
@ -96,7 +96,7 @@ TUPLE: entry title url description date ;
tri ;
: xml>feed ( xml -- feed )
dup name-tag {
dup main>> {
{ "RDF" [ rss1.0 ] }
{ "rss" [ rss2.0 ] }
{ "feed" [ atom1.0 ] }

6
extra/xmode/loader/syntax/syntax.factor
View File

@ -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
math.parser namespaces parser lexer xmode.utilities regexp io.files ;
IN: xmode.loader.syntax
@ -7,7 +7,7 @@ SYMBOL: ignore-case?
! Rule tag parsing utilities
: (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:
scan scan-word
@ -98,4 +98,4 @@ TAGS>
: init-eol-span-tag ( -- ) [ drop init-eol-span ] , ;
: 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 ;

11
extra/xmode/marker/context/context.factor
View File

@ -1,4 +1,4 @@
USING: kernel ;
USING: accessors kernel ;
IN: xmode.marker.context
! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
@ -11,10 +11,9 @@ end
: <line-context> ( ruleset parent -- line-context )
over [ "no context" throw ] unless
{ set-line-context-in-rule-set set-line-context-parent }
line-context construct ;
line-context new
swap >>parent
swap >>in-rule-set ;
M: line-context clone
(clone)
dup line-context-parent clone
over set-line-context-parent ;
call-next-method [ clone ] change-parent ;

18
extra/xmode/rules/rules.factor
View File

@ -66,14 +66,11 @@ delegate
chars
;
: construct-rule ( class -- rule )
>r rule new r> construct-delegate ; inline
TUPLE: seq-rule < rule ;
TUPLE: seq-rule ;
TUPLE: span-rule < rule ;
TUPLE: span-rule ;
TUPLE: eol-span-rule ;
TUPLE: eol-span-rule < rule ;
: init-span ( rule -- )
dup rule-delegate [ drop ] [
@ -85,16 +82,15 @@ TUPLE: eol-span-rule ;
dup init-span
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 )
f <string-matcher> f f f <matcher>
escape-rule construct-rule
[ set-rule-start ] keep ;
escape-rule new swap >>start ;
GENERIC: text-hash-char ( text -- ch )

8
extra/xmode/utilities/utilities-tests.factor
View File

@ -1,7 +1,7 @@
IN: xmode.utilities.tests
USING: xmode.utilities tools.test xml xml.data kernel strings
vectors sequences io.files prettyprint assocs unicode.case ;
USING: accessors xmode.utilities tools.test xml xml.data kernel
strings vectors sequences io.files prettyprint assocs
unicode.case ;
[ "hi" 3 ] [
{ 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
] unit-test
@ -35,7 +35,7 @@ TAGS>
{ { "type" >upper set-company-type } }
init-from-tag dup
] keep
tag-children [ tag? ] filter
children>> [ tag? ] filter
[ parse-employee-tag ] with each ;
[

8
extra/xmode/utilities/utilities.factor
View File

@ -1,10 +1,10 @@
USING: sequences assocs kernel quotations namespaces xml.data
xml.utilities combinators macros parser lexer words ;
USING: accessors sequences assocs kernel quotations namespaces
xml.data xml.utilities combinators macros parser lexer words ;
IN: xmode.utilities
: 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 )
f -rot
@ -53,5 +53,5 @@ SYMBOL: tag-handler-word
: TAGS>
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