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

db4
Doug Coleman 2008-08-29 09:29:23 -05:00
commit b8fe50a75e
51 changed files with 319 additions and 235 deletions

View File

@ -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? ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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* ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ] }

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 >

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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>> ;

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 -- )

View File

@ -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

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 [ ] [ "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

View File

@ -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 ;

View File

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

View File

@ -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 -- )

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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

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 IN: io.files.unique.tests
[ 123 ] [ [ 123 ] [

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 )

View File

@ -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 ] }

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 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 ;

View File

@ -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 ;

View File

@ -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 )

View File

@ -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 ;
[ [

View File

@ -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