diff --git a/basis/biassocs/biassocs-tests.factor b/basis/biassocs/biassocs-tests.factor index 2ef54441e1..af10eb18e4 100644 --- a/basis/biassocs/biassocs-tests.factor +++ b/basis/biassocs/biassocs-tests.factor @@ -1,4 +1,4 @@ -USING: biassocs assocs namespaces tools.test ; +USING: biassocs assocs namespaces tools.test hashtables kernel ; IN: biassocs.tests "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 diff --git a/basis/biassocs/biassocs.factor b/basis/biassocs/biassocs.factor index 5956589ba5..7daa478f54 100644 --- a/basis/biassocs/biassocs.factor +++ b/basis/biassocs/biassocs.factor @@ -43,4 +43,7 @@ M: biassoc new-assoc INSTANCE: biassoc assoc : >biassoc ( assoc -- biassoc ) - T{ biassoc } assoc-clone-like ; \ No newline at end of file + T{ biassoc } assoc-clone-like ; + +M: biassoc clone + [ from>> ] [ to>> ] bi [ clone ] bi@ biassoc boa ; diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 7aea3c458a..0b5a63a906 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -44,33 +44,33 @@ PRIVATE> : ( n -- bit-array ) dup bits>bytes 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 ; +M: bit-array new-sequence drop ; 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 ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor old mode 100644 new mode 100755 index 3b8d996f34..504acc74b0 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -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? ; diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 38842696d7..67added49d 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -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 ; diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index a160272b21..20a5cc867c 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -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? diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 73ff49259a..faf6968670 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -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? diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor old mode 100644 new mode 100755 index 9b278dde9b..fca35a5653 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -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 ; diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index a667ea727f..cdbeabe532 100644 --- a/basis/compiler/tree/propagation/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -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 ] diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 1586f2ca0b..3836e0f3ba 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -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 ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 7c684f5b7f..a9b77681fb 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -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 ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index eb9591c40c..321941741e 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -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 diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index 3dd2c4998a..a11264fb7f 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/basis/compiler/tree/propagation/propagation.factor @@ -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) ; diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 5837d59ef9..88c9831a24 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -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 ] diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index f68760a4e1..83579d2beb 100644 --- a/basis/grouping/grouping.factor +++ b/basis/grouping/grouping.factor @@ -18,41 +18,41 @@ GENERIC: group@ ( n groups -- from to seq ) M: chunking-seq set-nth group@ 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@ ; +M: slice-chunking nth group@ ; 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> diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index 6b7a6ae8ca..08d794090c 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -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 } diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 2e9aac2ac9..fde5cf9b12 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -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 ; : ( 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 ; diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor index 16132ca810..00d3bc7509 100644 --- a/basis/io/encodings/ascii/ascii.factor +++ b/basis/io/encodings/ascii/ascii.factor @@ -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 diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index 444ba98c7d..43463bd3f1 100755 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -47,10 +47,8 @@ IN: io.files.windows GetLastError ERROR_ALREADY_EXISTS = not ; : set-file-pointer ( handle length method -- ) - [ dupd d>w/w ] dip SetFilePointer - INVALID_SET_FILE_POINTER = [ - CloseHandle "SetFilePointer failed" throw - ] when drop ; + [ [ handle>> ] dip d>w/w ] dip SetFilePointer + INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ; HOOK: open-append os ( path -- win32-file ) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 4587556e0c..f57f7b6d47 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -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 + +[ ] [ + + console-vm "-run=listener" 2array >>command + "vocab:io/launcher/windows/nt/test/input.txt" >>stdin + try-process +] unit-test diff --git a/basis/io/launcher/windows/nt/nt.factor b/basis/io/launcher/windows/nt/nt.factor index 5ebb38abc2..e62373cbd7 100755 --- a/basis/io/launcher/windows/nt/nt.factor +++ b/basis/io/launcher/windows/nt/nt.factor @@ -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 [ ! 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* &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? &dispose handle>> ; + CreateFile dup invalid-handle? &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 diff --git a/basis/io/launcher/windows/nt/test/input.txt b/basis/io/launcher/windows/nt/test/input.txt new file mode 100755 index 0000000000..99c3cc6fb1 --- /dev/null +++ b/basis/io/launcher/windows/nt/test/input.txt @@ -0,0 +1 @@ +USE: system 0 exit diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index e469140ff4..4de49c06a7 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -9,9 +9,9 @@ C: bits : make-bits ( number -- bits ) [ T{ bits f 0 0 } ] [ dup abs log2 1 + ] 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 diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index 832a9e64ba..ce94dfaca8 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -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 diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 801522b376..0daea7f706 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -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 diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 07c3d8fae7..a2bdf6d98f 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -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 ; diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 8ea28b2235..99997ab8cb 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -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 - ] if ; +: points>interval ( seq -- interval nan? ) + [ first fp-nan? not ] partition + [ + [ [ ] [ endpoint-min ] map-reduce ] + [ [ ] [ endpoint-max ] map-reduce ] bi + + ] + [ 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 ; diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index d28afa1413..58cb2b09db 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -12,11 +12,9 @@ TUPLE: 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) diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 7da92cd154..dcb8e87e7c 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -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 <= ; diff --git a/basis/multiline/multiline-docs.factor b/basis/multiline/multiline-docs.factor index 0977acd1cd..fd91c440d7 100644 --- a/basis/multiline/multiline-docs.factor +++ b/basis/multiline/multiline-docs.factor @@ -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:" diff --git a/basis/multiline/multiline-tests.factor b/basis/multiline/multiline-tests.factor index 2458589d27..25610ed660 100644 --- a/basis/multiline/multiline-tests.factor +++ b/basis/multiline/multiline-tests.factor @@ -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 diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index e4334f1201..4eaafe1f18 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -4,6 +4,8 @@ USING: namespaces make parser lexer kernel sequences words quotations math accessors locals ; IN: multiline +ERROR: bad-heredoc identifier ; + > ; @@ -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 ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0edbe5e53d..ea8f6f5f49 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -158,6 +158,8 @@ M: bad-executable summary \ [ infer- ] "special" set-word-prop +\ t "flushable" set-word-prop + : infer-effect-unsafe ( word -- ) pop-literal nip add-effect-input diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 761dbd816a..92e7541616 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -54,17 +54,17 @@ TUPLE: CLASS-array [ \ CLASS [ tuple-prototype 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 ; +M: CLASS-array new-sequence drop ; inline : >CLASS-array ( seq -- tuple-array ) 0 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 diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor index 47a6c2090a..b70c7c5050 100644 --- a/basis/vectors/functor/functor.factor +++ b/basis/vectors/functor/functor.factor @@ -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 [ ] [ >fixnum ] bi V boa ; +M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; inline -M: A new-resizable drop ; +M: A new-resizable drop ; inline M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 864700cb0f..d6a08325d9 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -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 +TUPLE: ole32-error code message ; -M: ole32-error error. - "COM method failed: " print error-code>> n>win32-error-string print ; +: ( code -- error ) + dup n>win32-error-string \ ole32-error boa ; : ole32-error ( hresult -- ) dup succeeded? [ drop ] [ throw ] if ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor index ec38e3be5b..d98ea3d103 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -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 diff --git a/core/arrays/arrays.factor b/core/arrays/arrays.factor index dd70e45b6b..fa4d4b2f69 100644 --- a/core/arrays/arrays.factor +++ b/core/arrays/arrays.factor @@ -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 ; +M: object new-sequence drop 0 ; inline -M: f new-sequence drop [ f ] [ 0 ] if-zero ; +M: f new-sequence drop [ f ] [ 0 ] if-zero ; inline M: array equal? over array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 8b6809236c..e633a54843 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -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 ; +M: sequence new-assoc drop ; 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 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 diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 72989ac447..3c89a5f63e 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -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 diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor index fc3d9501c7..287e972405 100644 --- a/core/byte-vectors/byte-vectors.factor +++ b/core/byte-vectors/byte-vectors.factor @@ -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 ; +M: byte-array new-resizable drop ; inline INSTANCE: byte-vector growable diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index c74c8f3b50..8eeb4ce357 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -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 ; diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index d7fba97977..1c1db09cf4 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 6d0c2c8242..1452abd4b4 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 ; diff --git a/core/growable/growable.factor b/core/growable/growable.factor index 754a3293d1..68a8de3d43 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -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 diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 03bc3e01fd..8547f53a0e 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -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 ; +M: assoc new-assoc drop ; inline -M: f new-assoc drop ; +M: f new-assoc drop ; 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* ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index a722655cad..2911385c09 100755 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -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 diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index d6350e0420..838d877a40 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -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 ) diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 42898fc085..5738c2ec99 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -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 ; diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 036c7d9721..b3bd3cacdb 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -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 < ; diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index 1305f2a18d..ed4947e1f5 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -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 ) diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 2a22dc4330..160b220173 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -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 diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 2b35ef76fd..75abd8087e 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -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: diff --git a/core/math/math.factor b/core/math/math.factor index a00f2240e1..1213e13a1f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -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 : ( 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 diff --git a/core/math/order/order.factor b/core/math/order/order.factor index 435eec9b96..707dc02af2 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -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 diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 0b2c170c1e..49b6ec1374 100644 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -11,24 +11,24 @@ TUPLE: sbuf : ( n -- sbuf ) 0 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 ] [ >fixnum ] bi sbuf boa ; + drop [ 0 ] [ >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 ; +M: sbuf new-resizable drop ; inline M: sbuf equal? over sbuf? [ sequence= ] [ 2drop f ] if ; -M: string new-resizable drop ; +M: string new-resizable drop ; 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 diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 84b80794a3..031d5f7b4a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 } ; > ; -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 -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 -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 ; diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 81251d728f..d22ca31d00 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -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 diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 7b117ac412..3cf9b261dc 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -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 ; diff --git a/core/strings/strings.factor b/core/strings/strings.factor index ffcefab78b..8ab0409318 100644 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -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 ( seq -- str ) "" clone-like ; -M: string new-sequence drop 0 ; +M: string new-sequence drop 0 ; inline INSTANCE: string sequence diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index 1bdda7b69d..4bbc787294 100644 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -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 ] [ >fixnum ] bi vector boa ; + drop [ f ] [ >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 ; +M: sequence new-resizable drop ; inline INSTANCE: vector growable diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 0ecf7b65f0..c3dacbaf14 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -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 diff --git a/core/words/words.factor b/core/words/words.factor index 2ebdb8b7a8..19a2ce551d 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -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 ;