Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
15a7148de0
|
|
@ -1,4 +1,4 @@
|
|||
USING: biassocs assocs namespaces tools.test ;
|
||||
USING: biassocs assocs namespaces tools.test hashtables kernel ;
|
||||
IN: biassocs.tests
|
||||
|
||||
<bihash> "h" set
|
||||
|
|
@ -30,3 +30,13 @@ H{ { "a" "A" } { "b" "B" } } "a" set
|
|||
[ "A" ] [ "a" "b" get at ] unit-test
|
||||
|
||||
[ "a" ] [ "A" "b" get value-at ] unit-test
|
||||
|
||||
[ ] [ H{ { 1 2 } } >biassoc "h" set ] unit-test
|
||||
|
||||
[ ] [ "h" get clone "g" set ] unit-test
|
||||
|
||||
[ ] [ 3 4 "g" get set-at ] unit-test
|
||||
|
||||
[ H{ { 1 2 } } ] [ "h" get >hashtable ] unit-test
|
||||
|
||||
[ H{ { 1 2 } { 4 3 } } ] [ "g" get >hashtable ] unit-test
|
||||
|
|
|
|||
|
|
@ -43,4 +43,7 @@ M: biassoc new-assoc
|
|||
INSTANCE: biassoc assoc
|
||||
|
||||
: >biassoc ( assoc -- biassoc )
|
||||
T{ biassoc } assoc-clone-like ;
|
||||
T{ biassoc } assoc-clone-like ;
|
||||
|
||||
M: biassoc clone
|
||||
[ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ;
|
||||
|
|
|
|||
|
|
@ -44,33 +44,33 @@ PRIVATE>
|
|||
: <bit-array> ( n -- bit-array )
|
||||
dup bits>bytes <byte-array> bit-array boa ; inline
|
||||
|
||||
M: bit-array length length>> ;
|
||||
M: bit-array length length>> ; inline
|
||||
|
||||
M: bit-array nth-unsafe
|
||||
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ;
|
||||
[ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; inline
|
||||
|
||||
M: bit-array set-nth-unsafe
|
||||
[ >fixnum ] [ underlying>> ] bi*
|
||||
[ byte/bit set-bit ] 2keep
|
||||
swap n>byte set-alien-unsigned-1 ;
|
||||
swap n>byte set-alien-unsigned-1 ; inline
|
||||
|
||||
GENERIC: clear-bits ( bit-array -- )
|
||||
|
||||
M: bit-array clear-bits 0 (set-bits) ;
|
||||
M: bit-array clear-bits 0 (set-bits) ; inline
|
||||
|
||||
GENERIC: set-bits ( bit-array -- )
|
||||
|
||||
M: bit-array set-bits -1 (set-bits) ;
|
||||
M: bit-array set-bits -1 (set-bits) ; inline
|
||||
|
||||
M: bit-array clone
|
||||
[ length>> ] [ underlying>> clone ] bi bit-array boa ;
|
||||
[ length>> ] [ underlying>> clone ] bi bit-array boa ; inline
|
||||
|
||||
: >bit-array ( seq -- bit-array )
|
||||
T{ bit-array f 0 B{ } } clone-like ; inline
|
||||
|
||||
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
|
||||
M: bit-array like drop dup bit-array? [ >bit-array ] unless ; inline
|
||||
|
||||
M: bit-array new-sequence drop <bit-array> ;
|
||||
M: bit-array new-sequence drop <bit-array> ; inline
|
||||
|
||||
M: bit-array equal?
|
||||
over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
|
||||
|
|
@ -81,7 +81,7 @@ M: bit-array resize
|
|||
resize-byte-array
|
||||
] 2bi
|
||||
bit-array boa
|
||||
dup clean-up ;
|
||||
dup clean-up ; inline
|
||||
|
||||
M: bit-array byte-length length 7 + -3 shift ;
|
||||
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
|||
} cond ;
|
||||
|
||||
: optimize? ( word -- ? )
|
||||
{ [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
|
||||
single-generic? not ;
|
||||
|
||||
: contains-breakpoints? ( -- ? )
|
||||
dependencies get keys [ "break?" word-prop ] any? ;
|
||||
|
|
|
|||
|
|
@ -5,11 +5,11 @@ IN: compiler.tests.redefine3
|
|||
|
||||
GENERIC: sheeple ( obj -- x )
|
||||
|
||||
M: object sheeple drop "sheeple" ;
|
||||
M: object sheeple drop "sheeple" ; inline
|
||||
|
||||
MIXIN: empty-mixin
|
||||
|
||||
M: empty-mixin sheeple drop "wake up" ;
|
||||
M: empty-mixin sheeple drop "wake up" ; inline
|
||||
|
||||
: sheeple-test ( -- string ) { } sheeple ;
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ IN: compiler.tests.stack-trace
|
|||
[ baz ] [ 3 = ] must-fail-with
|
||||
[ t ] [
|
||||
symbolic-stack-trace
|
||||
[ word? ] filter
|
||||
2 head*
|
||||
{ baz bar foo } tail?
|
||||
] unit-test
|
||||
|
||||
|
|
@ -24,7 +24,7 @@ IN: compiler.tests.stack-trace
|
|||
[ t ] [
|
||||
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
|
||||
] unit-test
|
||||
|
||||
|
||||
[ t f ] [
|
||||
[ { "hi" } bleh ] ignore-errors
|
||||
\ + stack-trace-any?
|
||||
|
|
|
|||
|
|
@ -41,13 +41,13 @@ IN: compiler.tree.cleanup.tests
|
|||
|
||||
GENERIC: mynot ( x -- y )
|
||||
|
||||
M: f mynot drop t ;
|
||||
M: f mynot drop t ; inline
|
||||
|
||||
M: object mynot drop f ;
|
||||
M: object mynot drop f ; inline
|
||||
|
||||
GENERIC: detect-f ( x -- y )
|
||||
|
||||
M: f detect-f ;
|
||||
M: f detect-f ; inline
|
||||
|
||||
[ t ] [
|
||||
[ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
|
||||
|
|
@ -55,9 +55,9 @@ M: f detect-f ;
|
|||
|
||||
GENERIC: xyz ( n -- n )
|
||||
|
||||
M: integer xyz ;
|
||||
M: integer xyz ; inline
|
||||
|
||||
M: object xyz ;
|
||||
M: object xyz ; inline
|
||||
|
||||
[ t ] [
|
||||
[ { integer } declare xyz ] \ xyz inlined?
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences words memoize combinators
|
||||
classes classes.builtin classes.tuple math.partial-dispatch
|
||||
fry assocs combinators.short-circuit
|
||||
classes classes.builtin classes.tuple classes.singleton
|
||||
math.partial-dispatch fry assocs combinators.short-circuit
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -45,6 +45,7 @@ M: predicate finalize-word
|
|||
"predicating" word-prop {
|
||||
{ [ dup builtin-class? ] [ drop word>> cached-expansion ] }
|
||||
{ [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
|
||||
{ [ dup singleton-class? ] [ drop word>> def>> splice-final ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -153,7 +153,7 @@ ERROR: uninferable ;
|
|||
|
||||
: (value>quot) ( value-info -- quot )
|
||||
dup class>> {
|
||||
{ \ quotation [ literal>> dup remember-inlining '[ drop @ ] ] }
|
||||
{ \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
|
||||
{ \ curry [
|
||||
slots>> third (value>quot)
|
||||
'[ [ obj>> ] [ quot>> @ ] bi ]
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: accessors kernel arrays sequences math math.order
|
||||
math.partial-dispatch generic generic.standard generic.single generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry combinators.smart hints
|
||||
locals
|
||||
combinators.short-circuit words namespaces continuations classes
|
||||
fry hints locals
|
||||
compiler.tree
|
||||
compiler.tree.builder
|
||||
compiler.tree.recursive
|
||||
|
|
@ -14,19 +14,6 @@ compiler.tree.propagation.info
|
|||
compiler.tree.propagation.nodes ;
|
||||
IN: compiler.tree.propagation.inlining
|
||||
|
||||
! We count nodes up-front; if there are relatively few nodes,
|
||||
! we are more eager to inline
|
||||
SYMBOL: node-count
|
||||
|
||||
: count-nodes ( nodes -- n )
|
||||
0 swap [ drop 1 + ] each-node ;
|
||||
|
||||
: compute-node-count ( nodes -- ) count-nodes node-count set ;
|
||||
|
||||
! We try not to inline the same word too many times, to avoid
|
||||
! combinatorial explosion
|
||||
SYMBOL: inlining-count
|
||||
|
||||
! Splicing nodes
|
||||
: splicing-call ( #call word -- nodes )
|
||||
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
|
||||
|
|
@ -101,99 +88,28 @@ M: callable splicing-nodes splicing-body ;
|
|||
dupd inlining-math-partial eliminate-dispatch ;
|
||||
|
||||
! Method body inlining
|
||||
SYMBOL: recursive-calls
|
||||
DEFER: (flat-length)
|
||||
|
||||
: word-flat-length ( word -- n )
|
||||
{
|
||||
! special-case
|
||||
{ [ dup { dip 2dip 3dip } memq? ] [ drop 1 ] }
|
||||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! recursive and inline
|
||||
{ [ dup recursive-calls get key? ] [ drop 10 ] }
|
||||
! inline
|
||||
[ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
|
||||
} cond ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ (flat-length) 2 + ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
[ drop 0 ]
|
||||
} cond
|
||||
] sigma ;
|
||||
|
||||
: flat-length ( word -- n )
|
||||
H{ } clone recursive-calls [
|
||||
[ recursive-calls get conjoin ]
|
||||
[ def>> (flat-length) 5 /i ]
|
||||
bi
|
||||
] with-variable ;
|
||||
|
||||
: classes-known? ( #call -- ? )
|
||||
in-d>> [
|
||||
value-info class>>
|
||||
[ class-types length 1 = ]
|
||||
[ union-class? not ]
|
||||
bi and
|
||||
] any? ;
|
||||
|
||||
: node-count-bias ( -- n )
|
||||
45 node-count get [-] 8 /i ;
|
||||
|
||||
: body-length-bias ( word -- n )
|
||||
[ flat-length ] [ inlining-count get at 0 or ] bi
|
||||
over 2 <= [ drop ] [ 2/ 1 + * ] if 24 swap [-] 4 /i ;
|
||||
|
||||
: inlining-rank ( #call word -- n )
|
||||
[
|
||||
[ classes-known? 2 0 ? ]
|
||||
[
|
||||
[ body-length-bias ]
|
||||
[ "specializer" word-prop 1 0 ? ]
|
||||
[ method-body? 1 0 ? ]
|
||||
tri
|
||||
node-count-bias
|
||||
loop-nesting get 0 or 2 *
|
||||
] bi*
|
||||
] sum-outputs ;
|
||||
|
||||
: should-inline? ( #call word -- ? )
|
||||
dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
|
||||
|
||||
SYMBOL: history
|
||||
|
||||
: already-inlined? ( obj -- ? ) history get memq? ;
|
||||
|
||||
: add-to-history ( obj -- ) history [ swap suffix ] change ;
|
||||
|
||||
: remember-inlining ( word -- )
|
||||
[ inlining-count get inc-at ]
|
||||
[ add-to-history ]
|
||||
bi ;
|
||||
|
||||
:: inline-word ( #call word -- ? )
|
||||
word already-inlined? [ f ] [
|
||||
#call word splicing-body [
|
||||
[
|
||||
word remember-inlining
|
||||
[ ] [ count-nodes ] [ (propagate) ] tri
|
||||
word add-to-history
|
||||
dup (propagate)
|
||||
] with-scope
|
||||
[ #call (>>body) ] [ node-count +@ ] bi* t
|
||||
#call (>>body) t
|
||||
] [ f ] if*
|
||||
] if ;
|
||||
|
||||
: inline-method-body ( #call word -- ? )
|
||||
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
|
||||
|
||||
: always-inline-word? ( word -- ? )
|
||||
{ curry compose } memq? ;
|
||||
|
||||
: never-inline-word? ( word -- ? )
|
||||
[ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
|
||||
{ [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ;
|
||||
|
||||
: custom-inlining? ( word -- ? )
|
||||
"custom-inlining" word-prop ;
|
||||
|
|
@ -217,7 +133,7 @@ SYMBOL: history
|
|||
{ [ dup always-inline-word? ] [ inline-word ] }
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ dup method-body? ] [ inline-method-body ] }
|
||||
{ [ dup inline? ] [ inline-word ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel effects accessors math math.private
|
||||
math.integers.private math.partial-dispatch math.intervals
|
||||
math.parser math.order layouts words sequences sequences.private
|
||||
math.parser math.order math.functions layouts words sequences sequences.private
|
||||
arrays assocs classes classes.algebra combinators generic.math
|
||||
splitting fry locals classes.tuple alien.accessors
|
||||
classes.tuple.private slots.private definitions strings.private
|
||||
|
|
@ -41,6 +41,8 @@ IN: compiler.tree.propagation.known-words
|
|||
|
||||
\ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
|
||||
|
||||
\ absq [ [ interval-absq ] ?change-interval ] "outputs" set-word-prop
|
||||
|
||||
: math-closure ( class -- newclass )
|
||||
{ fixnum bignum integer rational float real number object }
|
||||
[ class<= ] with find nip ;
|
||||
|
|
|
|||
|
|
@ -157,6 +157,18 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test
|
||||
|
||||
[ t ] [ [ abs ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
|
||||
|
||||
[ V{ string } ] [
|
||||
[ dup string? not [ "Oops" throw ] [ ] if ] final-classes
|
||||
] unit-test
|
||||
|
|
@ -444,6 +456,13 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
|||
] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ f { } } ] [
|
||||
[
|
||||
T{ mixed-mutable-immutable f 3 { } }
|
||||
[ x>> ] [ y>> ] bi
|
||||
] final-literals
|
||||
] unit-test
|
||||
|
||||
! Recursive propagation
|
||||
: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
|
||||
|
||||
|
|
@ -502,8 +521,8 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
|||
] unit-test
|
||||
|
||||
GENERIC: iterate ( obj -- next-obj ? )
|
||||
M: fixnum iterate f ;
|
||||
M: array iterate first t ;
|
||||
M: fixnum iterate f ; inline
|
||||
M: array iterate first t ; inline
|
||||
|
||||
: dead-loop ( obj -- final-obj )
|
||||
iterate [ dead-loop ] when ; inline recursive
|
||||
|
|
@ -567,7 +586,7 @@ M: array iterate first t ;
|
|||
] unit-test
|
||||
|
||||
GENERIC: bad-generic ( a -- b )
|
||||
M: fixnum bad-generic 1 fixnum+fast ;
|
||||
M: fixnum bad-generic 1 fixnum+fast ; inline
|
||||
: bad-behavior ( -- b ) 4 bad-generic ; inline recursive
|
||||
|
||||
[ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
|
||||
|
|
@ -740,7 +759,7 @@ TUPLE: foo bar ;
|
|||
[ t ] [ [ foo new ] { new } inlined? ] unit-test
|
||||
|
||||
GENERIC: whatever ( x -- y )
|
||||
M: number whatever drop foo ;
|
||||
M: number whatever drop foo ; inline
|
||||
|
||||
[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
|
||||
|
||||
|
|
@ -749,8 +768,8 @@ M: number whatever drop foo ;
|
|||
[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
|
||||
|
||||
GENERIC: whatever2 ( x -- y )
|
||||
M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
|
||||
M: f whatever2 ;
|
||||
M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline
|
||||
M: f whatever2 ; inline
|
||||
|
||||
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||
|
|
|
|||
|
|
@ -19,6 +19,4 @@ IN: compiler.tree.propagation
|
|||
H{ } clone copies set
|
||||
H{ } clone 1array value-infos set
|
||||
H{ } clone 1array constraints set
|
||||
H{ } clone inlining-count set
|
||||
dup compute-node-count
|
||||
dup (propagate) ;
|
||||
|
|
|
|||
|
|
@ -119,7 +119,9 @@ M: #declare propagate-before
|
|||
M: #call propagate-before
|
||||
dup word>> {
|
||||
{ [ 2dup foldable-call? ] [ fold-call ] }
|
||||
{ [ 2dup do-inlining ] [ 2drop ] }
|
||||
{ [ 2dup do-inlining ] [
|
||||
[ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos
|
||||
] }
|
||||
[
|
||||
[ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
|
||||
[ compute-constraints ]
|
||||
|
|
|
|||
|
|
@ -18,41 +18,41 @@ GENERIC: group@ ( n groups -- from to seq )
|
|||
|
||||
M: chunking-seq set-nth group@ <slice> 0 swap copy ;
|
||||
|
||||
M: chunking-seq like drop { } like ;
|
||||
M: chunking-seq like drop { } like ; inline
|
||||
|
||||
INSTANCE: chunking-seq sequence
|
||||
|
||||
MIXIN: subseq-chunking
|
||||
|
||||
M: subseq-chunking nth group@ subseq ;
|
||||
M: subseq-chunking nth group@ subseq ; inline
|
||||
|
||||
MIXIN: slice-chunking
|
||||
|
||||
M: slice-chunking nth group@ <slice> ;
|
||||
M: slice-chunking nth group@ <slice> ; inline
|
||||
|
||||
M: slice-chunking nth-unsafe group@ slice boa ;
|
||||
M: slice-chunking nth-unsafe group@ slice boa ; inline
|
||||
|
||||
TUPLE: abstract-groups < chunking-seq ;
|
||||
|
||||
M: abstract-groups length
|
||||
[ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ;
|
||||
[ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
|
||||
|
||||
M: abstract-groups set-length
|
||||
[ n>> * ] [ seq>> ] bi set-length ;
|
||||
[ n>> * ] [ seq>> ] bi set-length ; inline
|
||||
|
||||
M: abstract-groups group@
|
||||
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
|
||||
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
|
||||
|
||||
TUPLE: abstract-clumps < chunking-seq ;
|
||||
|
||||
M: abstract-clumps length
|
||||
[ seq>> length ] [ n>> ] bi - 1 + ;
|
||||
[ seq>> length ] [ n>> ] bi - 1 + ; inline
|
||||
|
||||
M: abstract-clumps set-length
|
||||
[ n>> + 1 - ] [ seq>> ] bi set-length ;
|
||||
[ n>> + 1 - ] [ seq>> ] bi set-length ; inline
|
||||
|
||||
M: abstract-clumps group@
|
||||
[ n>> over + ] [ seq>> ] bi ;
|
||||
[ n>> over + ] [ seq>> ] bi ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -71,7 +71,8 @@ t specialize-method? set-global
|
|||
SYNTAX: HINTS:
|
||||
scan-object dup wrapper? [ wrapped>> ] when
|
||||
[ changed-definition ]
|
||||
[ parse-definition { } like "specializer" set-word-prop ] bi ;
|
||||
[ subwords [ changed-definition ] each ]
|
||||
[ parse-definition { } like "specializer" set-word-prop ] tri ;
|
||||
|
||||
! Default specializers
|
||||
{ first first2 first3 first4 }
|
||||
|
|
|
|||
|
|
@ -4,23 +4,36 @@ USING: alien alien.c-types arrays destructors io io.backend
|
|||
io.buffers io.files io.ports io.binary io.timeouts system
|
||||
strings kernel math namespaces sequences windows.errors
|
||||
windows.kernel32 windows.shell32 windows.types windows.winsock
|
||||
splitting continuations math.bitwise accessors ;
|
||||
splitting continuations math.bitwise accessors init sets assocs ;
|
||||
IN: io.backend.windows
|
||||
|
||||
: win32-handles ( -- assoc )
|
||||
\ win32-handles [ H{ } clone ] initialize-alien ;
|
||||
|
||||
TUPLE: win32-handle < identity-tuple handle disposed ;
|
||||
|
||||
M: win32-handle hashcode* handle>> hashcode* ;
|
||||
|
||||
: set-inherit ( handle ? -- )
|
||||
[ HANDLE_FLAG_INHERIT ] dip
|
||||
[ handle>> HANDLE_FLAG_INHERIT ] dip
|
||||
>BOOLEAN SetHandleInformation win32-error=0/f ;
|
||||
|
||||
TUPLE: win32-handle handle disposed ;
|
||||
|
||||
: new-win32-handle ( handle class -- win32-handle )
|
||||
new swap [ >>handle ] [ f set-inherit ] bi ;
|
||||
new swap >>handle
|
||||
dup f set-inherit
|
||||
dup win32-handles conjoin ;
|
||||
|
||||
: <win32-handle> ( handle -- win32-handle )
|
||||
win32-handle new-win32-handle ;
|
||||
|
||||
ERROR: disposing-twice ;
|
||||
|
||||
: unregister-handle ( handle -- )
|
||||
win32-handles delete-at*
|
||||
[ t >>disposed drop ] [ disposing-twice ] if ;
|
||||
|
||||
M: win32-handle dispose* ( handle -- )
|
||||
handle>> CloseHandle drop ;
|
||||
[ unregister-handle ] [ handle>> CloseHandle win32-error=0/f ] bi ;
|
||||
|
||||
TUPLE: win32-file < win32-handle ptr ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ PRIVATE>
|
|||
SINGLETON: ascii
|
||||
|
||||
M: ascii encode-char
|
||||
128 encode-if< ;
|
||||
128 encode-if< ; inline
|
||||
|
||||
M: ascii decode-char
|
||||
128 decode-if< ;
|
||||
128 decode-if< ; inline
|
||||
|
|
|
|||
|
|
@ -47,10 +47,8 @@ IN: io.files.windows
|
|||
GetLastError ERROR_ALREADY_EXISTS = not ;
|
||||
|
||||
: set-file-pointer ( handle length method -- )
|
||||
[ dupd d>w/w <uint> ] dip SetFilePointer
|
||||
INVALID_SET_FILE_POINTER = [
|
||||
CloseHandle "SetFilePointer failed" throw
|
||||
] when drop ;
|
||||
[ [ handle>> ] dip d>w/w <uint> ] dip SetFilePointer
|
||||
INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
|
||||
|
||||
HOOK: open-append os ( path -- win32-file )
|
||||
|
||||
|
|
|
|||
|
|
@ -164,4 +164,19 @@ IN: io.launcher.windows.nt.tests
|
|||
"append-test" temp-file ascii file-contents
|
||||
] unit-test
|
||||
|
||||
[ "( scratchpad ) " ] [
|
||||
console-vm "-run=listener" 2array
|
||||
ascii [ "USE: system 0 exit" print flush readln ] with-process-stream
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
console-vm "-run=listener" 2array
|
||||
ascii [ "USE: system 0 exit" print ] with-process-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
<process>
|
||||
console-vm "-run=listener" 2array >>command
|
||||
"vocab:io/launcher/windows/nt/test/input.txt" >>stdin
|
||||
try-process
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -10,21 +10,21 @@ IN: io.launcher.windows.nt
|
|||
|
||||
: duplicate-handle ( handle -- handle' )
|
||||
GetCurrentProcess ! source process
|
||||
swap ! handle
|
||||
swap handle>> ! handle
|
||||
GetCurrentProcess ! target process
|
||||
f <void*> [ ! target handle
|
||||
DUPLICATE_SAME_ACCESS ! desired access
|
||||
TRUE ! inherit handle
|
||||
DUPLICATE_CLOSE_SOURCE ! options
|
||||
0 ! options
|
||||
DuplicateHandle win32-error=0/f
|
||||
] keep *void* ;
|
||||
] keep *void* <win32-handle> &dispose ;
|
||||
|
||||
! /dev/null simulation
|
||||
: null-input ( -- pipe )
|
||||
(pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
|
||||
(pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
|
||||
|
||||
: null-output ( -- pipe )
|
||||
(pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
|
||||
(pipe) [ in>> dispose ] [ out>> &dispose ] bi ;
|
||||
|
||||
: null-pipe ( mode -- pipe )
|
||||
{
|
||||
|
|
@ -49,7 +49,7 @@ IN: io.launcher.windows.nt
|
|||
create-mode
|
||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||
f ! template file
|
||||
CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
|
||||
CreateFile dup invalid-handle? <win32-file> &dispose ;
|
||||
|
||||
: redirect-append ( path access-mode create-mode -- handle )
|
||||
[ path>> ] 2dip
|
||||
|
|
@ -58,10 +58,10 @@ IN: io.launcher.windows.nt
|
|||
dup 0 FILE_END set-file-pointer ;
|
||||
|
||||
: redirect-handle ( handle access-mode create-mode -- handle )
|
||||
2drop handle>> duplicate-handle ;
|
||||
2drop ;
|
||||
|
||||
: redirect-stream ( stream access-mode create-mode -- handle )
|
||||
[ underlying-handle handle>> ] 2dip redirect-handle ;
|
||||
[ underlying-handle ] 2dip redirect-handle ;
|
||||
|
||||
: redirect ( obj access-mode create-mode -- handle )
|
||||
{
|
||||
|
|
@ -72,7 +72,7 @@ IN: io.launcher.windows.nt
|
|||
{ [ pick win32-file? ] [ redirect-handle ] }
|
||||
[ redirect-stream ]
|
||||
} cond
|
||||
dup [ dup t set-inherit ] when ;
|
||||
dup [ dup t set-inherit handle>> ] when ;
|
||||
|
||||
: redirect-stdout ( process args -- handle )
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
USE: system 0 exit
|
||||
|
|
@ -9,9 +9,9 @@ C: <bits> bits
|
|||
: make-bits ( number -- bits )
|
||||
[ T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if-zero ; inline
|
||||
|
||||
M: bits length length>> ;
|
||||
M: bits length length>> ; inline
|
||||
|
||||
M: bits nth-unsafe number>> swap bit? ;
|
||||
M: bits nth-unsafe number>> swap bit? ; inline
|
||||
|
||||
INSTANCE: bits immutable-sequence
|
||||
|
||||
|
|
|
|||
|
|
@ -5,29 +5,29 @@ math.libm math.functions arrays math.functions.private sequences
|
|||
parser ;
|
||||
IN: math.complex.private
|
||||
|
||||
M: real real-part ;
|
||||
M: real imaginary-part drop 0 ;
|
||||
M: complex real-part real>> ;
|
||||
M: complex imaginary-part imaginary>> ;
|
||||
M: complex absq >rect [ sq ] bi@ + ;
|
||||
M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ;
|
||||
M: real real-part ; inline
|
||||
M: real imaginary-part drop 0 ; inline
|
||||
M: complex real-part real>> ; inline
|
||||
M: complex imaginary-part imaginary>> ; inline
|
||||
M: complex absq >rect [ sq ] bi@ + ; inline
|
||||
M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; inline
|
||||
: componentwise ( x y quot -- a b ) [ [ >rect ] bi@ ] dip bi-curry@ bi* ; inline
|
||||
: complex= ( x y quot -- ? ) componentwise and ; inline
|
||||
M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ;
|
||||
M: complex number= [ number= ] complex= ;
|
||||
M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; inline
|
||||
M: complex number= [ number= ] complex= ; inline
|
||||
: complex-op ( x y quot -- z ) componentwise rect> ; inline
|
||||
M: complex + [ + ] complex-op ;
|
||||
M: complex - [ - ] complex-op ;
|
||||
M: complex + [ + ] complex-op ; inline
|
||||
M: complex - [ - ] complex-op ; inline
|
||||
: *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline
|
||||
: *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline
|
||||
M: complex * [ *re - ] [ *im + ] 2bi rect> ;
|
||||
M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline
|
||||
: (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
|
||||
: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline
|
||||
M: complex / [ / ] complex/ ;
|
||||
M: complex /f [ /f ] complex/ ;
|
||||
M: complex /i [ /i ] complex/ ;
|
||||
M: complex abs absq >float fsqrt ;
|
||||
M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
|
||||
M: complex / [ / ] complex/ ; inline
|
||||
M: complex /f [ /f ] complex/ ; inline
|
||||
M: complex /i [ /i ] complex/ ; inline
|
||||
M: complex abs absq >float fsqrt ; inline
|
||||
M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline
|
||||
|
||||
IN: syntax
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ IN: math.functions
|
|||
GENERIC: sqrt ( x -- y ) foldable
|
||||
|
||||
M: real sqrt
|
||||
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
|
||||
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline
|
||||
|
||||
: factor-2s ( n -- r s )
|
||||
#! factor an integer into 2^r * s
|
||||
|
|
@ -120,7 +120,7 @@ ERROR: non-trivial-divisor n ;
|
|||
|
||||
GENERIC: absq ( x -- y ) foldable
|
||||
|
||||
M: real absq sq ;
|
||||
M: real absq sq ; inline
|
||||
|
||||
: ~abs ( x y epsilon -- ? )
|
||||
[ - abs ] dip < ;
|
||||
|
|
@ -148,13 +148,13 @@ M: real absq sq ;
|
|||
|
||||
GENERIC: exp ( x -- y )
|
||||
|
||||
M: real exp fexp ;
|
||||
M: real exp fexp ; inline
|
||||
|
||||
M: complex exp >rect swap fexp swap polar> ;
|
||||
|
||||
GENERIC: log ( x -- y )
|
||||
|
||||
M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ;
|
||||
M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
|
||||
|
||||
M: complex log >polar swap flog swap rect> ;
|
||||
|
||||
|
|
@ -169,7 +169,7 @@ M: complex cos
|
|||
[ [ fcos ] [ fcosh ] bi* * ]
|
||||
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
|
||||
|
||||
M: real cos fcos ;
|
||||
M: real cos fcos ; inline
|
||||
|
||||
: sec ( x -- y ) cos recip ; inline
|
||||
|
||||
|
|
@ -180,7 +180,7 @@ M: complex cosh
|
|||
[ [ fcosh ] [ fcos ] bi* * ]
|
||||
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
|
||||
|
||||
M: real cosh fcosh ;
|
||||
M: real cosh fcosh ; inline
|
||||
|
||||
: sech ( x -- y ) cosh recip ; inline
|
||||
|
||||
|
|
@ -191,7 +191,7 @@ M: complex sin
|
|||
[ [ fsin ] [ fcosh ] bi* * ]
|
||||
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
|
||||
|
||||
M: real sin fsin ;
|
||||
M: real sin fsin ; inline
|
||||
|
||||
: cosec ( x -- y ) sin recip ; inline
|
||||
|
||||
|
|
@ -202,7 +202,7 @@ M: complex sinh
|
|||
[ [ fsinh ] [ fcos ] bi* * ]
|
||||
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
|
||||
|
||||
M: real sinh fsinh ;
|
||||
M: real sinh fsinh ; inline
|
||||
|
||||
: cosech ( x -- y ) sinh recip ; inline
|
||||
|
||||
|
|
@ -210,13 +210,13 @@ GENERIC: tan ( x -- y ) foldable
|
|||
|
||||
M: complex tan [ sin ] [ cos ] bi / ;
|
||||
|
||||
M: real tan ftan ;
|
||||
M: real tan ftan ; inline
|
||||
|
||||
GENERIC: tanh ( x -- y ) foldable
|
||||
|
||||
M: complex tanh [ sinh ] [ cosh ] bi / ;
|
||||
|
||||
M: real tanh ftanh ;
|
||||
M: real tanh ftanh ; inline
|
||||
|
||||
: cot ( x -- y ) tan recip ; inline
|
||||
|
||||
|
|
@ -252,7 +252,7 @@ GENERIC: atan ( x -- y ) foldable
|
|||
|
||||
M: complex atan i* atanh i* ;
|
||||
|
||||
M: real atan fatan ;
|
||||
M: real atan fatan ; inline
|
||||
|
||||
: asec ( x -- y ) recip acos ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -348,6 +348,10 @@ comparison-ops [
|
|||
|
||||
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
|
||||
|
||||
[ t ] [ full-interval interval-abs [0,inf] = ] unit-test
|
||||
|
||||
[ t ] [ [0,inf] interval-sq [0,inf] = ] unit-test
|
||||
|
||||
! Test that commutative interval ops really are
|
||||
: random-interval-or-empty ( -- obj )
|
||||
10 random 0 = [ empty-interval ] [ random-interval ] if ;
|
||||
|
|
|
|||
|
|
@ -94,21 +94,25 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
: interval>points ( int -- from to )
|
||||
[ from>> ] [ to>> ] bi ;
|
||||
|
||||
: points>interval ( seq -- interval )
|
||||
dup [ first fp-nan? ] any?
|
||||
[ drop [-inf,inf] ] [
|
||||
dup first
|
||||
[ [ endpoint-min ] reduce ]
|
||||
[ [ endpoint-max ] reduce ]
|
||||
2bi <interval>
|
||||
] if ;
|
||||
: points>interval ( seq -- interval nan? )
|
||||
[ first fp-nan? not ] partition
|
||||
[
|
||||
[ [ ] [ endpoint-min ] map-reduce ]
|
||||
[ [ ] [ endpoint-max ] map-reduce ] bi
|
||||
<interval>
|
||||
]
|
||||
[ empty? not ]
|
||||
bi* ;
|
||||
|
||||
: nan-ok ( interval nan? -- interval ) drop ; inline
|
||||
: nan-not-ok ( interval nan? -- interval ) [ drop full-interval ] when ; inline
|
||||
|
||||
: (interval-op) ( p1 p2 quot -- p3 )
|
||||
[ [ first ] [ first ] [ call ] tri* ]
|
||||
[ drop [ second ] both? ]
|
||||
3bi 2array ; inline
|
||||
|
||||
: interval-op ( i1 i2 quot -- i3 )
|
||||
: interval-op ( i1 i2 quot -- i3 nan? )
|
||||
{
|
||||
[ [ from>> ] [ from>> ] [ ] tri* (interval-op) ]
|
||||
[ [ to>> ] [ from>> ] [ ] tri* (interval-op) ]
|
||||
|
|
@ -126,10 +130,10 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
} cond ; inline
|
||||
|
||||
: interval+ ( i1 i2 -- i3 )
|
||||
[ [ + ] interval-op ] do-empty-interval ;
|
||||
[ [ + ] interval-op nan-ok ] do-empty-interval ;
|
||||
|
||||
: interval- ( i1 i2 -- i3 )
|
||||
[ [ - ] interval-op ] do-empty-interval ;
|
||||
[ [ - ] interval-op nan-ok ] do-empty-interval ;
|
||||
|
||||
: interval-intersect ( i1 i2 -- i3 )
|
||||
{
|
||||
|
|
@ -154,7 +158,7 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
{ [ dup empty-interval eq? ] [ drop ] }
|
||||
{ [ over full-interval eq? ] [ drop ] }
|
||||
{ [ dup full-interval eq? ] [ nip ] }
|
||||
[ [ interval>points 2array ] bi@ append points>interval ]
|
||||
[ [ interval>points 2array ] bi@ append points>interval nan-not-ok ]
|
||||
} cond ;
|
||||
|
||||
: interval-subset? ( i1 i2 -- ? )
|
||||
|
|
@ -173,7 +177,7 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
0 swap interval-contains? ;
|
||||
|
||||
: interval* ( i1 i2 -- i3 )
|
||||
[ [ [ * ] interval-op ] do-empty-interval ]
|
||||
[ [ [ * ] interval-op nan-ok ] do-empty-interval ]
|
||||
[ [ interval-zero? ] either? ]
|
||||
2bi [ 0 [a,a] interval-union ] when ;
|
||||
|
||||
|
|
@ -220,7 +224,7 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
[
|
||||
[
|
||||
[ interval-closure ] bi@
|
||||
[ shift ] interval-op
|
||||
[ shift ] interval-op nan-not-ok
|
||||
] interval-integer-op
|
||||
] do-empty-interval ;
|
||||
|
||||
|
|
@ -235,11 +239,11 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
|
||||
: interval-max ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
[ [ interval-closure ] bi@ [ max ] interval-op ] do-empty-interval ;
|
||||
[ [ interval-closure ] bi@ [ max ] interval-op nan-not-ok ] do-empty-interval ;
|
||||
|
||||
: interval-min ( i1 i2 -- i3 )
|
||||
#! Inaccurate; could be tighter
|
||||
[ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
|
||||
[ [ interval-closure ] bi@ [ min ] interval-op nan-not-ok ] do-empty-interval ;
|
||||
|
||||
: interval-interior ( i1 -- i2 )
|
||||
dup special-interval? [
|
||||
|
|
@ -254,7 +258,7 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
} cond ; inline
|
||||
|
||||
: interval/ ( i1 i2 -- i3 )
|
||||
[ [ [ / ] interval-op ] interval-division-op ] do-empty-interval ;
|
||||
[ [ [ / ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ;
|
||||
|
||||
: interval/-safe ( i1 i2 -- i3 )
|
||||
#! Just a hack to make the compiler work if bootstrap.math
|
||||
|
|
@ -266,13 +270,13 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
[
|
||||
[
|
||||
[ interval-closure ] bi@
|
||||
[ /i ] interval-op
|
||||
[ /i ] interval-op nan-not-ok
|
||||
] interval-integer-op
|
||||
] interval-division-op
|
||||
] do-empty-interval ;
|
||||
|
||||
: interval/f ( i1 i2 -- i3 )
|
||||
[ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
|
||||
[ [ [ /f ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ;
|
||||
|
||||
: (interval-abs) ( i1 -- i2 )
|
||||
interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ;
|
||||
|
|
@ -281,10 +285,13 @@ MEMO: array-capacity-interval ( -- interval )
|
|||
{
|
||||
{ [ dup empty-interval eq? ] [ ] }
|
||||
{ [ dup full-interval eq? ] [ drop [0,inf] ] }
|
||||
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
|
||||
[ (interval-abs) points>interval ]
|
||||
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval nan-not-ok ] }
|
||||
[ (interval-abs) points>interval nan-not-ok ]
|
||||
} cond ;
|
||||
|
||||
: interval-absq ( i1 -- i2 )
|
||||
interval-abs interval-sq ;
|
||||
|
||||
: interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ;
|
||||
|
||||
: interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ;
|
||||
|
|
|
|||
|
|
@ -12,11 +12,9 @@ TUPLE: range
|
|||
: <range> ( a b step -- range )
|
||||
[ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
|
||||
|
||||
M: range length ( seq -- n )
|
||||
length>> ;
|
||||
M: range length ( seq -- n ) length>> ; inline
|
||||
|
||||
M: range nth-unsafe ( n range -- obj )
|
||||
[ step>> * ] keep from>> + ;
|
||||
M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
|
||||
|
||||
! For ranges with many elements, the default element-wise methods
|
||||
! sequences define are unsuitable because they're O(n)
|
||||
|
|
|
|||
|
|
@ -48,8 +48,8 @@ M: ratio >fixnum >fraction /i >fixnum ;
|
|||
M: ratio >bignum >fraction /i >bignum ;
|
||||
M: ratio >float >fraction /f ;
|
||||
|
||||
M: ratio numerator numerator>> ;
|
||||
M: ratio denominator denominator>> ;
|
||||
M: ratio numerator numerator>> ; inline
|
||||
M: ratio denominator denominator>> ; inline
|
||||
|
||||
M: ratio < scale < ;
|
||||
M: ratio <= scale <= ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax ;
|
||||
USING: help.markup help.syntax strings ;
|
||||
IN: multiline
|
||||
|
||||
HELP: STRING:
|
||||
|
|
@ -19,24 +19,33 @@ HELP: /*
|
|||
} ;
|
||||
|
||||
HELP: HEREDOC:
|
||||
{ $syntax "HEREDOC: marker\n...text...marker" }
|
||||
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "" "a string" } }
|
||||
{ $description "A multiline string syntax with a user-specified terminating delimiter. HEREDOC: reads the next word, and uses it as the 'close quote'. All input from the beginning of the HEREDOC:'s next line, until the first appearance of the word's name, becomes a string. The terminating word does not need to be at the beginning of a line.\n\nThe HEREDOC: line should not have anything after the delimiting word. The delimiting word should be an alphanumeric token. It should not be, as in some other languages, a \"quoted string\"." }
|
||||
{ $syntax "HEREDOC: marker\n...text...\nmarker" }
|
||||
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
|
||||
{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: HEREDOC: } " until the end of the line containing the " { $link POSTPONE: HEREDOC: } ". Text is captured until a line is found conatining exactly this delimter string." }
|
||||
{ $warning "Whitespace is significant." }
|
||||
{ $examples
|
||||
{ $example "USING: multiline prettyprint ;"
|
||||
"HEREDOC: END\nx\nEND ."
|
||||
"HEREDOC: END\nx\nEND\n."
|
||||
"\"x\\n\""
|
||||
}
|
||||
{ $example "USING: multiline prettyprint ;"
|
||||
"HEREDOC: END\nxEND ."
|
||||
"\"x\""
|
||||
}
|
||||
{ $example "USING: multiline prettyprint sequences ;"
|
||||
"2 5 HEREDOC: zap\nfoo\nbarzap subseq ."
|
||||
"2 5 HEREDOC: zap\nfoo\nbar\nzap\nsubseq ."
|
||||
"\"o\\nb\""
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: DELIMITED:
|
||||
{ $syntax "DELIMITED: marker\n...text...\nmarker" }
|
||||
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "value" string } }
|
||||
{ $description "Returns a string delimited by an arbitrary user-defined token. This delimiter must be exactly the text beginning at the first non-blank character after the " { $link POSTPONE: DELIMITED: } " until the end of the line containing the " { $link POSTPONE: DELIMITED: } ". Text is captured until the exact delimiter string is found, regardless of where." }
|
||||
{ $examples
|
||||
{ $example "USING: multiline prettyprint ;"
|
||||
"DELIMITED: factor blows my mind"
|
||||
"whoafactor blows my mind ."
|
||||
"\"whoa\""
|
||||
}
|
||||
} ;
|
||||
|
||||
{ POSTPONE: <" POSTPONE: STRING: } related-words
|
||||
|
||||
HELP: parse-multiline-string
|
||||
|
|
@ -49,6 +58,7 @@ ARTICLE: "multiline" "Multiline"
|
|||
{ $subsection POSTPONE: STRING: }
|
||||
{ $subsection POSTPONE: <" }
|
||||
{ $subsection POSTPONE: HEREDOC: }
|
||||
{ $subsection POSTPONE: DELIMITED: }
|
||||
"Multiline comments:"
|
||||
{ $subsection POSTPONE: /* }
|
||||
"Writing new multiline parsing words:"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: multiline tools.test ;
|
||||
USING: accessors eval multiline tools.test ;
|
||||
IN: multiline.tests
|
||||
|
||||
STRING: test-it
|
||||
|
|
@ -26,36 +26,66 @@ hi"> ] unit-test
|
|||
[ "foo\nbar\n" ] [ HEREDOC: END
|
||||
foo
|
||||
bar
|
||||
END ] unit-test
|
||||
|
||||
[ "foo\nbar" ] [ HEREDOC: END
|
||||
foo
|
||||
barEND ] unit-test
|
||||
END
|
||||
] unit-test
|
||||
|
||||
[ "" ] [ HEREDOC: END
|
||||
END ] unit-test
|
||||
END
|
||||
] unit-test
|
||||
|
||||
[ " " ] [ HEREDOC: END
|
||||
END ] unit-test
|
||||
[ " END\n" ] [ HEREDOC: END
|
||||
END
|
||||
END
|
||||
] unit-test
|
||||
|
||||
[ "\n" ] [ HEREDOC: END
|
||||
|
||||
END ] unit-test
|
||||
END
|
||||
] unit-test
|
||||
|
||||
[ "x" ] [ HEREDOC: END
|
||||
xEND ] unit-test
|
||||
[ "x\n" ] [ HEREDOC: END
|
||||
x
|
||||
END
|
||||
] unit-test
|
||||
|
||||
[ "xyz " ] [ HEREDOC: END
|
||||
xyz END ] unit-test
|
||||
[ "x\n" ] [ HEREDOC: END
|
||||
x
|
||||
END
|
||||
] unit-test
|
||||
|
||||
[ "xyz \n" ] [ HEREDOC: END
|
||||
xyz
|
||||
END
|
||||
] unit-test
|
||||
|
||||
[ "} ! * # \" «\n" ] [ HEREDOC: END
|
||||
} ! * # " «
|
||||
END ] unit-test
|
||||
END
|
||||
] unit-test
|
||||
|
||||
[ 21 "foo\nbar" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X
|
||||
[ 21 "foo\nbar\n" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X
|
||||
foo
|
||||
barX HEREDOC: END ! mumble
|
||||
bar
|
||||
X
|
||||
HEREDOC: END
|
||||
HEREDOC: FOO
|
||||
FOO
|
||||
END 22 ] unit-test
|
||||
END
|
||||
22 ] unit-test
|
||||
|
||||
[ "lol\n xyz\n" ]
|
||||
[
|
||||
HEREDOC: xyz
|
||||
lol
|
||||
xyz
|
||||
xyz
|
||||
] unit-test
|
||||
|
||||
|
||||
[ "lol" ]
|
||||
[ DELIMITED: aol
|
||||
lolaol ] unit-test
|
||||
|
||||
[ "whoa" ]
|
||||
[ DELIMITED: factor blows my mind
|
||||
whoafactor blows my mind ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,6 +4,8 @@ USING: namespaces make parser lexer kernel sequences words
|
|||
quotations math accessors locals ;
|
||||
IN: multiline
|
||||
|
||||
ERROR: bad-heredoc identifier ;
|
||||
|
||||
<PRIVATE
|
||||
: next-line-text ( -- str )
|
||||
lexer get dup next-line line-text>> ;
|
||||
|
|
@ -46,6 +48,28 @@ SYNTAX: STRING:
|
|||
change-column drop
|
||||
] "" make ;
|
||||
|
||||
: rest-of-line ( -- seq )
|
||||
lexer get [ line-text>> ] [ column>> ] bi tail ;
|
||||
|
||||
:: advance-same-line ( text -- )
|
||||
lexer get [ text length + ] change-column drop ;
|
||||
|
||||
:: (parse-til-line-begins) ( begin-text -- )
|
||||
lexer get still-parsing? [
|
||||
lexer get line-text>> begin-text sequence= [
|
||||
begin-text advance-same-line
|
||||
] [
|
||||
lexer get line-text>> % "\n" %
|
||||
lexer get next-line
|
||||
begin-text (parse-til-line-begins)
|
||||
] if
|
||||
] [
|
||||
begin-text bad-heredoc
|
||||
] if ;
|
||||
|
||||
: parse-til-line-begins ( begin-text -- seq )
|
||||
[ (parse-til-line-begins) ] "" make ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: parse-multiline-string ( end-text -- str )
|
||||
|
|
@ -66,7 +90,13 @@ SYNTAX: {"
|
|||
SYNTAX: /* "*/" parse-multiline-string drop ;
|
||||
|
||||
SYNTAX: HEREDOC:
|
||||
scan
|
||||
lexer get skip-blank
|
||||
rest-of-line
|
||||
lexer get next-line
|
||||
0 (parse-multiline-string)
|
||||
parsed ;
|
||||
parse-til-line-begins parsed ;
|
||||
|
||||
SYNTAX: DELIMITED:
|
||||
lexer get skip-blank
|
||||
rest-of-line
|
||||
lexer get next-line
|
||||
0 (parse-multiline-string) parsed ;
|
||||
|
|
|
|||
|
|
@ -158,6 +158,8 @@ M: bad-executable summary
|
|||
|
||||
\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
|
||||
|
||||
\ <tuple-boa> t "flushable" set-word-prop
|
||||
|
||||
: infer-effect-unsafe ( word -- )
|
||||
pop-literal nip
|
||||
add-effect-input
|
||||
|
|
|
|||
|
|
@ -54,17 +54,17 @@ TUPLE: CLASS-array
|
|||
[ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
|
||||
\ CLASS-array boa ; inline
|
||||
|
||||
M: CLASS-array length length>> ;
|
||||
M: CLASS-array length length>> ; inline
|
||||
|
||||
M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
|
||||
M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline
|
||||
|
||||
M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
|
||||
M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline
|
||||
|
||||
M: CLASS-array new-sequence drop <CLASS-array> ;
|
||||
M: CLASS-array new-sequence drop <CLASS-array> ; inline
|
||||
|
||||
: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
|
||||
|
||||
M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
|
||||
M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline
|
||||
|
||||
INSTANCE: CLASS-array sequence
|
||||
|
||||
|
|
|
|||
|
|
@ -18,11 +18,11 @@ TUPLE: V { underlying A } { length array-capacity } ;
|
|||
M: V like
|
||||
drop dup V instance? [
|
||||
dup A instance? [ dup length V boa ] [ >V ] if
|
||||
] unless ;
|
||||
] unless ; inline
|
||||
|
||||
M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
|
||||
M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ; inline
|
||||
|
||||
M: A new-resizable drop <V> ;
|
||||
M: A new-resizable drop <V> ; inline
|
||||
|
||||
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.syntax alien.c-types alien.strings math
|
||||
kernel sequences windows.errors windows.types debugger io
|
||||
kernel sequences windows.errors windows.types io
|
||||
accessors math.order namespaces make math.parser windows.kernel32
|
||||
combinators locals specialized-arrays.direct.uchar ;
|
||||
IN: windows.ole32
|
||||
|
|
@ -116,11 +116,10 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
|
|||
: succeeded? ( hresult -- ? )
|
||||
0 HEX: 7FFFFFFF between? ;
|
||||
|
||||
TUPLE: ole32-error error-code ;
|
||||
C: <ole32-error> ole32-error
|
||||
TUPLE: ole32-error code message ;
|
||||
|
||||
M: ole32-error error.
|
||||
"COM method failed: " print error-code>> n>win32-error-string print ;
|
||||
: <ole32-error> ( code -- error )
|
||||
dup n>win32-error-string \ ole32-error boa ;
|
||||
|
||||
: ole32-error ( hresult -- )
|
||||
dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
|
||||
|
|
|
|||
|
|
@ -20,11 +20,11 @@ UNION: pinned-c-ptr
|
|||
|
||||
GENERIC: >c-ptr ( obj -- c-ptr )
|
||||
|
||||
M: c-ptr >c-ptr ;
|
||||
M: c-ptr >c-ptr ; inline
|
||||
|
||||
SLOT: underlying
|
||||
|
||||
M: object >c-ptr underlying>> ;
|
||||
M: object >c-ptr underlying>> ; inline
|
||||
|
||||
GENERIC: expired? ( c-ptr -- ? ) flushable
|
||||
|
||||
|
|
|
|||
|
|
@ -4,17 +4,17 @@ USING: accessors kernel kernel.private math math.private
|
|||
sequences sequences.private ;
|
||||
IN: arrays
|
||||
|
||||
M: array clone (clone) ;
|
||||
M: array length length>> ;
|
||||
M: array nth-unsafe [ >fixnum ] dip array-nth ;
|
||||
M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ;
|
||||
M: array resize resize-array ;
|
||||
M: array clone (clone) ; inline
|
||||
M: array length length>> ; inline
|
||||
M: array nth-unsafe [ >fixnum ] dip array-nth ; inline
|
||||
M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline
|
||||
M: array resize resize-array ; inline
|
||||
|
||||
: >array ( seq -- array ) { } clone-like ;
|
||||
|
||||
M: object new-sequence drop 0 <array> ;
|
||||
M: object new-sequence drop 0 <array> ; inline
|
||||
|
||||
M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ;
|
||||
M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; inline
|
||||
|
||||
M: array equal?
|
||||
over array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ GENERIC: assoc-like ( assoc exemplar -- newassoc )
|
|||
GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
|
||||
GENERIC: >alist ( assoc -- newassoc )
|
||||
|
||||
M: assoc assoc-like drop ;
|
||||
M: assoc assoc-like drop ; inline
|
||||
|
||||
: ?at ( key assoc -- value/key ? )
|
||||
2dup at* [ 2nip t ] [ 2drop f ] if ; inline
|
||||
|
|
@ -87,7 +87,7 @@ PRIVATE>
|
|||
|
||||
M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||
[ dup assoc-size ] dip new-assoc
|
||||
[ [ set-at ] with-assoc assoc-each ] keep ;
|
||||
[ [ set-at ] with-assoc assoc-each ] keep ; inline
|
||||
|
||||
: keys ( assoc -- keys )
|
||||
[ drop ] { } assoc>map ;
|
||||
|
|
@ -189,48 +189,48 @@ M: sequence set-at
|
|||
[ 2nip set-second ]
|
||||
[ drop [ swap 2array ] dip push ] if ;
|
||||
|
||||
M: sequence new-assoc drop <vector> ;
|
||||
M: sequence new-assoc drop <vector> ; inline
|
||||
|
||||
M: sequence clear-assoc delete-all ;
|
||||
M: sequence clear-assoc delete-all ; inline
|
||||
|
||||
M: sequence delete-at
|
||||
[ nip ] [ search-alist nip ] 2bi
|
||||
[ swap delete-nth ] [ drop ] if* ;
|
||||
|
||||
M: sequence assoc-size length ;
|
||||
M: sequence assoc-size length ; inline
|
||||
|
||||
M: sequence assoc-clone-like
|
||||
[ >alist ] dip clone-like ;
|
||||
[ >alist ] dip clone-like ; inline
|
||||
|
||||
M: sequence assoc-like
|
||||
[ >alist ] dip like ;
|
||||
[ >alist ] dip like ; inline
|
||||
|
||||
M: sequence >alist ;
|
||||
M: sequence >alist ; inline
|
||||
|
||||
! Override sequence => assoc instance for f
|
||||
M: f clear-assoc drop ;
|
||||
M: f clear-assoc drop ; inline
|
||||
|
||||
M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
|
||||
M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline
|
||||
|
||||
INSTANCE: sequence assoc
|
||||
|
||||
TUPLE: enum seq ;
|
||||
TUPLE: enum { seq read-only } ;
|
||||
|
||||
C: <enum> enum
|
||||
|
||||
M: enum at*
|
||||
seq>> 2dup bounds-check?
|
||||
[ nth t ] [ 2drop f f ] if ;
|
||||
[ nth t ] [ 2drop f f ] if ; inline
|
||||
|
||||
M: enum set-at seq>> set-nth ;
|
||||
M: enum set-at seq>> set-nth ; inline
|
||||
|
||||
M: enum delete-at seq>> delete-nth ;
|
||||
M: enum delete-at seq>> delete-nth ; inline
|
||||
|
||||
M: enum >alist ( enum -- alist )
|
||||
seq>> [ length ] keep zip ;
|
||||
seq>> [ length ] keep zip ; inline
|
||||
|
||||
M: enum assoc-size seq>> length ;
|
||||
M: enum assoc-size seq>> length ; inline
|
||||
|
||||
M: enum clear-assoc seq>> delete-all ;
|
||||
M: enum clear-assoc seq>> delete-all ; inline
|
||||
|
||||
INSTANCE: enum assoc
|
||||
|
|
|
|||
|
|
@ -4,18 +4,18 @@ USING: accessors kernel kernel.private alien.accessors sequences
|
|||
sequences.private math ;
|
||||
IN: byte-arrays
|
||||
|
||||
M: byte-array clone (clone) ;
|
||||
M: byte-array length length>> ;
|
||||
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
|
||||
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
|
||||
M: byte-array clone (clone) ; inline
|
||||
M: byte-array length length>> ; inline
|
||||
M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; inline
|
||||
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; inline
|
||||
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
|
||||
M: byte-array new-sequence drop (byte-array) ;
|
||||
M: byte-array new-sequence drop (byte-array) ; inline
|
||||
|
||||
M: byte-array equal?
|
||||
over byte-array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: byte-array resize
|
||||
resize-byte-array ;
|
||||
resize-byte-array ; inline
|
||||
|
||||
INSTANCE: byte-array sequence
|
||||
|
||||
|
|
|
|||
|
|
@ -18,15 +18,15 @@ M: byte-vector like
|
|||
drop dup byte-vector? [
|
||||
dup byte-array?
|
||||
[ dup length byte-vector boa ] [ >byte-vector ] if
|
||||
] unless ;
|
||||
] unless ; inline
|
||||
|
||||
M: byte-vector new-sequence
|
||||
drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;
|
||||
drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; inline
|
||||
|
||||
M: byte-vector equal?
|
||||
over byte-vector? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: byte-vector contract 2drop ;
|
||||
M: byte-vector contract 2drop ; inline
|
||||
|
||||
M: byte-array like
|
||||
#! If we have an byte-array, we're done.
|
||||
|
|
@ -39,8 +39,8 @@ M: byte-array like
|
|||
2dup length eq?
|
||||
[ nip ] [ resize-byte-array ] if
|
||||
] [ >byte-array ] if
|
||||
] unless ;
|
||||
] unless ; inline
|
||||
|
||||
M: byte-array new-resizable drop <byte-vector> ;
|
||||
M: byte-array new-resizable drop <byte-vector> ; inline
|
||||
|
||||
INSTANCE: byte-vector growable
|
||||
|
|
|
|||
|
|
@ -20,9 +20,9 @@ PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
|
|||
|
||||
: bootstrap-type>class ( n -- class ) builtins get nth ;
|
||||
|
||||
M: hi-tag class hi-tag type>class ;
|
||||
M: hi-tag class hi-tag type>class ; inline
|
||||
|
||||
M: object class tag type>class ;
|
||||
M: object class tag type>class ; inline
|
||||
|
||||
M: builtin-class rank-class drop 0 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -110,6 +110,12 @@ USE: multiline
|
|||
"class-intersect-no-method-c" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
! Forget the above crap
|
||||
[
|
||||
{ "classes.test.a" "classes.test.b" "classes.test.c" "classes.test.d" }
|
||||
[ forget-vocab ] each
|
||||
] with-compilation-unit
|
||||
|
||||
TUPLE: forgotten-predicate-test ;
|
||||
|
||||
[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
|
|||
: layout-of ( tuple -- layout )
|
||||
1 slot { array } declare ; inline
|
||||
|
||||
M: tuple class layout-of 2 slot { word } declare ;
|
||||
M: tuple class layout-of 2 slot { word } declare ; inline
|
||||
|
||||
: tuple-size ( tuple -- size )
|
||||
layout-of 3 slot { fixnum } declare ; inline
|
||||
|
|
@ -335,7 +335,7 @@ M: tuple-class (classes-intersect?)
|
|||
[ swap classes-intersect? ]
|
||||
} cond ;
|
||||
|
||||
M: tuple clone (clone) ;
|
||||
M: tuple clone (clone) ; inline
|
||||
|
||||
M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,9 +9,9 @@ MIXIN: growable
|
|||
SLOT: length
|
||||
SLOT: underlying
|
||||
|
||||
M: growable length length>> ;
|
||||
M: growable nth-unsafe underlying>> nth-unsafe ;
|
||||
M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
|
||||
M: growable length length>> ; inline
|
||||
M: growable nth-unsafe underlying>> nth-unsafe ; inline
|
||||
M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline
|
||||
|
||||
: capacity ( seq -- n ) underlying>> length ; inline
|
||||
|
||||
|
|
@ -49,21 +49,21 @@ M: growable set-length ( n seq -- )
|
|||
[ >fixnum ] dip
|
||||
] if ; inline
|
||||
|
||||
M: growable set-nth ensure set-nth-unsafe ;
|
||||
M: growable set-nth ensure set-nth-unsafe ; inline
|
||||
|
||||
M: growable clone (clone) [ clone ] change-underlying ;
|
||||
M: growable clone (clone) [ clone ] change-underlying ; inline
|
||||
|
||||
M: growable lengthen ( n seq -- )
|
||||
2dup length > [
|
||||
2dup capacity > [ over new-size over expand ] when
|
||||
2dup (>>length)
|
||||
] when 2drop ;
|
||||
] when 2drop ; inline
|
||||
|
||||
M: growable shorten ( n seq -- )
|
||||
growable-check
|
||||
2dup length < [
|
||||
2dup contract
|
||||
2dup (>>length)
|
||||
] when 2drop ;
|
||||
] when 2drop ; inline
|
||||
|
||||
INSTANCE: growable sequence
|
||||
|
|
|
|||
|
|
@ -112,7 +112,7 @@ M: hashtable delete-at ( key hash -- )
|
|||
] if ;
|
||||
|
||||
M: hashtable assoc-size ( hash -- n )
|
||||
[ count>> ] [ deleted>> ] bi - ;
|
||||
[ count>> ] [ deleted>> ] bi - ; inline
|
||||
|
||||
: rehash ( hash -- )
|
||||
dup >alist [
|
||||
|
|
@ -150,7 +150,7 @@ M: hashtable >alist
|
|||
] keep { } like ;
|
||||
|
||||
M: hashtable clone
|
||||
(clone) [ clone ] change-array ;
|
||||
(clone) [ clone ] change-array ; inline
|
||||
|
||||
M: hashtable equal?
|
||||
over hashtable? [
|
||||
|
|
@ -159,15 +159,15 @@ M: hashtable equal?
|
|||
] [ 2drop f ] if ;
|
||||
|
||||
! Default method
|
||||
M: assoc new-assoc drop <hashtable> ;
|
||||
M: assoc new-assoc drop <hashtable> ; inline
|
||||
|
||||
M: f new-assoc drop <hashtable> ;
|
||||
M: f new-assoc drop <hashtable> ; inline
|
||||
|
||||
: >hashtable ( assoc -- hashtable )
|
||||
H{ } assoc-clone-like ;
|
||||
|
||||
M: hashtable assoc-like
|
||||
drop dup hashtable? [ >hashtable ] unless ;
|
||||
drop dup hashtable? [ >hashtable ] unless ; inline
|
||||
|
||||
: ?set-at ( value key assoc/f -- assoc )
|
||||
[ [ set-at ] keep ] [ associate ] if* ;
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ SINGLETON: utf8
|
|||
dup stream-read1 dup [ begin-utf8 ] when nip ; inline
|
||||
|
||||
M: utf8 decode-char
|
||||
drop decode-utf8 ;
|
||||
drop decode-utf8 ; inline
|
||||
|
||||
! Encoding UTF-8
|
||||
|
||||
|
|
|
|||
|
|
@ -192,19 +192,19 @@ UNION: boolean POSTPONE: t POSTPONE: f ;
|
|||
! Object protocol
|
||||
GENERIC: hashcode* ( depth obj -- code )
|
||||
|
||||
M: object hashcode* 2drop 0 ;
|
||||
M: object hashcode* 2drop 0 ; inline
|
||||
|
||||
M: f hashcode* 2drop 31337 ;
|
||||
M: f hashcode* 2drop 31337 ; inline
|
||||
|
||||
: hashcode ( obj -- code ) 3 swap hashcode* ; inline
|
||||
|
||||
GENERIC: equal? ( obj1 obj2 -- ? )
|
||||
|
||||
M: object equal? 2drop f ;
|
||||
M: object equal? 2drop f ; inline
|
||||
|
||||
TUPLE: identity-tuple ;
|
||||
|
||||
M: identity-tuple equal? 2drop f ;
|
||||
M: identity-tuple equal? 2drop f ; inline
|
||||
|
||||
: = ( obj1 obj2 -- ? )
|
||||
2dup eq? [ 2drop t ] [
|
||||
|
|
@ -213,9 +213,9 @@ M: identity-tuple equal? 2drop f ;
|
|||
|
||||
GENERIC: clone ( obj -- cloned )
|
||||
|
||||
M: object clone ;
|
||||
M: object clone ; inline
|
||||
|
||||
M: callstack clone (clone) ;
|
||||
M: callstack clone (clone) ; inline
|
||||
|
||||
! Tuple construction
|
||||
GENERIC: new ( class -- tuple )
|
||||
|
|
|
|||
|
|
@ -78,6 +78,6 @@ M: bignum >integer
|
|||
|
||||
M: real >integer
|
||||
dup most-negative-fixnum most-positive-fixnum between?
|
||||
[ >fixnum ] [ >bignum ] if ;
|
||||
[ >fixnum ] [ >bignum ] if ; inline
|
||||
|
||||
UNION: immediate fixnum POSTPONE: f ;
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ M: lexer skip-word ( lexer -- )
|
|||
] change-lexer-column ;
|
||||
|
||||
: still-parsing? ( lexer -- ? )
|
||||
[ line>> ] [ text>> ] bi length <= ;
|
||||
[ line>> ] [ text>> length ] bi <= ;
|
||||
|
||||
: still-parsing-line? ( lexer -- ? )
|
||||
[ column>> ] [ line-length>> ] bi < ;
|
||||
|
|
|
|||
|
|
@ -10,21 +10,21 @@ HELP: >float
|
|||
|
||||
HELP: bits>double ( n -- x )
|
||||
{ $values { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } { "x" float } }
|
||||
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
|
||||
{ $description "Creates a " { $link float } " object from a 64-bit binary representation. This word is usually used to reconstruct floats read from streams." } ;
|
||||
|
||||
{ bits>double bits>float double>bits float>bits } related-words
|
||||
|
||||
HELP: bits>float ( n -- x )
|
||||
{ $values { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } { "x" float } }
|
||||
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
|
||||
{ $description "Creates a " { $link float } " object from a 32-bit binary representation. This word is usually used to reconstruct floats read from streams." } ;
|
||||
|
||||
HELP: double>bits ( x -- n )
|
||||
{ $values { "x" float } { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } }
|
||||
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
|
||||
{ $description "Creates a 64-bit binary representation of a " { $link float } " object. This can be used in the process of writing a float to a stream." } ;
|
||||
|
||||
HELP: float>bits ( x -- n )
|
||||
{ $values { "x" float } { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } }
|
||||
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
|
||||
{ $description "Creates a 32-bit binary representation of a " { $link float } " object. This can be used in the process of writing a float to a stream." } ;
|
||||
|
||||
! Unsafe primitives
|
||||
HELP: float+ ( x y -- z )
|
||||
|
|
|
|||
|
|
@ -3,28 +3,28 @@
|
|||
USING: kernel math math.private ;
|
||||
IN: math.floats.private
|
||||
|
||||
M: fixnum >float fixnum>float ;
|
||||
M: bignum >float bignum>float ;
|
||||
M: fixnum >float fixnum>float ; inline
|
||||
M: bignum >float bignum>float ; inline
|
||||
|
||||
M: float >fixnum float>fixnum ;
|
||||
M: float >bignum float>bignum ;
|
||||
M: float >float ;
|
||||
M: float >fixnum float>fixnum ; inline
|
||||
M: float >bignum float>bignum ; inline
|
||||
M: float >float ; inline
|
||||
|
||||
M: float hashcode* nip float>bits ;
|
||||
M: float equal? over float? [ float= ] [ 2drop f ] if ;
|
||||
M: float number= float= ;
|
||||
M: float hashcode* nip float>bits ; inline
|
||||
M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
|
||||
M: float number= float= ; inline
|
||||
|
||||
M: float < float< ;
|
||||
M: float <= float<= ;
|
||||
M: float > float> ;
|
||||
M: float >= float>= ;
|
||||
M: float < float< ; inline
|
||||
M: float <= float<= ; inline
|
||||
M: float > float> ; inline
|
||||
M: float >= float>= ; inline
|
||||
|
||||
M: float + float+ ;
|
||||
M: float - float- ;
|
||||
M: float * float* ;
|
||||
M: float / float/f ;
|
||||
M: float /f float/f ;
|
||||
M: float /i float/f >integer ;
|
||||
M: float mod float-mod ;
|
||||
M: float + float+ ; inline
|
||||
M: float - float- ; inline
|
||||
M: float * float* ; inline
|
||||
M: float / float/f ; inline
|
||||
M: float /f float/f ; inline
|
||||
M: float /i float/f >integer ; inline
|
||||
M: float mod float-mod ; inline
|
||||
|
||||
M: real abs dup 0 < [ neg ] when ;
|
||||
M: real abs dup 0 < [ neg ] when ; inline
|
||||
|
|
|
|||
|
|
@ -5,79 +5,79 @@ USING: kernel kernel.private sequences
|
|||
sequences.private math math.private combinators ;
|
||||
IN: math.integers.private
|
||||
|
||||
M: integer numerator ;
|
||||
M: integer denominator drop 1 ;
|
||||
M: integer numerator ; inline
|
||||
M: integer denominator drop 1 ; inline
|
||||
|
||||
M: fixnum >fixnum ;
|
||||
M: fixnum >bignum fixnum>bignum ;
|
||||
M: fixnum >integer ;
|
||||
M: fixnum >fixnum ; inline
|
||||
M: fixnum >bignum fixnum>bignum ; inline
|
||||
M: fixnum >integer ; inline
|
||||
|
||||
M: fixnum hashcode* nip ;
|
||||
M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ;
|
||||
M: fixnum number= eq? ;
|
||||
M: fixnum hashcode* nip ; inline
|
||||
M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ; inline
|
||||
M: fixnum number= eq? ; inline
|
||||
|
||||
M: fixnum < fixnum< ;
|
||||
M: fixnum <= fixnum<= ;
|
||||
M: fixnum > fixnum> ;
|
||||
M: fixnum >= fixnum>= ;
|
||||
M: fixnum < fixnum< ; inline
|
||||
M: fixnum <= fixnum<= ; inline
|
||||
M: fixnum > fixnum> ; inline
|
||||
M: fixnum >= fixnum>= ; inline
|
||||
|
||||
M: fixnum + fixnum+ ;
|
||||
M: fixnum - fixnum- ;
|
||||
M: fixnum * fixnum* ;
|
||||
M: fixnum /i fixnum/i ;
|
||||
M: fixnum /f [ >float ] dip >float float/f ;
|
||||
M: fixnum + fixnum+ ; inline
|
||||
M: fixnum - fixnum- ; inline
|
||||
M: fixnum * fixnum* ; inline
|
||||
M: fixnum /i fixnum/i ; inline
|
||||
M: fixnum /f [ >float ] dip >float float/f ; inline
|
||||
|
||||
M: fixnum mod fixnum-mod ;
|
||||
M: fixnum mod fixnum-mod ; inline
|
||||
|
||||
M: fixnum /mod fixnum/mod ;
|
||||
M: fixnum /mod fixnum/mod ; inline
|
||||
|
||||
M: fixnum bitand fixnum-bitand ;
|
||||
M: fixnum bitor fixnum-bitor ;
|
||||
M: fixnum bitxor fixnum-bitxor ;
|
||||
M: fixnum shift >fixnum fixnum-shift ;
|
||||
M: fixnum bitand fixnum-bitand ; inline
|
||||
M: fixnum bitor fixnum-bitor ; inline
|
||||
M: fixnum bitxor fixnum-bitxor ; inline
|
||||
M: fixnum shift >fixnum fixnum-shift ; inline
|
||||
|
||||
M: fixnum bitnot fixnum-bitnot ;
|
||||
M: fixnum bitnot fixnum-bitnot ; inline
|
||||
|
||||
M: fixnum bit? neg shift 1 bitand 0 > ;
|
||||
M: fixnum bit? neg shift 1 bitand 0 > ; inline
|
||||
|
||||
: fixnum-log2 ( x -- n )
|
||||
0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;
|
||||
|
||||
M: fixnum (log2) fixnum-log2 ;
|
||||
M: fixnum (log2) fixnum-log2 ; inline
|
||||
|
||||
M: bignum >fixnum bignum>fixnum ;
|
||||
M: bignum >bignum ;
|
||||
M: bignum >fixnum bignum>fixnum ; inline
|
||||
M: bignum >bignum ; inline
|
||||
|
||||
M: bignum hashcode* nip >fixnum ;
|
||||
|
||||
M: bignum equal?
|
||||
over bignum? [ bignum= ] [
|
||||
swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if
|
||||
] if ;
|
||||
] if ; inline
|
||||
|
||||
M: bignum number= bignum= ;
|
||||
M: bignum number= bignum= ; inline
|
||||
|
||||
M: bignum < bignum< ;
|
||||
M: bignum <= bignum<= ;
|
||||
M: bignum > bignum> ;
|
||||
M: bignum >= bignum>= ;
|
||||
M: bignum < bignum< ; inline
|
||||
M: bignum <= bignum<= ; inline
|
||||
M: bignum > bignum> ; inline
|
||||
M: bignum >= bignum>= ; inline
|
||||
|
||||
M: bignum + bignum+ ;
|
||||
M: bignum - bignum- ;
|
||||
M: bignum * bignum* ;
|
||||
M: bignum /i bignum/i ;
|
||||
M: bignum mod bignum-mod ;
|
||||
M: bignum + bignum+ ; inline
|
||||
M: bignum - bignum- ; inline
|
||||
M: bignum * bignum* ; inline
|
||||
M: bignum /i bignum/i ; inline
|
||||
M: bignum mod bignum-mod ; inline
|
||||
|
||||
M: bignum /mod bignum/mod ;
|
||||
M: bignum /mod bignum/mod ; inline
|
||||
|
||||
M: bignum bitand bignum-bitand ;
|
||||
M: bignum bitor bignum-bitor ;
|
||||
M: bignum bitxor bignum-bitxor ;
|
||||
M: bignum shift >fixnum bignum-shift ;
|
||||
M: bignum bitand bignum-bitand ; inline
|
||||
M: bignum bitor bignum-bitor ; inline
|
||||
M: bignum bitxor bignum-bitxor ; inline
|
||||
M: bignum shift >fixnum bignum-shift ; inline
|
||||
|
||||
M: bignum bitnot bignum-bitnot ;
|
||||
M: bignum bit? bignum-bit? ;
|
||||
M: bignum (log2) bignum-log2 ;
|
||||
M: bignum bitnot bignum-bitnot ; inline
|
||||
M: bignum bit? bignum-bit? ; inline
|
||||
M: bignum (log2) bignum-log2 ; inline
|
||||
|
||||
! Converting ratios to floats. Based on FLOAT-RATIO from
|
||||
! sbcl/src/code/float.lisp, which has the following license:
|
||||
|
|
|
|||
|
|
@ -98,38 +98,38 @@ GENERIC: fp-infinity? ( x -- ? )
|
|||
GENERIC: fp-nan-payload ( x -- bits )
|
||||
|
||||
M: object fp-special?
|
||||
drop f ;
|
||||
drop f ; inline
|
||||
M: object fp-nan?
|
||||
drop f ;
|
||||
drop f ; inline
|
||||
M: object fp-qnan?
|
||||
drop f ;
|
||||
drop f ; inline
|
||||
M: object fp-snan?
|
||||
drop f ;
|
||||
drop f ; inline
|
||||
M: object fp-infinity?
|
||||
drop f ;
|
||||
drop f ; inline
|
||||
M: object fp-nan-payload
|
||||
drop f ;
|
||||
drop f ; inline
|
||||
|
||||
M: float fp-special?
|
||||
double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
|
||||
double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
|
||||
|
||||
M: float fp-nan-payload
|
||||
double>bits HEX: fffffffffffff bitand ; foldable flushable
|
||||
double>bits HEX: fffffffffffff bitand ; inline
|
||||
|
||||
M: float fp-nan?
|
||||
dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
|
||||
dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-qnan?
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-snan?
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-infinity?
|
||||
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
|
||||
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
|
||||
|
||||
: <fp-nan> ( payload -- nan )
|
||||
HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
|
||||
HEX: 7ff0000000000000 bitor bits>double ; inline
|
||||
|
||||
: next-float ( m -- n )
|
||||
double>bits
|
||||
|
|
@ -137,7 +137,7 @@ M: float fp-infinity?
|
|||
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
|
||||
1 + bits>double ! positive
|
||||
] if
|
||||
] if ; foldable flushable
|
||||
] if ; inline
|
||||
|
||||
: prev-float ( m -- n )
|
||||
double>bits
|
||||
|
|
@ -145,7 +145,7 @@ M: float fp-infinity?
|
|||
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
|
||||
1 - bits>double ! positive non-zero
|
||||
] if
|
||||
] if ; foldable flushable
|
||||
] if ; inline
|
||||
|
||||
: next-power-of-2 ( m -- n )
|
||||
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
|
||||
|
|
|
|||
|
|
@ -15,24 +15,24 @@ GENERIC: <=> ( obj1 obj2 -- <=> )
|
|||
|
||||
: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
|
||||
|
||||
M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
|
||||
M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline
|
||||
|
||||
GENERIC: before? ( obj1 obj2 -- ? )
|
||||
GENERIC: after? ( obj1 obj2 -- ? )
|
||||
GENERIC: before=? ( obj1 obj2 -- ? )
|
||||
GENERIC: after=? ( obj1 obj2 -- ? )
|
||||
|
||||
M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
|
||||
M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
|
||||
M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
|
||||
M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
|
||||
M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline
|
||||
M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline
|
||||
M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline
|
||||
M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline
|
||||
|
||||
M: real before? ( obj1 obj2 -- ? ) < ;
|
||||
M: real after? ( obj1 obj2 -- ? ) > ;
|
||||
M: real before=? ( obj1 obj2 -- ? ) <= ;
|
||||
M: real after=? ( obj1 obj2 -- ? ) >= ;
|
||||
M: real before? ( obj1 obj2 -- ? ) < ; inline
|
||||
M: real after? ( obj1 obj2 -- ? ) > ; inline
|
||||
M: real before=? ( obj1 obj2 -- ? ) <= ; inline
|
||||
M: real after=? ( obj1 obj2 -- ? ) >= ; inline
|
||||
|
||||
: min ( x y -- z ) [ before? ] most ; inline
|
||||
: min ( x y -- z ) [ before? ] most ; inline
|
||||
: max ( x y -- z ) [ after? ] most ; inline
|
||||
: clamp ( x min max -- y ) [ max ] dip min ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -11,24 +11,24 @@ TUPLE: sbuf
|
|||
: <sbuf> ( n -- sbuf ) 0 <string> 0 sbuf boa ; inline
|
||||
|
||||
M: sbuf set-nth-unsafe
|
||||
[ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ;
|
||||
[ >fixnum ] [ >fixnum ] [ underlying>> ] tri* set-string-nth ; inline
|
||||
|
||||
M: sbuf new-sequence
|
||||
drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ;
|
||||
drop [ 0 <string> ] [ >fixnum ] bi sbuf boa ; inline
|
||||
|
||||
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
|
||||
|
||||
M: sbuf like
|
||||
drop dup sbuf? [
|
||||
dup string? [ dup length sbuf boa ] [ >sbuf ] if
|
||||
] unless ;
|
||||
] unless ; inline
|
||||
|
||||
M: sbuf new-resizable drop <sbuf> ;
|
||||
M: sbuf new-resizable drop <sbuf> ; inline
|
||||
|
||||
M: sbuf equal?
|
||||
over sbuf? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: string new-resizable drop <sbuf> ;
|
||||
M: string new-resizable drop <sbuf> ; inline
|
||||
|
||||
M: string like
|
||||
#! If we have a string, we're done.
|
||||
|
|
@ -41,6 +41,6 @@ M: string like
|
|||
2dup length eq?
|
||||
[ nip dup reset-string-hashcode ] [ resize-string ] if
|
||||
] [ >string ] if
|
||||
] unless ;
|
||||
] unless ; inline
|
||||
|
||||
INSTANCE: sbuf growable
|
||||
|
|
|
|||
|
|
@ -18,14 +18,14 @@ GENERIC: clone-like ( seq exemplar -- newseq ) flushable
|
|||
: new-like ( len exemplar quot -- seq )
|
||||
over [ [ new-sequence ] dip call ] dip like ; inline
|
||||
|
||||
M: sequence like drop ;
|
||||
M: sequence like drop ; inline
|
||||
|
||||
GENERIC: lengthen ( n seq -- )
|
||||
GENERIC: shorten ( n seq -- )
|
||||
|
||||
M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
|
||||
M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ; inline
|
||||
|
||||
M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
|
||||
M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ; inline
|
||||
|
||||
: empty? ( seq -- ? ) length 0 = ; inline
|
||||
|
||||
|
|
@ -82,25 +82,25 @@ GENERIC: resize ( n seq -- newseq ) flushable
|
|||
GENERIC: nth-unsafe ( n seq -- elt ) flushable
|
||||
GENERIC: set-nth-unsafe ( elt n seq -- )
|
||||
|
||||
M: sequence nth bounds-check nth-unsafe ;
|
||||
M: sequence set-nth bounds-check set-nth-unsafe ;
|
||||
M: sequence nth bounds-check nth-unsafe ; inline
|
||||
M: sequence set-nth bounds-check set-nth-unsafe ; inline
|
||||
|
||||
M: sequence nth-unsafe nth ;
|
||||
M: sequence set-nth-unsafe set-nth ;
|
||||
M: sequence nth-unsafe nth ; inline
|
||||
M: sequence set-nth-unsafe set-nth ; inline
|
||||
|
||||
: change-nth-unsafe ( i seq quot -- )
|
||||
[ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
|
||||
|
||||
! The f object supports the sequence protocol trivially
|
||||
M: f length drop 0 ;
|
||||
M: f nth-unsafe nip ;
|
||||
M: f like drop [ f ] when-empty ;
|
||||
M: f length drop 0 ; inline
|
||||
M: f nth-unsafe nip ; inline
|
||||
M: f like drop [ f ] when-empty ; inline
|
||||
|
||||
INSTANCE: f immutable-sequence
|
||||
|
||||
! Integers support the sequence protocol
|
||||
M: integer length ;
|
||||
M: integer nth-unsafe drop ;
|
||||
M: integer length ; inline
|
||||
M: integer nth-unsafe drop ; inline
|
||||
|
||||
INSTANCE: integer immutable-sequence
|
||||
|
||||
|
|
@ -113,8 +113,8 @@ TUPLE: iota { n integer read-only } ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
M: iota length n>> ;
|
||||
M: iota nth-unsafe drop ;
|
||||
M: iota length n>> ; inline
|
||||
M: iota nth-unsafe drop ; inline
|
||||
|
||||
INSTANCE: iota immutable-sequence
|
||||
|
||||
|
|
@ -185,12 +185,12 @@ MIXIN: virtual-sequence
|
|||
GENERIC: virtual-seq ( seq -- seq' )
|
||||
GENERIC: virtual@ ( n seq -- n' seq' )
|
||||
|
||||
M: virtual-sequence nth virtual@ nth ;
|
||||
M: virtual-sequence set-nth virtual@ set-nth ;
|
||||
M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
|
||||
M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
|
||||
M: virtual-sequence like virtual-seq like ;
|
||||
M: virtual-sequence new-sequence virtual-seq new-sequence ;
|
||||
M: virtual-sequence nth virtual@ nth ; inline
|
||||
M: virtual-sequence set-nth virtual@ set-nth ; inline
|
||||
M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline
|
||||
M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline
|
||||
M: virtual-sequence like virtual-seq like ; inline
|
||||
M: virtual-sequence new-sequence virtual-seq new-sequence ; inline
|
||||
|
||||
INSTANCE: virtual-sequence sequence
|
||||
|
||||
|
|
@ -199,11 +199,9 @@ TUPLE: reversed { seq read-only } ;
|
|||
|
||||
C: <reversed> reversed
|
||||
|
||||
M: reversed virtual-seq seq>> ;
|
||||
|
||||
M: reversed virtual@ seq>> [ length swap - 1 - ] keep ;
|
||||
|
||||
M: reversed length seq>> length ;
|
||||
M: reversed virtual-seq seq>> ; inline
|
||||
M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline
|
||||
M: reversed length seq>> length ; inline
|
||||
|
||||
INSTANCE: reversed virtual-sequence
|
||||
|
||||
|
|
@ -233,11 +231,11 @@ TUPLE: slice-error from to seq reason ;
|
|||
check-slice
|
||||
slice boa ; inline
|
||||
|
||||
M: slice virtual-seq seq>> ;
|
||||
M: slice virtual-seq seq>> ; inline
|
||||
|
||||
M: slice virtual@ [ from>> + ] [ seq>> ] bi ;
|
||||
M: slice virtual@ [ from>> + ] [ seq>> ] bi ; inline
|
||||
|
||||
M: slice length [ to>> ] [ from>> ] bi - ;
|
||||
M: slice length [ to>> ] [ from>> ] bi - ; inline
|
||||
|
||||
: short ( seq n -- seq n' ) over length min ; inline
|
||||
|
||||
|
|
@ -260,8 +258,8 @@ TUPLE: repetition { len read-only } { elt read-only } ;
|
|||
|
||||
C: <repetition> repetition
|
||||
|
||||
M: repetition length len>> ;
|
||||
M: repetition nth-unsafe nip elt>> ;
|
||||
M: repetition length len>> ; inline
|
||||
M: repetition nth-unsafe nip elt>> ; inline
|
||||
|
||||
INSTANCE: repetition immutable-sequence
|
||||
|
||||
|
|
@ -316,9 +314,9 @@ PRIVATE>
|
|||
(copy) drop ; inline
|
||||
|
||||
M: sequence clone-like
|
||||
[ dup length ] dip new-sequence [ 0 swap copy ] keep ;
|
||||
[ dup length ] dip new-sequence [ 0 swap copy ] keep ; inline
|
||||
|
||||
M: immutable-sequence clone-like like ;
|
||||
M: immutable-sequence clone-like like ; inline
|
||||
|
||||
: push-all ( src dest -- ) [ length ] [ copy ] bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -18,23 +18,6 @@ TUPLE: hello length ;
|
|||
|
||||
[ "xyz" 4 >>length ] [ no-method? ] must-fail-with
|
||||
|
||||
[ t ] [ r/o-test \ foo>> method "foldable" word-prop ] unit-test
|
||||
[ t ] [ r/o-test \ foo>> method "flushable" word-prop ] unit-test
|
||||
|
||||
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
|
||||
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
|
||||
|
||||
! See if declarations are cleared on redefinition
|
||||
[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test
|
||||
|
||||
[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
|
||||
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
|
||||
|
||||
[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test
|
||||
|
||||
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
|
||||
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
|
||||
|
||||
! Test protocol slots
|
||||
SLOT: my-protocol-slot-test
|
||||
|
||||
|
|
|
|||
|
|
@ -24,7 +24,8 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
|
|||
[ create-method ] 2dip
|
||||
[ [ props>> ] [ drop ] [ ] tri* update ]
|
||||
[ drop define ]
|
||||
3bi ;
|
||||
[ 2drop make-inline ]
|
||||
3tri ;
|
||||
|
||||
GENERIC# reader-quot 1 ( class slot-spec -- quot )
|
||||
|
||||
|
|
@ -41,11 +42,7 @@ M: object reader-quot
|
|||
dup t "reader" set-word-prop ;
|
||||
|
||||
: reader-props ( slot-spec -- assoc )
|
||||
[
|
||||
[ "reading" set ]
|
||||
[ read-only>> [ t "foldable" set ] when ] bi
|
||||
t "flushable" set
|
||||
] H{ } make-assoc ;
|
||||
"reading" associate ;
|
||||
|
||||
: define-reader-generic ( name -- )
|
||||
reader-word (( object -- value )) define-simple-generic ;
|
||||
|
|
|
|||
|
|
@ -37,24 +37,24 @@ M: string hashcode*
|
|||
[ ] [ dup rehash-string string-hashcode ] ?if ;
|
||||
|
||||
M: string length
|
||||
length>> ;
|
||||
length>> ; inline
|
||||
|
||||
M: string nth-unsafe
|
||||
[ >fixnum ] dip string-nth ;
|
||||
[ >fixnum ] dip string-nth ; inline
|
||||
|
||||
M: string set-nth-unsafe
|
||||
dup reset-string-hashcode
|
||||
[ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ;
|
||||
[ >fixnum ] [ >fixnum ] [ ] tri* set-string-nth ; inline
|
||||
|
||||
M: string clone
|
||||
(clone) [ clone ] change-aux ;
|
||||
(clone) [ clone ] change-aux ; inline
|
||||
|
||||
M: string resize resize-string ;
|
||||
M: string resize resize-string ; inline
|
||||
|
||||
: 1string ( ch -- str ) 1 swap <string> ;
|
||||
|
||||
: >string ( seq -- str ) "" clone-like ;
|
||||
|
||||
M: string new-sequence drop 0 <string> ;
|
||||
M: string new-sequence drop 0 <string> ; inline
|
||||
|
||||
INSTANCE: string sequence
|
||||
|
|
|
|||
|
|
@ -15,10 +15,10 @@ TUPLE: vector
|
|||
M: vector like
|
||||
drop dup vector? [
|
||||
dup array? [ dup length vector boa ] [ >vector ] if
|
||||
] unless ;
|
||||
] unless ; inline
|
||||
|
||||
M: vector new-sequence
|
||||
drop [ f <array> ] [ >fixnum ] bi vector boa ;
|
||||
drop [ f <array> ] [ >fixnum ] bi vector boa ; inline
|
||||
|
||||
M: vector equal?
|
||||
over vector? [ sequence= ] [ 2drop f ] if ;
|
||||
|
|
@ -34,9 +34,9 @@ M: array like
|
|||
2dup length eq?
|
||||
[ nip ] [ resize-array ] if
|
||||
] [ >array ] if
|
||||
] unless ;
|
||||
] unless ; inline
|
||||
|
||||
M: sequence new-resizable drop <vector> ;
|
||||
M: sequence new-resizable drop <vector> ; inline
|
||||
|
||||
INSTANCE: vector growable
|
||||
|
||||
|
|
|
|||
|
|
@ -122,6 +122,6 @@ DEFER: x
|
|||
[
|
||||
all-words [
|
||||
"compiled-uses" word-prop
|
||||
keys [ "forgotten" word-prop ] any?
|
||||
] filter
|
||||
keys [ "forgotten" word-prop ] filter
|
||||
] map harvest
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: words
|
|||
|
||||
M: word execute (execute) ;
|
||||
|
||||
M: word ?execute execute( -- value ) ;
|
||||
M: word ?execute execute( -- value ) ; inline
|
||||
|
||||
M: word <=>
|
||||
[ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
|
||||
|
|
@ -213,7 +213,7 @@ M: word forget*
|
|||
] if ;
|
||||
|
||||
M: word hashcode*
|
||||
nip 1 slot { fixnum } declare ; foldable
|
||||
nip 1 slot { fixnum } declare ; inline foldable
|
||||
|
||||
M: word literalize <wrapper> ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue