From: John Benediktsson Date: Wed, 9 Sep 2020 21:41:17 +0000 (-0700) Subject: basis: removing unnecessary method stack effects. X-Git-Tag: 0.99~3098 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=115b7b62df777f85f54571eb49109c0f0a1d2b4f basis: removing unnecessary method stack effects. --- diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index ee6ad00e83..d9656b4077 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -166,10 +166,10 @@ ERROR: not-enough-bits n bit-reader ; bs bytes>> subseq endian> execute( seq -- x ) n bs subseq-endian execute( bignum n bs -- bits ) ; -M: lsb0-bit-reader peek ( n bs -- bits ) +M: lsb0-bit-reader peek \ le> \ subseq>bits-le (peek) ; -M: msb0-bit-reader peek ( n bs -- bits ) +M: msb0-bit-reader peek \ be> \ subseq>bits-be (peek) ; :: bit-writer-bytes ( writer -- bytes ) diff --git a/basis/channels/channels.factor b/basis/channels/channels.factor index 870085f77a..7c278d5977 100644 --- a/basis/channels/channels.factor +++ b/basis/channels/channels.factor @@ -31,11 +31,11 @@ GENERIC: from ( channel -- value ) PRIVATE> -M: channel to ( value channel -- ) +M: channel to dup receivers>> [ dup wait to ] [ nip (to) ] if-empty ; -M: channel from ( channel -- value ) +M: channel from [ self ] dip notify senders>> [ (from) ] unless-empty diff --git a/basis/channels/remote/remote.factor b/basis/channels/remote/remote.factor index 8b30a5236c..a1c90dc6e8 100644 --- a/basis/channels/remote/remote.factor +++ b/basis/channels/remote/remote.factor @@ -60,10 +60,10 @@ C: remote-channel PRIVATE> -M: remote-channel to ( value remote-channel -- ) +M: remote-channel to [ id>> swap to-message boa ] keep send-message drop ; -M: remote-channel from ( remote-channel -- value ) +M: remote-channel from [ id>> from-message boa ] keep send-message ; [ diff --git a/basis/checksums/adler-32/adler-32.factor b/basis/checksums/adler-32/adler-32.factor index 67c2842b74..0fc9985d60 100644 --- a/basis/checksums/adler-32/adler-32.factor +++ b/basis/checksums/adler-32/adler-32.factor @@ -8,7 +8,7 @@ SINGLETON: adler-32 CONSTANT: adler-32-modulus 65521 -M: adler-32 checksum-bytes ( bytes checksum -- value ) +M: adler-32 checksum-bytes drop [ sum 1 + ] [ [ dup length [1,b] vdot ] [ length ] bi + ] bi diff --git a/basis/checksums/bsd/bsd.factor b/basis/checksums/bsd/bsd.factor index 0b61551a50..86d1cc2e16 100644 --- a/basis/checksums/bsd/bsd.factor +++ b/basis/checksums/bsd/bsd.factor @@ -5,7 +5,7 @@ IN: checksums.bsd SINGLETON: bsd -M: bsd checksum-bytes ( bytes checksum -- value ) +M: bsd checksum-bytes drop 0 [ [ [ -1 shift ] [ 1 bitand 15 shift ] bi + ] dip + 0xffff bitand diff --git a/basis/checksums/fnv1/fnv1.factor b/basis/checksums/fnv1/fnv1.factor index b9f4d1830e..f60e97dbf4 100644 --- a/basis/checksums/fnv1/fnv1.factor +++ b/basis/checksums/fnv1/fnv1.factor @@ -38,67 +38,67 @@ CONSTANT: fnv1-256-basis 0xdd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b CONSTANT: fnv1-512-basis 0xb86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9 CONSTANT: fnv1-1024-basis 0x5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3 -M: fnv1-32 checksum-bytes ( bytes checksum -- value ) +M: fnv1-32 checksum-bytes drop fnv1-32-basis swap [ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ; -M: fnv1a-32 checksum-bytes ( bytes checksum -- value ) +M: fnv1a-32 checksum-bytes drop fnv1-32-basis swap [ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ; -M: fnv1-64 checksum-bytes ( bytes checksum -- value ) +M: fnv1-64 checksum-bytes drop fnv1-64-basis swap [ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ; -M: fnv1a-64 checksum-bytes ( bytes checksum -- value ) +M: fnv1a-64 checksum-bytes drop fnv1-64-basis swap [ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ; -M: fnv1-128 checksum-bytes ( bytes checksum -- value ) +M: fnv1-128 checksum-bytes drop fnv1-128-basis swap [ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ; -M: fnv1a-128 checksum-bytes ( bytes checksum -- value ) +M: fnv1a-128 checksum-bytes drop fnv1-128-basis swap [ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ; -M: fnv1-256 checksum-bytes ( bytes checksum -- value ) +M: fnv1-256 checksum-bytes drop fnv1-256-basis swap [ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ; -M: fnv1a-256 checksum-bytes ( bytes checksum -- value ) +M: fnv1a-256 checksum-bytes drop fnv1-256-basis swap [ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ; -M: fnv1-512 checksum-bytes ( bytes checksum -- value ) +M: fnv1-512 checksum-bytes drop fnv1-512-basis swap [ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ; -M: fnv1a-512 checksum-bytes ( bytes checksum -- value ) +M: fnv1a-512 checksum-bytes drop fnv1-512-basis swap [ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ; -M: fnv1-1024 checksum-bytes ( bytes checksum -- value ) +M: fnv1-1024 checksum-bytes drop fnv1-1024-basis swap [ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ; -M: fnv1a-1024 checksum-bytes ( bytes checksum -- value ) +M: fnv1a-1024 checksum-bytes drop fnv1-1024-basis swap [ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ; diff --git a/basis/checksums/murmur/murmur.factor b/basis/checksums/murmur/murmur.factor index 441a59eaee..d18b1318a5 100644 --- a/basis/checksums/murmur/murmur.factor +++ b/basis/checksums/murmur/murmur.factor @@ -47,7 +47,7 @@ CONSTANT: n 0xe6546b64 PRIVATE> -M: murmur3-32 checksum-bytes ( bytes checksum -- value ) +M: murmur3-32 checksum-bytes seed>> 32 bits main-loop end-case avalanche ; INSTANCE: murmur3-32 checksum diff --git a/basis/checksums/openssl/openssl.factor b/basis/checksums/openssl/openssl.factor index ef10076fda..0bd00fcfd7 100644 --- a/basis/checksums/openssl/openssl.factor +++ b/basis/checksums/openssl/openssl.factor @@ -38,13 +38,13 @@ M: evp-md-context dispose* : set-digest ( name ctx -- ) handle>> swap digest-named f EVP_DigestInit_ex ssl-error ; -M: openssl-checksum initialize-checksum-state ( checksum -- evp-md-context ) +M: openssl-checksum initialize-checksum-state maybe-init-ssl name>> [ set-digest ] keep ; -M: evp-md-context add-checksum-bytes ( ctx bytes -- ctx' ) +M: evp-md-context add-checksum-bytes [ dup handle>> ] dip dup length EVP_DigestUpdate ssl-error ; -M: evp-md-context get-checksum ( ctx -- value ) +M: evp-md-context get-checksum handle>> { { int EVP_MAX_MD_SIZE } int } [ EVP_DigestFinal_ex ssl-error ] with-out-parameters diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index 175d2df225..5b0a477857 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -116,7 +116,7 @@ M: struct-mirror delete-at M: struct-mirror clear-assoc object>> reset-struct-slots ; -M: struct-mirror >alist ( mirror -- alist ) +M: struct-mirror >alist object>> [ [ drop "underlying" ] [ >c-ptr ] bi 2array 1array ] [ diff --git a/basis/colors/gray/gray.factor b/basis/colors/gray/gray.factor index c6f576f58c..9b71b35837 100644 --- a/basis/colors/gray/gray.factor +++ b/basis/colors/gray/gray.factor @@ -7,7 +7,7 @@ TUPLE: gray < color { gray read-only } { alpha read-only } ; C: gray -M: gray >rgba ( gray -- rgba ) +M: gray >rgba [ gray>> dup dup ] [ alpha>> ] bi ; inline M: gray red>> gray>> ; diff --git a/basis/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor index addc518e89..1f2528e880 100644 --- a/basis/colors/hsv/hsv.factor +++ b/basis/colors/hsv/hsv.factor @@ -29,7 +29,7 @@ C: hsva PRIVATE> -M: hsva >rgba ( hsva -- rgba ) +M: hsva >rgba [ dup Hi { diff --git a/basis/colors/ryb/ryb.factor b/basis/colors/ryb/ryb.factor index d96cc15f6a..e8a6137b64 100644 --- a/basis/colors/ryb/ryb.factor +++ b/basis/colors/ryb/ryb.factor @@ -61,7 +61,7 @@ C: ryba PRIVATE> -M: ryba >rgba ( ryba -- rgba ) +M: ryba >rgba [ [ red>> ] [ yellow>> ] [ blue>> ] tri [ ryb>rgb ] normalized diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 06b18597c8..d32cf013ac 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -95,7 +95,7 @@ IN: compiler.cfg.builder.alien [ stack-params get [ caller-stack-cleanup ] keep ] } cleave ; -M: #alien-invoke emit-node ( block node -- block' ) +M: #alien-invoke emit-node params>> [ [ params>alien-insn-params ] @@ -104,7 +104,7 @@ M: #alien-invoke emit-node ( block node -- block' ) ] [ caller-return ] bi ; -M: #alien-indirect emit-node ( block node -- block' ) +M: #alien-indirect emit-node params>> [ [ ds-pop ^^unbox-any-c-ptr ] dip @@ -113,7 +113,7 @@ M: #alien-indirect emit-node ( block node -- block' ) ] [ caller-return ] bi ; -M: #alien-assembly emit-node ( block node -- block' ) +M: #alien-assembly emit-node params>> [ [ params>alien-insn-params ] @@ -167,7 +167,7 @@ M: #alien-assembly emit-node ( block node -- block' ) : emit-callback-outputs ( block params -- ) [ emit-callback-return ] keep callback-stack-cleanup ; -M: #alien-callback emit-node ( block node -- block' ) +M: #alien-callback emit-node dup params>> xt>> dup [ t cfg get frame-pointer?<< diff --git a/basis/compiler/cfg/builder/alien/boxing/boxing.factor b/basis/compiler/cfg/builder/alien/boxing/boxing.factor index 075a2df084..777c4ec8e6 100644 --- a/basis/compiler/cfg/builder/alien/boxing/boxing.factor +++ b/basis/compiler/cfg/builder/alien/boxing/boxing.factor @@ -88,7 +88,7 @@ M: long-long-type unbox int-rep long-long-on-stack? long-long-odd-register? 3array int-rep long-long-on-stack? f 3array 2array record-reg-reps ; -M: struct-c-type unbox ( src c-type -- vregs reps ) +M: struct-c-type unbox [ ^^unbox-any-c-ptr ] dip explode-struct ; : frob-struct ( c-type -- c-type ) diff --git a/basis/compiler/cfg/builder/alien/params/params.factor b/basis/compiler/cfg/builder/alien/params/params.factor index 0713115d09..609c7309bc 100644 --- a/basis/compiler/cfg/builder/alien/params/params.factor +++ b/basis/compiler/cfg/builder/alien/params/params.factor @@ -8,11 +8,11 @@ SYMBOL: stack-params GENERIC: alloc-stack-param ( rep -- n ) -M: object alloc-stack-param ( rep -- n ) +M: object alloc-stack-param stack-params get [ rep-size cell align stack-params +@ ] dip ; -M: float-rep alloc-stack-param ( rep -- n ) +M: float-rep alloc-stack-param stack-params get swap rep-size [ cell align stack-params +@ ] keep float-right-align-on-stack? [ + ] [ drop ] if ; diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 453e01e932..b8402f452f 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -71,7 +71,7 @@ GENERIC: emit-node ( block node -- block' ) ##branch, [ begin-basic-block ] dip [ label>> id>> loops get set-at ] [ child>> emit-nodes ] 2bi ; -M: #recursive emit-node ( block node -- block' ) +M: #recursive emit-node dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ; ! #if @@ -109,28 +109,28 @@ M: #recursive emit-node ( block node -- block' ) ! loc>vreg sync ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ; -M: #if emit-node ( block node -- block' ) +M: #if emit-node { { [ dup trivial-if? ] [ drop emit-trivial-if ] } { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } [ emit-actual-if ] } cond ; -M: #dispatch emit-node ( block node -- block' ) +M: #dispatch emit-node ! Inputs to the final instruction need to be copied because of ! loc>vreg sync. ^^offset>slot always returns a fresh vreg, ! though. ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ; -M: #call emit-node ( block node -- block' ) +M: #call emit-node dup word>> dup "intrinsic" word-prop [ nip call( block #call -- block' ) ] [ swap call-height emit-call ] if* ; -M: #call-recursive emit-node ( block node -- block' ) +M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ; -M: #push emit-node ( block node -- block ) +M: #push emit-node literal>> ^^load-literal ds-push ; ! #shuffle @@ -157,7 +157,7 @@ M: #push emit-node ( block node -- block ) [ make-input-map ] [ mapping>> ] [ extract-outputs ] tri [ [ of of peek-loc ] 2with map ] 2with map ; -M: #shuffle emit-node ( block node -- block ) +M: #shuffle emit-node [ out-vregs/stack ] keep store-height-changes first2 [ ds-loc store-vregs ] [ rs-loc store-vregs ] bi* ; @@ -167,14 +167,14 @@ M: #shuffle emit-node ( block node -- block ) t >>kill-block? ##safepoint, ##epilogue, ##return, ; -M: #return emit-node ( block node -- block' ) +M: #return emit-node drop end-word ; -M: #return-recursive emit-node ( block node -- block' ) +M: #return-recursive emit-node label>> id>> loops get key? [ ] [ end-word ] if ; ! #terminate -M: #terminate emit-node ( block node -- block' ) +M: #terminate emit-node drop ##no-tco, end-basic-block f ; ! No-op nodes diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index f78c336d6f..e6009e0b42 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -35,7 +35,7 @@ GENERIC: visit-insn ( live-set insn -- ) : gen-uses ( live-set insn -- ) uses-vregs [ swap conjoin ] with each ; inline -M: vreg-insn visit-insn ( live-set insn -- ) +M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] 2bi ; DEFER: lookup-base-pointer @@ -98,7 +98,7 @@ M: vreg-insn lookup-base-pointer* 2drop f ; : fill-gc-map ( live-set gc-map -- ) [ gc-roots ] dip [ gc-roots<< ] [ derived-roots<< ] bi ; -M: gc-map-insn visit-insn ( live-set insn -- ) +M: gc-map-insn visit-insn [ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] 2tri ; M: ##phi visit-insn kill-defs ; diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor index 7e59a4ef79..d859691bfd 100644 --- a/basis/concurrency/distributed/distributed.factor +++ b/basis/concurrency/distributed/distributed.factor @@ -68,11 +68,11 @@ C: connection : send-to-connection ( message connection -- ) stream>> [ serialize flush ] with-stream* ; -M: remote-thread send ( message thread -- ) +M: remote-thread send [ id>> 2array ] [ node>> ] [ thread-connections at ] tri [ nip send-to-connection ] [ send-remote-message ] if* ; -M: thread (serialize) ( obj -- ) +M: thread (serialize) id>> [ local-node get insecure>> ] dip (serialize) ; : stop-node ( -- ) diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 5f2a3fd5d8..8763c83ae1 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -13,7 +13,7 @@ M: thread mailbox-of [ { mailbox } declare ] [ [ >>mailbox drop ] keep ] ?if ; inline -M: thread send ( message thread -- ) +M: thread send mailbox-of mailbox-put ; : my-mailbox ( -- mailbox ) self mailbox-of ; inline diff --git a/basis/couchdb/couchdb.factor b/basis/couchdb/couchdb.factor index 15db1920e1..93f57a0724 100644 --- a/basis/couchdb/couchdb.factor +++ b/basis/couchdb/couchdb.factor @@ -18,7 +18,7 @@ SYMBOL: couch TUPLE: couchdb-error { data assoc } ; C: couchdb-error -M: couchdb-error error. ( error -- ) +M: couchdb-error error. "CouchDB Error: " write data>> "error" over at [ print ] when* "reason" of [ print ] when* ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 83de9fbf6b..901bc44797 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -524,7 +524,7 @@ HOOK: immediate-bitwise? cpu ( n -- ? ) HOOK: immediate-comparand? cpu ( n -- ? ) HOOK: immediate-store? cpu ( n -- ? ) -M: object immediate-comparand? ( n -- ? ) +M: object immediate-comparand? { { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] } { [ dup not ] [ drop t ] } diff --git a/basis/cpu/ppc/32/linux/linux.factor b/basis/cpu/ppc/32/linux/linux.factor index 187de4e784..18e7f5670a 100644 --- a/basis/cpu/ppc/32/linux/linux.factor +++ b/basis/cpu/ppc/32/linux/linux.factor @@ -5,13 +5,13 @@ compiler.cfg.builder.alien.boxing sequences arrays alien.c-types cpu.architecture cpu.ppc alien.complex ; IN: cpu.ppc.32.linux -M: linux lr-save ( -- n ) 1 cells ; +M: linux lr-save 1 cells ; -M: linux has-toc ( -- ? ) f ; +M: linux has-toc f ; -M: linux reserved-area-size ( -- n ) 2 cells ; +M: linux reserved-area-size 2 cells ; -M: linux allows-null-dereference ( -- ? ) f ; +M: linux allows-null-dereference f ; M: ppc param-regs drop { @@ -35,7 +35,7 @@ M: ppc long-long-odd-register? t ; M: ppc float-right-align-on-stack? f ; -M: ppc flatten-struct-type ( type -- seq ) +M: ppc flatten-struct-type { { [ dup lookup-c-type complex-double lookup-c-type = ] [ drop { { int-rep f f } { int-rep f f } diff --git a/basis/cpu/ppc/64/linux/linux.factor b/basis/cpu/ppc/64/linux/linux.factor index 6b4df01173..d2f29a7d3a 100644 --- a/basis/cpu/ppc/64/linux/linux.factor +++ b/basis/cpu/ppc/64/linux/linux.factor @@ -7,11 +7,11 @@ IN: cpu.ppc.64.linux M: linux lr-save 2 cells ; -M: linux has-toc ( -- ? ) t ; +M: linux has-toc t ; -M: linux reserved-area-size ( -- n ) 6 cells ; +M: linux reserved-area-size 6 cells ; -M: linux allows-null-dereference ( -- ? ) f ; +M: linux allows-null-dereference f ; M: ppc param-regs drop { @@ -33,7 +33,7 @@ M: ppc long-long-odd-register? f ; M: ppc float-right-align-on-stack? t ; -M: ppc flatten-struct-type ( type -- seq ) +M: ppc flatten-struct-type { { [ dup lookup-c-type complex-double lookup-c-type = ] [ drop { { double-rep f f } { double-rep f f } } ] } @@ -42,7 +42,7 @@ M: ppc flatten-struct-type ( type -- seq ) [ heap-size cell align cell /i { int-rep f f } ] } cond ; -M: ppc flatten-struct-type-return ( type -- seq ) +M: ppc flatten-struct-type-return { { [ dup lookup-c-type complex-double lookup-c-type = ] [ drop { { double-rep f f } { double-rep f f } } ] } diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor index 9d37f1cdd6..6f083373d5 100644 --- a/basis/cpu/ppc/assembler/assembler.factor +++ b/basis/cpu/ppc/assembler/assembler.factor @@ -115,16 +115,16 @@ IN: cpu.ppc.assembler ! 2.4 Branch Instructions GENERIC: B ( target_addr/label -- ) -M: integer B ( target_addr -- ) -2 shift 0 0 18 i-insn ; +M: integer B -2 shift 0 0 18 i-insn ; GENERIC: BL ( target_addr/label -- ) -M: integer BL ( target_addr -- ) -2 shift 0 1 18 i-insn ; +M: integer BL -2 shift 0 1 18 i-insn ; : BA ( target_addr -- ) -2 shift 1 0 18 i-insn ; : BLA ( target_addr -- ) -2 shift 1 1 18 i-insn ; GENERIC: BC ( bo bi target_addr/label -- ) -M: integer BC ( bo bi target_addr -- ) -2 shift 0 0 16 b-insn ; +M: integer BC -2 shift 0 0 16 b-insn ; : BCA ( bo bi target_addr -- ) -2 shift 1 0 16 b-insn ; : BCL ( bo bi target_addr -- ) -2 shift 0 1 16 b-insn ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index f4a75c75cc..7a78d3d981 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -34,9 +34,9 @@ HOOK: has-toc os ( -- ? ) HOOK: reserved-area-size os ( -- n ) HOOK: allows-null-dereference os ( -- ? ) -M: label B ( label -- ) [ 0 B ] dip rc-relative-ppc-3-pc label-fixup ; -M: label BL ( label -- ) [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ; -M: label BC ( bo bi label -- ) [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ; +M: label B [ 0 B ] dip rc-relative-ppc-3-pc label-fixup ; +M: label BL [ 0 BL ] dip rc-relative-ppc-3-pc label-fixup ; +M: label BC [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ; CONSTANT: scratch-reg 30 CONSTANT: fp-scratch-reg 30 @@ -44,16 +44,16 @@ CONSTANT: ds-reg 14 CONSTANT: rs-reg 15 CONSTANT: vm-reg 16 -M: ppc machine-registers ( -- assoc ) +M: ppc machine-registers { { int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] } { float-regs $[ 0 29 [a,b] ] } } ; -M: ppc frame-reg ( -- reg ) 31 ; -M: ppc.32 vm-stack-space ( -- n ) 16 ; -M: ppc.64 vm-stack-space ( -- n ) 32 ; -M: ppc complex-addressing? ( -- ? ) f ; +M: ppc frame-reg 31 ; +M: ppc.32 vm-stack-space 16 ; +M: ppc.64 vm-stack-space 32 ; +M: ppc complex-addressing? f ; ! PW1-PW8 parameter save slots : param-save-size ( -- n ) 8 cells ; foldable @@ -67,7 +67,7 @@ M: ppc complex-addressing? ( -- ? ) f ; : param@ ( n -- offset ) reserved-area-size + ; -M: ppc gc-root-offset ( spill-slot -- n ) +M: ppc gc-root-offset n>> spill@ cell /i ; : LOAD32 ( r n -- ) @@ -129,12 +129,12 @@ HOOK: %load-cell-imm-rc cpu ( -- rel-class ) M: ppc.32 %load-cell-imm-rc rc-absolute-ppc-2/2 ; M: ppc.64 %load-cell-imm-rc rc-absolute-ppc-2/2/2/2 ; -M: ppc.32 %load-immediate ( reg val -- ) +M: ppc.32 %load-immediate dup -0x8000 0x7fff between? [ LI ] [ LOAD32 ] if ; -M: ppc.64 %load-immediate ( reg val -- ) +M: ppc.64 %load-immediate dup -0x8000 0x7fff between? [ LI ] [ LOAD64 ] if ; -M: ppc %load-reference ( reg obj -- ) +M: ppc %load-reference [ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ] [ \ f type-number LI ] if* ; @@ -156,11 +156,11 @@ M: ds-loc loc-reg drop ds-reg ; M: rs-loc loc-reg drop rs-reg ; ! Load value at stack location loc into vreg. -M: ppc %peek ( vreg loc -- ) +M: ppc %peek [ loc-reg ] [ n>> cells neg ] bi %load-cell ; ! Replace value at stack location loc with value in vreg. -M: ppc %replace ( vreg loc -- ) +M: ppc %replace [ loc-reg ] [ n>> cells neg ] bi %store-cell ; ! Replace value at stack location with an immediate value. @@ -176,45 +176,45 @@ M:: ppc %replace-imm ( src loc -- ) } cond scratch-reg reg offset %store-cell ; -M: ppc %clear ( loc -- ) +M: ppc %clear 297 swap %replace-imm ; ! Increment stack pointer by n cells. -M: ppc %inc ( loc -- ) +M: ppc %inc [ ds-loc? [ ds-reg ds-reg ] [ rs-reg rs-reg ] if ] [ n>> ] bi cells ADDI ; -M: ppc stack-frame-size ( stack-frame -- i ) +M: ppc stack-frame-size (stack-frame-size) reserved-area-size + param-save-size + factor-area-size + 16 align ; -M: ppc %call ( word -- ) +M: ppc %call 0 BL rc-relative-ppc-3-pc rel-word-pic ; : instrs ( n -- b ) 4 * ; inline -M: ppc %jump ( word -- ) +M: ppc %jump 6 0 %load-cell-imm 1 instrs %load-cell-imm-rc rel-here 0 B rc-relative-ppc-3-pc rel-word-pic-tail ; -M: ppc %dispatch ( src temp -- ) +M: ppc %dispatch [ nip 0 %load-cell-imm 3 instrs %load-cell-imm-rc rel-here ] [ swap dupd %load-cell-x ] [ nip MTCTR ] 2tri BCTR ; -M: ppc %slot ( dst obj slot scale tag -- ) +M: ppc %slot [ 0 assert= ] bi@ %load-cell-x ; -M: ppc %slot-imm ( dst obj slot tag -- ) +M: ppc %slot-imm slot-offset scratch-reg swap LI scratch-reg %load-cell-x ; -M: ppc %set-slot ( src obj slot scale tag -- ) +M: ppc %set-slot [ 0 assert= ] bi@ %store-cell-x ; -M: ppc %set-slot-imm ( src obj slot tag -- ) +M: ppc %set-slot-imm slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ; M: ppc %jump-label B ; @@ -255,7 +255,7 @@ M: ppc.64 %log2 [ CNTLZD ] [ drop dup NEG ] [ drop dup 63 ADDI ] 2tri ; M: ppc.32 %bit-count POPCNTW ; M: ppc.64 %bit-count POPCNTD ; -M: ppc %copy ( dst src rep -- ) +M: ppc %copy 2over eq? [ 3drop ] [ { { tagged-rep [ MR ] } @@ -276,15 +276,15 @@ M: ppc %copy ( dst src rep -- ) { cc/o [ 0 label BNS ] } } case ; inline -M: ppc %fixnum-add ( label dst src1 src2 cc -- ) +M: ppc %fixnum-add [ ADDO. ] overflow-template ; -M: ppc %fixnum-sub ( label dst src1 src2 cc -- ) +M: ppc %fixnum-sub [ SUBFO. ] overflow-template ; -M: ppc.32 %fixnum-mul ( label dst src1 src2 cc -- ) +M: ppc.32 %fixnum-mul [ MULLWO. ] overflow-template ; -M: ppc.64 %fixnum-mul ( label dst src1 src2 cc -- ) +M: ppc.64 %fixnum-mul [ MULLDO. ] overflow-template ; M: ppc %add-float FADD ; @@ -292,11 +292,11 @@ M: ppc %sub-float FSUB ; M: ppc %mul-float FMUL ; M: ppc %div-float FDIV ; -M: ppc %min-float ( dst src1 src2 -- ) +M: ppc %min-float 2dup [ scratch-reg ] 2dip FSUB [ scratch-reg ] 2dip FSEL ; -M: ppc %max-float ( dst src1 src2 -- ) +M: ppc %max-float 2dup [ scratch-reg ] 2dip FSUB [ scratch-reg ] 2dip FSEL ; @@ -343,26 +343,26 @@ M:: ppc.64 %float>integer ( dst src -- ) } ; ! Return values of this class go here -M: ppc return-regs ( -- regs ) +M: ppc return-regs { { int-regs { 3 4 5 6 } } { float-regs { 1 2 3 4 } } } ; ! Is this structure small enough to be returned in registers? -M: ppc return-struct-in-registers? ( c-type -- ? ) +M: ppc return-struct-in-registers? lookup-c-type return-in-registers?>> ; ! If t, the struct return pointer is never passed in a param reg -M: ppc struct-return-on-stack? ( -- ? ) f ; +M: ppc struct-return-on-stack? f ; GENERIC: load-param ( reg src -- ) -M: integer load-param ( reg src -- ) int-rep %copy ; -M: spill-slot load-param ( reg src -- ) [ 1 ] dip n>> spill@ %load-cell ; +M: integer load-param int-rep %copy ; +M: spill-slot load-param [ 1 ] dip n>> spill@ %load-cell ; GENERIC: store-param ( reg dst -- ) -M: integer store-param ( reg dst -- ) swap int-rep %copy ; -M: spill-slot store-param ( reg dst -- ) [ 1 ] dip n>> spill@ %store-cell ; +M: integer store-param swap int-rep %copy ; +M: spill-slot store-param [ 1 ] dip n>> spill@ %store-cell ; M:: ppc %unbox ( dst src func rep -- ) 3 src load-param @@ -459,10 +459,7 @@ M:: ppc %c-invoke ( name dll gc-map -- ) dead-outputs [ first2 discard-reg-param ] each ; inline -M: ppc %alien-invoke ( varargs? reg-inputs stack-inputs - reg-outputs dead-outputs - cleanup stack-size - symbols dll gc-map -- ) +M: ppc %alien-invoke '[ _ _ _ %c-invoke ] emit-alien-insn ; M:: ppc %alien-indirect ( src @@ -483,36 +480,33 @@ M:: ppc %alien-indirect ( src gc-map gc-map-here ] emit-alien-insn ; -M: ppc %alien-assembly ( varargs? reg-inputs stack-inputs - reg-outputs dead-outputs - cleanup stack-size - quot -- ) +M: ppc %alien-assembly '[ _ call( -- ) ] emit-alien-insn ; -M: ppc %callback-inputs ( reg-outputs stack-outputs -- ) +M: ppc %callback-inputs [ [ first3 load-reg-param ] each ] [ [ first3 load-stack-param ] each ] bi* 3 vm-reg MR 4 0 LI "begin_callback" f f %c-invoke ; -M: ppc %callback-outputs ( reg-inputs -- ) +M: ppc %callback-outputs 3 vm-reg MR "end_callback" f f %c-invoke [ first3 store-reg-param ] each ; -M: ppc stack-cleanup ( stack-size return abi -- n ) +M: ppc stack-cleanup 3drop 0 ; M: ppc fused-unboxing? f ; -M: ppc %alien-global ( register symbol dll -- ) +M: ppc %alien-global [ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ; -M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip %load-cell ; -M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip %store-cell ; +M: ppc %vm-field [ vm-reg ] dip %load-cell ; +M: ppc %set-vm-field [ vm-reg ] dip %store-cell ; -M: ppc %unbox-alien ( dst src -- ) +M: ppc %unbox-alien scratch-reg alien-offset LI scratch-reg %load-cell-x ; ! Convert a c-ptr object to a raw C pointer. @@ -706,7 +700,7 @@ M:: ppc.64 %convert-integer ( dst src c-type -- ) { c:ulonglong [ ] } } case ; -M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- ) +M: ppc.32 %load-memory-imm [ pick %trap-null { @@ -725,7 +719,7 @@ M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- ) } case ] ?if ; -M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- ) +M: ppc.64 %load-memory-imm [ pick %trap-null { @@ -747,7 +741,7 @@ M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- ) ] ?if ; -M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- ) +M: ppc.32 %load-memory [ [ 0 assert= ] bi@ ] 2dip [ pick %trap-null @@ -767,7 +761,7 @@ M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- ) } case ] ?if ; -M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- ) +M: ppc.64 %load-memory [ [ 0 assert= ] bi@ ] 2dip [ pick %trap-null @@ -790,7 +784,7 @@ M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- ) ] ?if ; -M: ppc.32 %store-memory-imm ( src base offset rep c-type -- ) +M: ppc.32 %store-memory-imm [ { { c:char [ STB ] } @@ -808,7 +802,7 @@ M: ppc.32 %store-memory-imm ( src base offset rep c-type -- ) } case ] ?if ; -M: ppc.64 %store-memory-imm ( src base offset rep c-type -- ) +M: ppc.64 %store-memory-imm [ { { c:char [ STB ] } @@ -828,7 +822,7 @@ M: ppc.64 %store-memory-imm ( src base offset rep c-type -- ) } case ] ?if ; -M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- ) +M: ppc.32 %store-memory [ [ 0 assert= ] bi@ ] 2dip [ { @@ -847,7 +841,7 @@ M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- ) } case ] ?if ; -M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- ) +M: ppc.64 %store-memory [ [ 0 assert= ] bi@ ] 2dip [ { @@ -914,7 +908,7 @@ M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- ) { cc/<= [ 0 label BGT ] } } case ; -M: ppc %call-gc ( gc-map -- ) +M: ppc %call-gc \ minor-gc %call gc-map-here ; M:: ppc %prologue ( stack-size -- ) @@ -1033,7 +1027,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 ) label branch1 branch2 (%branch) ; -M: ppc %spill ( src rep dst -- ) +M: ppc %spill n>> spill@ swap { { int-rep [ [ 1 ] dip %store-cell ] } { tagged-rep [ [ 1 ] dip %store-cell ] } @@ -1043,7 +1037,7 @@ M: ppc %spill ( src rep dst -- ) { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] } } case ; -M: ppc %reload ( dst rep src -- ) +M: ppc %reload n>> spill@ swap { { int-rep [ [ 1 ] dip %load-cell ] } { tagged-rep [ [ 1 ] dip %load-cell ] } @@ -1053,11 +1047,11 @@ M: ppc %reload ( dst rep src -- ) { scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] } } case ; -M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ; -M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ; -M: ppc immediate-store? ( n -- ? ) immediate-comparand? ; +M: ppc immediate-arithmetic? -32768 32767 between? ; +M: ppc immediate-bitwise? 0 65535 between? ; +M: ppc immediate-store? immediate-comparand? ; -M: ppc enable-cpu-features ( -- ) +M: ppc enable-cpu-features enable-float-intrinsics ; USE: vocabs diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 7dbf72cb74..8e7e7953be 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -26,18 +26,18 @@ M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; M: x86.32 frame-reg EBP ; -M: x86.32 immediate-comparand? ( obj -- ? ) drop t ; +M: x86.32 immediate-comparand? drop t ; M:: x86.32 %load-vector ( dst val rep -- ) dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ; -M: x86.32 %vm-field ( dst field -- ) +M: x86.32 %vm-field [ 0 [] MOV ] dip rc-absolute-cell rel-vm ; -M: x86.32 %set-vm-field ( dst field -- ) +M: x86.32 %set-vm-field [ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ; -M: x86.32 %vm-field-ptr ( dst field -- ) +M: x86.32 %vm-field-ptr [ 0 MOV ] dip rc-absolute-cell rel-vm ; M: x86.32 %mark-card @@ -61,7 +61,7 @@ M: x86.32 vm-stack-space 16 ; : save-vm-ptr ( n -- ) stack@ 0 MOV 0 rc-absolute-cell rel-vm ; -M: x86.32 return-struct-in-registers? ( c-type -- ? ) +M: x86.32 return-struct-in-registers? lookup-c-type [ return-in-registers?>> ] [ heap-size { 1 2 4 8 } member? ] bi @@ -87,7 +87,7 @@ M: x86.32 return-regs M: x86.32 %prepare-jump pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ; -M: x86.32 %load-stack-param ( dst rep n -- ) +M: x86.32 %load-stack-param next-stack@ swap pick register? [ %copy ] [ { { int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] } @@ -96,7 +96,7 @@ M: x86.32 %load-stack-param ( dst rep n -- ) } case ] if ; -M: x86.32 %store-stack-param ( src rep n -- ) +M: x86.32 %store-stack-param stack@ swap pick register? [ swapd %copy ] [ { { int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] } @@ -115,7 +115,7 @@ M: x86.32 %store-stack-param ( src rep n -- ) dst ?spill-slot x87-insn execute ] if ; inline -M: x86.32 %load-reg-param ( vreg rep reg -- ) +M: x86.32 %load-reg-param swap { { int-rep [ int-rep %copy ] } { float-rep [ drop \ FSTPS float-rep load-float-return ] } @@ -132,14 +132,14 @@ M: x86.32 %load-reg-param ( vreg rep reg -- ) src ?spill-slot x87-insn execute ] if ; inline -M: x86.32 %store-reg-param ( vreg rep reg -- ) +M: x86.32 %store-reg-param swap { { int-rep [ swap int-rep %copy ] } { float-rep [ drop \ FLDS float-rep store-float-return ] } { double-rep [ drop \ FLDL double-rep store-float-return ] } } case ; -M: x86.32 %discard-reg-param ( rep reg -- ) +M: x86.32 %discard-reg-param drop { { int-rep [ ] } { float-rep [ ST0 FSTP ] } @@ -179,12 +179,12 @@ M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- ) M: x86.32 %c-invoke [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ; -M: x86.32 %begin-callback ( -- ) +M: x86.32 %begin-callback 0 save-vm-ptr 4 stack@ 0 MOV "begin_callback" f f %c-invoke ; -M: x86.32 %end-callback ( -- ) +M: x86.32 %end-callback 0 save-vm-ptr "end_callback" f f %c-invoke ; @@ -192,7 +192,7 @@ M: x86.32 %end-callback ( -- ) ! MINGW ABI incompatibility disaster [ large-struct? ] [ mingw eq? os windows? not or ] bi* and ; -M: x86.32 %prepare-var-args ( reg-inputs -- ) drop ; +M: x86.32 %prepare-var-args drop ; M:: x86.32 stack-cleanup ( stack-size return abi -- n ) ! a) Functions which are stdcall/fastcall/thiscall have to @@ -205,7 +205,7 @@ M:: x86.32 stack-cleanup ( stack-size return abi -- n ) [ 0 ] } cond ; -M: x86.32 %cleanup ( n -- ) +M: x86.32 %cleanup [ ESP swap SUB ] unless-zero ; M: x86.32 %safepoint @@ -224,7 +224,7 @@ M: x86.32 flatten-struct-type M: x86.32 struct-return-on-stack? os linux? not ; -M: x86.32 (cpuid) ( eax ecx regs -- ) +M: x86.32 (cpuid) void { uint uint void* } cdecl [ ! Save ds-reg, rs-reg EDI PUSH diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index f098b6339c..1e19b39fd7 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -40,16 +40,16 @@ M: x86.64 machine-registers : vm-reg ( -- reg ) R13 ; inline : nv-reg ( -- reg ) RBX ; inline -M: x86.64 %vm-field ( dst offset -- ) +M: x86.64 %vm-field [ vm-reg ] dip [+] MOV ; M:: x86.64 %load-vector ( dst val rep -- ) dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ; -M: x86.64 %set-vm-field ( src offset -- ) +M: x86.64 %set-vm-field [ vm-reg ] dip [+] swap MOV ; -M: x86.64 %vm-field-ptr ( dst offset -- ) +M: x86.64 %vm-field-ptr [ vm-reg ] dip [+] LEA ; M: x86.64 %prepare-jump @@ -83,7 +83,7 @@ M:: x86.64 %load-reg-param ( vreg rep reg -- ) M:: x86.64 %store-reg-param ( vreg rep reg -- ) reg vreg rep %copy ; -M: x86.64 %discard-reg-param ( rep reg -- ) +M: x86.64 %discard-reg-param 2drop ; M:: x86.64 %unbox ( dst src func rep -- ) @@ -102,12 +102,12 @@ M: x86.64 %c-invoke [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip gc-map-here ; -M: x86.64 %begin-callback ( -- ) +M: x86.64 %begin-callback param-reg-0 vm-reg MOV param-reg-1 0 MOV "begin_callback" f f %c-invoke ; -M: x86.64 %end-callback ( -- ) +M: x86.64 %end-callback param-reg-0 vm-reg MOV "end_callback" f f %c-invoke ; @@ -122,7 +122,7 @@ M: x86.64 long-long-on-stack? f ; M: x86.64 struct-return-on-stack? f ; -M: x86.64 (cpuid) ( rax rcx regs -- ) +M: x86.64 (cpuid) void { uint uint void* } cdecl [ RAX param-reg-0 MOV RCX param-reg-1 MOV diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index f5df862848..336bca03cc 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -38,14 +38,14 @@ M: x86.64 reserved-stack-space 0 ; ] [ reps ] if ] [ reps ] if ; -M: x86.64 flatten-struct-type ( c-type -- seq ) +M: x86.64 flatten-struct-type dup heap-size 16 <= [ flatten-small-struct record-reg-reps ] [ call-next-method unrecord-reg-reps [ first t f 3array ] map ] if ; -M: x86.64 return-struct-in-registers? ( c-type -- ? ) +M: x86.64 return-struct-in-registers? heap-size 2 cells <= ; M: x86.64 dummy-stack-params? f ; @@ -54,6 +54,6 @@ M: x86.64 dummy-int-params? f ; M: x86.64 dummy-fp-params? f ; -M: x86.64 %prepare-var-args ( reg-inputs -- ) +M: x86.64 %prepare-var-args [ second reg-class-of float-regs? ] count 8 min [ EAX EAX XOR ] [ AL swap MOV ] if-zero ; diff --git a/basis/cpu/x86/64/windows/windows.factor b/basis/cpu/x86/64/windows/windows.factor index 14ca118f7c..a6738b2d12 100644 --- a/basis/cpu/x86/64/windows/windows.factor +++ b/basis/cpu/x86/64/windows/windows.factor @@ -13,7 +13,7 @@ M: x86.64 param-regs M: x86.64 reserved-stack-space 4 cells ; -M: x86.64 return-struct-in-registers? ( c-type -- ? ) +M: x86.64 return-struct-in-registers? heap-size { 1 2 4 8 } member? ; M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ; @@ -24,5 +24,4 @@ M: x86.64 dummy-int-params? t ; M: x86.64 dummy-fp-params? t ; -M: x86.64 %prepare-var-args ( reg-inputs -- ) - drop ; +M: x86.64 %prepare-var-args drop ; diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 1670db2f59..46baef6121 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -338,7 +338,7 @@ M: immediate SBB { 0b011 t 0x80 } immediate-1/4 ; M: operand SBB 0o030 2-operand ; GENERIC: AND ( dst src -- ) -M: immediate AND ( dst src -- ) +M: immediate AND maybe-zero-extend { 0b100 t 0x80 } immediate-1/4 ; M: operand AND 0o040 2-operand ; @@ -357,13 +357,11 @@ M: immediate XOR { 0b110 t 0x80 } immediate-1/4 ; M: operand XOR 0o060 2-operand ; GENERIC: CMP ( dst src -- ) -M: immediate CMP ( dst src -- ) - { 0b111 t 0x80 } immediate-1/4 ; +M: immediate CMP { 0b111 t 0x80 } immediate-1/4 ; M: operand CMP 0o070 2-operand ; GENERIC: TEST ( dst src -- ) -M: immediate TEST ( dst src -- ) - maybe-zero-extend { 0b0 t 0xf7 } immediate-4 ; +M: immediate TEST maybe-zero-extend { 0b0 t 0xf7 } immediate-4 ; M: operand TEST 0o204 2-operand ; : XCHG ( dst src -- ) 0o207 2-operand ; @@ -371,20 +369,20 @@ M: operand TEST 0o204 2-operand ; : BSR ( dst src -- ) { 0x0f 0xbd } (2-operand) ; GENERIC: BT ( value n -- ) -M: immediate BT ( value n -- ) { 0b100 t { 0x0f 0xba } } immediate-1* ; -M: operand BT ( value n -- ) swap { 0x0f 0xa3 } (2-operand) ; +M: immediate BT { 0b100 t { 0x0f 0xba } } immediate-1* ; +M: operand BT swap { 0x0f 0xa3 } (2-operand) ; GENERIC: BTC ( value n -- ) -M: immediate BTC ( value n -- ) { 0b111 t { 0x0f 0xba } } immediate-1* ; -M: operand BTC ( value n -- ) swap { 0x0f 0xbb } (2-operand) ; +M: immediate BTC { 0b111 t { 0x0f 0xba } } immediate-1* ; +M: operand BTC swap { 0x0f 0xbb } (2-operand) ; GENERIC: BTR ( value n -- ) -M: immediate BTR ( value n -- ) { 0b110 t { 0x0f 0xba } } immediate-1* ; -M: operand BTR ( value n -- ) swap { 0x0f 0xb3 } (2-operand) ; +M: immediate BTR { 0b110 t { 0x0f 0xba } } immediate-1* ; +M: operand BTR swap { 0x0f 0xb3 } (2-operand) ; GENERIC: BTS ( value n -- ) -M: immediate BTS ( value n -- ) { 0b101 t { 0x0f 0xba } } immediate-1* ; -M: operand BTS ( value n -- ) swap { 0x0f 0xab } (2-operand) ; +M: immediate BTS { 0b101 t { 0x0f 0xba } } immediate-1* ; +M: operand BTS swap { 0x0f 0xab } (2-operand) ; : NOT ( dst -- ) { 0b010 t 0xf7 } 1-operand ; : NEG ( dst -- ) { 0b011 t 0xf7 } 1-operand ; diff --git a/basis/cpu/x86/sse/sse.factor b/basis/cpu/x86/sse/sse.factor index dfdd19efc3..c7c6187904 100644 --- a/basis/cpu/x86/sse/sse.factor +++ b/basis/cpu/x86/sse/sse.factor @@ -35,16 +35,16 @@ M: x86 integer-float-needs-stack-frame? f ; M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ; M: x86 %float>integer CVTTSD2SI ; -M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- ) +M: x86 %compare-float-ordered [ COMISD ] (%compare-float) ; -M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- ) +M: x86 %compare-float-unordered [ UCOMISD ] (%compare-float) ; -M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- ) +M: x86 %compare-float-ordered-branch [ COMISD ] (%compare-float-branch) ; -M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- ) +M: x86 %compare-float-unordered-branch [ UCOMISD ] (%compare-float-branch) ; ! SIMD @@ -262,7 +262,7 @@ M: x86 %shuffle-vector-halves-imm-reps { sse2? { double-2-rep } } } available-reps ; -M: x86 %shuffle-vector ( dst src shuffle rep -- ) +M: x86 %shuffle-vector two-operand PSHUFB ; M: x86 %shuffle-vector-reps @@ -331,14 +331,14 @@ M: x86 %unsigned-pack-vector-reps { sse4.1? { int-4-rep } } } available-reps ; -M: x86 %tail>head-vector ( dst src rep -- ) +M: x86 %tail>head-vector dup { { float-4-rep [ drop UNPCKHPD ] } { double-2-rep [ drop UNPCKHPD ] } [ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ] } case ; -M: x86 %unpack-vector-head ( dst src rep -- ) +M: x86 %unpack-vector-head { { char-16-rep [ PMOVSXBW ] } { uchar-16-rep [ PMOVZXBW ] } @@ -349,13 +349,13 @@ M: x86 %unpack-vector-head ( dst src rep -- ) { float-4-rep [ CVTPS2PD ] } } case ; -M: x86 %unpack-vector-head-reps ( -- reps ) +M: x86 %unpack-vector-head-reps { { sse2? { float-4-rep } } { sse4.1? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } } } available-reps ; -M: x86 %integer>float-vector ( dst src rep -- ) +M: x86 %integer>float-vector { { int-4-rep [ CVTDQ2PS ] } } case ; @@ -365,7 +365,7 @@ M: x86 %integer>float-vector-reps { sse2? { int-4-rep } } } available-reps ; -M: x86 %float>integer-vector ( dst src rep -- ) +M: x86 %float>integer-vector { { float-4-rep [ CVTTPS2DQ ] } } case ; @@ -405,7 +405,7 @@ M: x86 %float>integer-vector-reps { cc> [ [ PCMPGTQ ] [ PCMPGTD ] [ PCMPGTW ] [ PCMPGTB ] (%compare-int-vector) ] } } case ; -M: x86 %compare-vector ( dst src1 src2 rep cc -- ) +M: x86 %compare-vector [ [ two-operand ] keep ] dip over float-vector-rep? [ %compare-float-vector ] @@ -481,7 +481,7 @@ M: x86 %compare-vector-ccs [ drop PMOVMSKB 0xffff ] } case ; -M: x86 %move-vector-mask ( dst src rep -- ) +M: x86 %move-vector-mask (%move-vector-mask) drop ; M: x86 %move-vector-mask-reps @@ -512,7 +512,7 @@ M: x86 %test-vector-reps { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -M: x86 %add-vector ( dst src1 src2 rep -- ) +M: x86 %add-vector [ two-operand ] keep { { float-4-rep [ ADDPS ] } @@ -533,7 +533,7 @@ M: x86 %add-vector-reps { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -M: x86 %saturated-add-vector ( dst src1 src2 rep -- ) +M: x86 %saturated-add-vector [ two-operand ] keep { { char-16-rep [ PADDSB ] } @@ -547,7 +547,7 @@ M: x86 %saturated-add-vector-reps { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } } } available-reps ; -M: x86 %add-sub-vector ( dst src1 src2 rep -- ) +M: x86 %add-sub-vector [ two-operand ] keep { { float-4-rep [ ADDSUBPS ] } @@ -559,7 +559,7 @@ M: x86 %add-sub-vector-reps { sse3? { float-4-rep double-2-rep } } } available-reps ; -M: x86 %sub-vector ( dst src1 src2 rep -- ) +M: x86 %sub-vector [ two-operand ] keep { { float-4-rep [ SUBPS ] } @@ -580,7 +580,7 @@ M: x86 %sub-vector-reps { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -M: x86 %saturated-sub-vector ( dst src1 src2 rep -- ) +M: x86 %saturated-sub-vector [ two-operand ] keep { { char-16-rep [ PSUBSB ] } @@ -594,7 +594,7 @@ M: x86 %saturated-sub-vector-reps { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } } } available-reps ; -M: x86 %mul-vector ( dst src1 src2 rep -- ) +M: x86 %mul-vector [ two-operand ] keep { { float-4-rep [ MULPS ] } @@ -612,7 +612,7 @@ M: x86 %mul-vector-reps { sse4.1? { int-4-rep uint-4-rep } } } available-reps ; -M: x86 %mul-high-vector ( dst src1 src2 rep -- ) +M: x86 %mul-high-vector [ two-operand ] keep { { short-8-rep [ PMULHW ] } @@ -624,7 +624,7 @@ M: x86 %mul-high-vector-reps { sse2? { short-8-rep ushort-8-rep } } } available-reps ; -M: x86 %mul-horizontal-add-vector ( dst src1 src2 rep -- ) +M: x86 %mul-horizontal-add-vector [ two-operand ] keep { { char-16-rep [ PMADDUBSW ] } @@ -638,7 +638,7 @@ M: x86 %mul-horizontal-add-vector-reps { ssse3? { char-16-rep uchar-16-rep } } } available-reps ; -M: x86 %div-vector ( dst src1 src2 rep -- ) +M: x86 %div-vector [ two-operand ] keep { { float-4-rep [ DIVPS ] } @@ -651,7 +651,7 @@ M: x86 %div-vector-reps { sse2? { double-2-rep } } } available-reps ; -M: x86 %min-vector ( dst src1 src2 rep -- ) +M: x86 %min-vector [ two-operand ] keep { { char-16-rep [ PMINSB ] } @@ -671,7 +671,7 @@ M: x86 %min-vector-reps { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } } available-reps ; -M: x86 %max-vector ( dst src1 src2 rep -- ) +M: x86 %max-vector [ two-operand ] keep { { char-16-rep [ PMAXSB ] } @@ -691,7 +691,7 @@ M: x86 %max-vector-reps { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } } } available-reps ; -M: x86 %avg-vector ( dst src1 src2 rep -- ) +M: x86 %avg-vector [ two-operand ] keep { { uchar-16-rep [ PAVGB ] } @@ -726,7 +726,7 @@ M: x86 %sad-vector-reps { sse2? { uchar-16-rep } } } available-reps ; -M: x86 %horizontal-add-vector ( dst src1 src2 rep -- ) +M: x86 %horizontal-add-vector [ two-operand ] keep signed-rep { { float-4-rep [ HADDPS ] } @@ -741,7 +741,7 @@ M: x86 %horizontal-add-vector-reps { ssse3? { int-4-rep uint-4-rep short-8-rep ushort-8-rep } } } available-reps ; -M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- ) +M: x86 %horizontal-shl-vector-imm two-operand PSLLDQ ; M: x86 %horizontal-shl-vector-imm-reps @@ -749,7 +749,7 @@ M: x86 %horizontal-shl-vector-imm-reps { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } } } available-reps ; -M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- ) +M: x86 %horizontal-shr-vector-imm two-operand PSRLDQ ; M: x86 %horizontal-shr-vector-imm-reps @@ -757,7 +757,7 @@ M: x86 %horizontal-shr-vector-imm-reps { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } } } available-reps ; -M: x86 %abs-vector ( dst src rep -- ) +M: x86 %abs-vector { { char-16-rep [ PABSB ] } { short-8-rep [ PABSW ] } @@ -769,7 +769,7 @@ M: x86 %abs-vector-reps { ssse3? { char-16-rep short-8-rep int-4-rep } } } available-reps ; -M: x86 %sqrt-vector ( dst src rep -- ) +M: x86 %sqrt-vector { { float-4-rep [ SQRTPS ] } { double-2-rep [ SQRTPD ] } @@ -781,7 +781,7 @@ M: x86 %sqrt-vector-reps { sse2? { double-2-rep } } } available-reps ; -M: x86 %and-vector ( dst src1 src2 rep -- ) +M: x86 %and-vector [ two-operand ] keep { { float-4-rep [ ANDPS ] } @@ -795,7 +795,7 @@ M: x86 %and-vector-reps { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -M: x86 %andn-vector ( dst src1 src2 rep -- ) +M: x86 %andn-vector [ two-operand ] keep { { float-4-rep [ ANDNPS ] } @@ -809,7 +809,7 @@ M: x86 %andn-vector-reps { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -M: x86 %or-vector ( dst src1 src2 rep -- ) +M: x86 %or-vector [ two-operand ] keep { { float-4-rep [ ORPS ] } @@ -823,7 +823,7 @@ M: x86 %or-vector-reps { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -M: x86 %xor-vector ( dst src1 src2 rep -- ) +M: x86 %xor-vector [ two-operand ] keep { { float-4-rep [ XORPS ] } @@ -837,7 +837,7 @@ M: x86 %xor-vector-reps { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -M: x86 %shl-vector ( dst src1 src2 rep -- ) +M: x86 %shl-vector [ two-operand ] keep { { short-8-rep [ PSLLW ] } @@ -853,7 +853,7 @@ M: x86 %shl-vector-reps { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } } } available-reps ; -M: x86 %shr-vector ( dst src1 src2 rep -- ) +M: x86 %shr-vector [ two-operand ] keep { { short-8-rep [ PSRAW ] } @@ -911,9 +911,9 @@ M: x86 %integer>scalar drop MOVD ; ] } } case ; -M: x86.32 %scalar>integer ( dst src rep -- ) %scalar>integer-32 ; +M: x86.32 %scalar>integer %scalar>integer-32 ; -M: x86.64 %scalar>integer ( dst src rep -- ) +M: x86.64 %scalar>integer { { longlong-scalar-rep [ MOVD ] } { ulonglong-scalar-rep [ MOVD ] } diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index e823ad72b5..964af77580 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -46,7 +46,7 @@ HOOK: pic-tail-reg cpu ( -- reg ) : align-stack ( n -- n' ) 16 align ; -M: x86 stack-frame-size ( stack-frame -- i ) +M: x86 stack-frame-size (stack-frame-size) reserved-stack-space + cell + @@ -60,7 +60,7 @@ M: x86 test-instruction? t ; M: x86 immediate-store? immediate-comparand? ; -M: x86 %load-immediate ( reg val -- ) +M: x86 %load-immediate { fixnum } declare [ 32-bit-version-of dup XOR ] [ MOV ] if-zero ; M: x86 %load-reference @@ -90,13 +90,13 @@ M: x86 %replace-imm [ [ 0 MOV ] dip rc-absolute rel-literal ] } cond ; -M: x86 %clear ( loc -- ) +M: x86 %clear 297 swap %replace-imm ; -M: x86 %inc ( loc -- ) +M: x86 %inc [ n>> ] [ ds-loc? ds-reg rs-reg ? ] bi (%inc) ; -M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; +M: x86 %call 0 CALL rc-relative rel-word-pic ; : xt-tail-pic-offset ( -- n ) ! See the comment in vm/cpu-x86.hpp @@ -104,21 +104,21 @@ M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; HOOK: %prepare-jump cpu ( -- ) -M: x86 %jump ( word -- ) +M: x86 %jump %prepare-jump 0 JMP rc-relative rel-word-pic-tail ; -M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; +M: x86 %jump-label 0 JMP rc-relative label-fixup ; -M: x86 %return ( -- ) 0 RET ; +M: x86 %return 0 RET ; : (%slot) ( obj slot scale tag -- op ) neg ; inline : (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline -M: x86 %slot ( dst obj slot scale tag -- ) (%slot) MOV ; -M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ; -M: x86 %set-slot ( src obj slot scale tag -- ) (%slot) swap MOV ; -M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ; +M: x86 %slot (%slot) MOV ; +M: x86 %slot-imm (%slot-imm) MOV ; +M: x86 %set-slot (%slot) swap MOV ; +M: x86 %set-slot-imm (%slot-imm) swap MOV ; :: two-operand ( dst src1 src2 rep -- dst src ) dst src2 eq? dst src1 eq? not and [ "Cannot handle this case" throw ] when @@ -130,13 +130,13 @@ M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ; dst ; inline M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ; -M: x86 %add-imm ( dst src1 src2 -- ) +M: x86 %add-imm 2over eq? [ nip { { 1 [ INC ] } { -1 [ DEC ] } [ ADD ] } case ] [ [+] LEA ] if ; M: x86 %sub int-rep two-operand SUB ; -M: x86 %sub-imm ( dst src1 src2 -- ) +M: x86 %sub-imm 2over eq? [ nip { { 1 [ DEC ] } { -1 [ INC ] } [ SUB ] } case ] [ neg [+] LEA ] if ; @@ -173,7 +173,7 @@ M: object copy-memory* copy-register* ; : ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ; -M: x86 %copy ( dst src rep -- ) +M: x86 %copy 2over eq? [ 3drop ] [ [ [ ?spill-slot ] bi@ ] dip 2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if @@ -186,16 +186,16 @@ M: x86 %copy ( dst src rep -- ) { cc/o [ JNO ] } } case ; inline -M: x86 %fixnum-add ( label dst src1 src2 cc -- ) +M: x86 %fixnum-add [ ADD ] fixnum-overflow ; -M: x86 %fixnum-sub ( label dst src1 src2 cc -- ) +M: x86 %fixnum-sub [ SUB ] fixnum-overflow ; -M: x86 %fixnum-mul ( label dst src1 src2 cc -- ) +M: x86 %fixnum-mul [ IMUL2 ] fixnum-overflow ; -M: x86 %unbox-alien ( dst src -- ) +M: x86 %unbox-alien alien-offset [+] MOV ; M:: x86 %unbox-any-c-ptr ( dst src -- ) @@ -364,7 +364,7 @@ M: x86.64 has-small-reg? 2drop t ; : %sign-extend ( dst src bits -- ) [ MOVSX ] (%convert-integer) ; inline -M: x86 %convert-integer ( dst src c-type -- ) +M: x86 %convert-integer { { c:char [ 8 %sign-extend ] } { c:uchar [ 8 %zero-extend ] } @@ -411,10 +411,10 @@ M: x86 %convert-integer ( dst src c-type -- ) } case ] [ nipd %copy ] ?if ; -M: x86 %load-memory ( dst base displacement scale offset rep c-type -- ) +M: x86 %load-memory (%memory) (%load-memory) ; -M: x86 %load-memory-imm ( dst base offset rep c-type -- ) +M: x86 %load-memory-imm (%memory-imm) (%load-memory) ; : (%store-memory) ( src exclude address rep c-type -- ) @@ -429,10 +429,10 @@ M: x86 %load-memory-imm ( dst base offset rep c-type -- ) } case ] [ [ nip swap ] dip %copy ] ?if ; -M: x86 %store-memory ( src base displacement scale offset rep c-type -- ) +M: x86 %store-memory (%memory) (%store-memory) ; -M: x86 %store-memory-imm ( src base offset rep c-type -- ) +M: x86 %store-memory-imm (%memory-imm) (%store-memory) ; : shift-count? ( reg -- ? ) { ECX RCX } member-eq? ; @@ -510,16 +510,16 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- ) M: x86 gc-root-offset n>> spill-offset special-offset cell + cell /i ; -M: x86 %call-gc ( gc-map -- ) +M: x86 %call-gc \ minor-gc %call gc-map-here ; -M: x86 %alien-global ( dst symbol library -- ) +M: x86 %alien-global [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; -M: x86 %prologue ( n -- ) cell - decr-stack-reg ; +M: x86 %prologue cell - decr-stack-reg ; -M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; +M: x86 %epilogue cell - incr-stack-reg ; :: (%boolean) ( dst temp insn -- ) dst \ f type-number MOV @@ -610,10 +610,10 @@ M:: x86 %dispatch ( src temp -- ) [ (align-code) ] bi ; -M: x86 %spill ( src rep dst -- ) +M: x86 %spill -rot %copy ; -M: x86 %reload ( dst rep src -- ) +M: x86 %reload swap %copy ; M:: x86 %local-allot ( dst size align offset -- ) @@ -661,10 +661,7 @@ M:: x86 %alien-assembly ( varargs? reg-inputs stack-inputs reg-outputs [ first3 %load-reg-param ] each dead-outputs [ first2 %discard-reg-param ] each ; -M: x86 %alien-invoke ( varargs? reg-inputs stack-inputs - reg-outputs dead-outputs - cleanup stack-size - symbols dll gc-map -- ) +M: x86 %alien-invoke '[ _ _ _ %c-invoke ] %alien-assembly ; M:: x86 %alien-indirect ( src @@ -681,14 +678,14 @@ M:: x86 %alien-indirect ( src HOOK: %begin-callback cpu ( -- ) -M: x86 %callback-inputs ( reg-outputs stack-outputs -- ) +M: x86 %callback-inputs [ [ first3 %load-reg-param ] each ] [ [ first3 %load-stack-param ] each ] bi* %begin-callback ; HOOK: %end-callback cpu ( -- ) -M: x86 %callback-outputs ( reg-inputs -- ) +M: x86 %callback-outputs %end-callback [ first3 %store-reg-param ] each ; @@ -708,10 +705,10 @@ M: x86 long-long-odd-register? f ; M: x86 float-right-align-on-stack? f ; -M: x86 immediate-arithmetic? ( n -- ? ) +M: x86 immediate-arithmetic? -0x80000000 0x7fffffff between? ; -M: x86 immediate-bitwise? ( n -- ? ) +M: x86 immediate-bitwise? -0x80000000 0x7fffffff between? ; :: %cmov-float= ( dst src -- ) @@ -778,7 +775,7 @@ M:: x86 %bit-test ( dst src1 src2 temp -- ) src1 src2 BT dst temp \ CMOVB (%boolean) ; -M: x86 enable-cpu-features ( -- ) +M: x86 enable-cpu-features enable-min/max enable-log2 enable-bit-test diff --git a/basis/cpu/x86/x87/x87.factor b/basis/cpu/x86/x87/x87.factor index f8997b78f7..640d3d7dbb 100644 --- a/basis/cpu/x86/x87/x87.factor +++ b/basis/cpu/x86/x87/x87.factor @@ -86,14 +86,14 @@ M:: x86 %float>integer ( dst src -- ) src2 shuffle-down quot call ST0 FSTP ; inline -M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- ) +M: x86 %compare-float-ordered [ [ FCOMI ] compare-op ] (%compare-float) ; -M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- ) +M: x86 %compare-float-unordered [ [ FUCOMI ] compare-op ] (%compare-float) ; -M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- ) +M: x86 %compare-float-ordered-branch [ [ FCOMI ] compare-op ] (%compare-float-branch) ; -M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- ) +M: x86 %compare-float-unordered-branch [ [ FUCOMI ] compare-op ] (%compare-float-branch) ; diff --git a/basis/db/db.factor b/basis/db/db.factor index 9c57ae65b3..216b120907 100644 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -26,7 +26,7 @@ HOOK: parse-db-error db-connection ( error -- error' ) : dispose-statements ( assoc -- ) values dispose-each ; -M: db-connection dispose ( db-connection -- ) +M: db-connection dispose dup db-connection [ [ dispose-statements H{ } clone ] change-insert-statements [ dispose-statements H{ } clone ] change-update-statements @@ -76,7 +76,7 @@ GENERIC: bind-tuple ( tuple statement -- ) GENERIC: execute-statement* ( statement type -- ) -M: object execute-statement* ( statement type -- ) +M: object execute-statement* '[ _ _ drop query-results dispose ] [ @@ -138,9 +138,9 @@ HOOK: begin-transaction db-connection ( -- ) HOOK: commit-transaction db-connection ( -- ) HOOK: rollback-transaction db-connection ( -- ) -M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ; -M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ; -M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ; +M: db-connection begin-transaction "BEGIN" sql-command ; +M: db-connection commit-transaction "COMMIT" sql-command ; +M: db-connection rollback-transaction "ROLLBACK" sql-command ; : in-transaction? ( -- ? ) in-transaction get ; diff --git a/basis/db/pools/pools.factor b/basis/db/pools/pools.factor index b0d9d69913..ebb3c008ad 100644 --- a/basis/db/pools/pools.factor +++ b/basis/db/pools/pools.factor @@ -13,7 +13,7 @@ TUPLE: db-pool < pool db ; : with-db-pool ( db quot -- ) [ ] dip with-pool ; inline -M: db-pool make-connection ( pool -- conn ) +M: db-pool make-connection db>> db-open ; : with-pooled-db ( pool quot -- ) diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 5a51dc0e12..b56ad0bc11 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -31,7 +31,7 @@ IN: db.postgresql.lib ERROR: postgresql-result-null ; -M: postgresql-result-null summary ( obj -- str ) +M: postgresql-result-null summary drop "PQexec returned f." ; : postgresql-result-ok? ( res -- ? ) @@ -126,7 +126,7 @@ M: postgresql-result-null summary ( obj -- str ) TUPLE: postgresql-malloc-destructor alien ; C: postgresql-malloc-destructor -M: postgresql-malloc-destructor dispose ( obj -- ) +M: postgresql-malloc-destructor dispose alien>> PQfreemem ; : &postgresql-free ( alien -- alien ) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 12bbd56dcf..34baeba51c 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -25,7 +25,7 @@ TUPLE: postgresql-statement < statement ; TUPLE: postgresql-result-set < result-set ; -M: postgresql-db db-open ( db -- db-connection ) +M: postgresql-db db-open { [ host>> ] [ port>> ] @@ -36,46 +36,46 @@ M: postgresql-db db-open ( db -- db-connection ) [ password>> ] } cleave connect-postgres ; -M: postgresql-db-connection db-close ( handle -- ) PQfinish ; +M: postgresql-db-connection db-close PQfinish ; -M: postgresql-statement bind-statement* ( statement -- ) drop ; +M: postgresql-statement bind-statement* drop ; GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding ) -M: sql-spec postgresql-bind-conversion ( tuple spec -- object ) +M: sql-spec postgresql-bind-conversion slot-name>> swap get-slot-named ; -M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object ) +M: literal-bind postgresql-bind-conversion nip value>> ; -M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object ) +M: generator-bind postgresql-bind-conversion dup generator-singleton>> eval-generator [ swap slot-name>> rot set-slot-named ] [ ] bi ; -M: postgresql-statement bind-tuple ( tuple statement -- ) +M: postgresql-statement bind-tuple [ nip ] [ in-params>> [ postgresql-bind-conversion ] with map ] 2bi >>bind-params drop ; -M: postgresql-result-set #rows ( result-set -- n ) +M: postgresql-result-set #rows handle>> PQntuples ; -M: postgresql-result-set #columns ( result-set -- n ) +M: postgresql-result-set #columns handle>> PQnfields ; : result-handle-n ( result-set -- handle n ) [ handle>> ] [ n>> ] bi ; -M: postgresql-result-set row-column ( result-set column -- object ) +M: postgresql-result-set row-column [ result-handle-n ] dip pq-get-string ; -M: postgresql-result-set row-column-typed ( result-set column -- object ) +M: postgresql-result-set row-column-typed dup pick out-params>> nth type>> [ result-handle-n ] 2dip postgresql-column-typed ; -M: postgresql-statement query-results ( query -- result-set ) +M: postgresql-statement query-results dup bind-params>> [ over [ bind-statement ] keep do-postgresql-bound-statement @@ -85,17 +85,17 @@ M: postgresql-statement query-results ( query -- result-set ) postgresql-result-set new-result-set dup init-result-set ; -M: postgresql-result-set advance-row ( result-set -- ) +M: postgresql-result-set advance-row [ 1 + ] change-n drop ; -M: postgresql-result-set more-rows? ( result-set -- ? ) +M: postgresql-result-set more-rows? [ n>> ] [ max>> ] bi < ; -M: postgresql-statement dispose ( query -- ) +M: postgresql-statement dispose dup handle>> PQclear f >>handle drop ; -M: postgresql-result-set dispose ( result-set -- ) +M: postgresql-result-set dispose [ handle>> PQclear ] [ 0 >>n @@ -103,27 +103,27 @@ M: postgresql-result-set dispose ( result-set -- ) f >>handle drop ] bi ; -M: postgresql-statement prepare-statement ( statement -- ) +M: postgresql-statement prepare-statement dup [ db-connection get handle>> f ] dip [ sql>> ] [ in-params>> ] bi length f PQprepare postgresql-error >>handle drop ; -M: postgresql-db-connection ( sql in out -- statement ) +M: postgresql-db-connection postgresql-statement new-statement ; -M: postgresql-db-connection ( sql in out -- statement ) +M: postgresql-db-connection dup prepare-statement ; : bind-name% ( -- ) CHAR: $ 0, sql-counter [ inc ] [ get 0# ] bi ; -M: postgresql-db-connection bind% ( spec -- ) +M: postgresql-db-connection bind% bind-name% 1, ; -M: postgresql-db-connection bind# ( spec object -- ) +M: postgresql-db-connection bind# [ bind-name% f swap type>> ] dip 1, ; @@ -169,7 +169,7 @@ M: postgresql-db-connection bind# ( spec object -- ) "_seq'');' language sql;" 0% ] query-make ; -M: postgresql-db-connection create-sql-statement ( class -- seq ) +M: postgresql-db-connection create-sql-statement [ [ create-table-sql , ] keep dup db-assigned? [ create-function-sql , ] [ drop ] if @@ -189,13 +189,13 @@ M: postgresql-db-connection create-sql-statement ( class -- seq ) "drop table " 0% 0% drop ] query-make ; -M: postgresql-db-connection drop-sql-statement ( class -- seq ) +M: postgresql-db-connection drop-sql-statement [ [ drop-table-sql , ] keep dup db-assigned? [ drop-function-sql , ] [ drop ] if ] { } make ; -M: postgresql-db-connection ( class -- statement ) +M: postgresql-db-connection [ "select add_" 0% 0% "(" 0% @@ -205,7 +205,7 @@ M: postgresql-db-connection ( class -- statement ");" 0% ] query-make ; -M: postgresql-db-connection ( class -- statement ) +M: postgresql-db-connection [ "insert into " 0% 0% "(" 0% @@ -228,10 +228,10 @@ M: postgresql-db-connection ( class -- statemen ");" 0% ] query-make ; -M: postgresql-db-connection insert-tuple-set-key ( tuple statement -- ) +M: postgresql-db-connection insert-tuple-set-key query-modify-tuple ; -M: postgresql-db-connection persistent-table ( -- hashtable ) +M: postgresql-db-connection persistent-table H{ { +db-assigned-id+ { "integer" "serial" f } } { +user-assigned-id+ { f f f } } @@ -271,7 +271,7 @@ M: postgresql-db-connection persistent-table ( -- hashtable ) } ; ERROR: no-compound-found string object ; -M: postgresql-db-connection compound ( string object -- string' ) +M: postgresql-db-connection compound over { { "default" [ first number>string " " glue ] } { "varchar" [ first number>string "(" ")" surround append ] } diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 3357ee5635..f68420a48f 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -33,7 +33,7 @@ SINGLETON: retryable ] if ] 2map >>bind-params ; -M: retryable execute-statement* ( statement type -- ) +M: retryable execute-statement* drop [ retries>> ] [ [ nip @@ -62,7 +62,7 @@ M: retryable execute-statement* ( statement type -- ) dup column-name>> 0% " = " 0% bind% ] interleave ; -M: db-connection ( class -- statement ) +M: db-connection [ "update " 0% 0% " set " 0% @@ -71,7 +71,7 @@ M: db-connection ( class -- statement ) where-primary-key% ] query-make ; -M: random-id-generator eval-generator ( singleton -- obj ) +M: random-id-generator eval-generator drop system-random-generator get [ 63 [ random-bits ] keep 1 - set-bit @@ -102,32 +102,32 @@ M: random-id-generator eval-generator ( singleton -- obj ) : in-parens ( quot -- ) "(" 0% call ")" 0% ; inline -M: interval where ( spec obj -- ) +M: interval where [ [ from>> "from" where-interval ] [ nip infinite-interval? [ " and " 0% ] unless ] [ to>> "to" where-interval ] 2tri ] in-parens ; -M: sequence where ( spec obj -- ) +M: sequence where [ [ " or " 0% ] [ dupd where ] interleave drop ] in-parens ; -M: byte-array where ( spec obj -- ) +M: byte-array where over column-name>> 0% " = " 0% bind# ; -M: NULL where ( spec obj -- ) +M: NULL where drop column-name>> 0% " is NULL" 0% ; : object-where ( spec obj -- ) over column-name>> 0% " = " 0% bind# ; -M: object where ( spec obj -- ) object-where ; +M: object where object-where ; -M: integer where ( spec obj -- ) object-where ; +M: integer where object-where ; -M: string where ( spec obj -- ) object-where ; +M: string where object-where ; : filter-slots ( tuple specs -- specs' ) [ @@ -145,7 +145,7 @@ M: string where ( spec obj -- ) object-where ; : where-clause ( tuple specs -- ) dupd filter-slots [ drop ] [ many-where ] if-empty ; -M: db-connection ( tuple table -- sql ) +M: db-connection [ "delete from " 0% 0% where-clause @@ -153,7 +153,7 @@ M: db-connection ( tuple table -- sql ) ERROR: all-slots-ignored class ; -M: db-connection ( tuple class -- statement ) +M: db-connection [ "select " 0% [ dupd filter-ignores ] dip @@ -188,13 +188,13 @@ M: db-connection ( tuple class -- statement ) [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; -M: db-connection query>statement ( query -- tuple ) +M: db-connection query>statement [ tuple>> dup class-of ] keep [ ] dip make-query* ; ! select ID, NAME, SCORE from EXAM limit 1 offset 3 -M: db-connection ( query -- statement ) +M: db-connection [ tuple>> dup class-of ] keep [ [ "select count(*) from " 0% 0% where-clause ] query-make ] dip make-query* ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 6b786bb851..bf148b3371 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -22,19 +22,19 @@ TUPLE: sqlite-db-connection < db-connection ; PRIVATE> -M: sqlite-db db-open ( db -- db-connection ) +M: sqlite-db db-open path>> sqlite-open ; -M: sqlite-db-connection db-close ( handle -- ) sqlite-close ; +M: sqlite-db-connection db-close sqlite-close ; TUPLE: sqlite-statement < statement ; TUPLE: sqlite-result-set < result-set has-more? ; -M: sqlite-db-connection ( str in out -- obj ) +M: sqlite-db-connection ; -M: sqlite-db-connection ( str in out -- obj ) +M: sqlite-db-connection sqlite-statement new-statement ; : sqlite-maybe-prepare ( statement -- statement ) @@ -43,22 +43,22 @@ M: sqlite-db-connection ( str in out -- obj ) >>handle ] unless ; -M: sqlite-statement dispose ( statement -- ) +M: sqlite-statement dispose handle>> [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ; -M: sqlite-result-set dispose ( result-set -- ) +M: sqlite-result-set dispose f >>handle drop ; : reset-bindings ( statement -- ) sqlite-maybe-prepare handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ; -M: sqlite-statement low-level-bind ( statement -- ) +M: sqlite-statement low-level-bind [ handle>> ] [ bind-params>> ] bi [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ; -M: sqlite-statement bind-statement* ( statement -- ) +M: sqlite-statement bind-statement* sqlite-maybe-prepare dup bound?>> [ dup reset-bindings ] when low-level-bind ; @@ -72,12 +72,12 @@ TUPLE: sqlite-low-level-binding < low-level-binding key type ; swap >>value swap >>key ; -M: sql-spec sqlite-bind-conversion ( tuple spec -- array ) +M: sql-spec sqlite-bind-conversion [ column-name>> ":" prepend ] [ slot-name>> rot get-slot-named ] [ type>> ] tri ; -M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) +M: literal-bind sqlite-bind-conversion nip [ key>> ] [ value>> ] [ type>> ] tri ; @@ -87,7 +87,7 @@ M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) obj name tuple set-slot-named generate-bind key>> obj generate-bind type>> ; -M: sqlite-statement bind-tuple ( tuple statement -- ) +M: sqlite-statement bind-tuple [ in-params>> [ sqlite-bind-conversion ] with map ] keep bind-statement ; @@ -98,31 +98,31 @@ ERROR: sqlite-last-id-fail ; db-connection get handle>> sqlite3_last_insert_rowid dup zero? [ sqlite-last-id-fail ] when ; -M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- ) +M: sqlite-db-connection insert-tuple-set-key execute-statement last-insert-id swap set-primary-key ; -M: sqlite-result-set #columns ( result-set -- n ) +M: sqlite-result-set #columns handle>> sqlite-#columns ; -M: sqlite-result-set row-column ( result-set n -- obj ) +M: sqlite-result-set row-column [ handle>> ] [ sqlite-column ] bi* ; -M: sqlite-result-set row-column-typed ( result-set n -- obj ) +M: sqlite-result-set row-column-typed dup pick out-params>> nth type>> [ handle>> ] 2dip sqlite-column-typed ; -M: sqlite-result-set advance-row ( result-set -- ) +M: sqlite-result-set advance-row dup handle>> sqlite-next >>has-more? drop ; -M: sqlite-result-set more-rows? ( result-set -- ? ) +M: sqlite-result-set more-rows? has-more?>> ; -M: sqlite-statement query-results ( query -- result-set ) +M: sqlite-statement query-results sqlite-maybe-prepare dup handle>> sqlite-result-set new-result-set dup advance-row ; -M: sqlite-db-connection ( class -- statement ) +M: sqlite-db-connection [ "insert into " 0% 0% "(" 0% @@ -143,19 +143,19 @@ M: sqlite-db-connection ( class -- statement ) ");" 0% ] query-make ; -M: sqlite-db-connection ( class -- statement ) +M: sqlite-db-connection ; -M: sqlite-db-connection bind# ( spec obj -- ) +M: sqlite-db-connection bind# [ [ column-name>> ":" next-sql-counter surround dup 0% ] [ type>> ] bi ] dip 1, ; -M: sqlite-db-connection bind% ( spec -- ) +M: sqlite-db-connection bind% dup 1, column-name>> ":" prepend 0% ; -M: sqlite-db-connection persistent-table ( -- assoc ) +M: sqlite-db-connection persistent-table H{ { +db-assigned-id+ { "integer" "integer" f } } { +user-assigned-id+ { f f f } } @@ -314,16 +314,16 @@ M: sqlite-db-connection persistent-table ( -- assoc ) ");" 0% ] 2bi ; -M: sqlite-db-connection create-sql-statement ( class -- statement ) +M: sqlite-db-connection create-sql-statement [ [ sqlite-create-table ] [ drop create-db-triggers ] 2bi ] query-make ; -M: sqlite-db-connection drop-sql-statement ( class -- statements ) +M: sqlite-db-connection drop-sql-statement [ nip "drop table " 0% 0% ";" 0% ] query-make ; -M: sqlite-db-connection compound ( string seq -- new-string ) +M: sqlite-db-connection compound over { { "default" [ first number>string " " glue ] } { "references" [ >reference-string ] } diff --git a/basis/debugger/unix/unix.factor b/basis/debugger/unix/unix.factor index 62b2969c5a..f4f859cd1c 100644 --- a/basis/debugger/unix/unix.factor +++ b/basis/debugger/unix/unix.factor @@ -4,6 +4,6 @@ USING: debugger io kernel prettyprint sequences system unix.signals ; IN: debugger.unix -M: unix signal-error. ( obj -- ) +M: unix signal-error. "Unix signal #" write third [ pprint ] [ signal-name. ] bi nl ; diff --git a/basis/editors/atom/atom.factor b/basis/editors/atom/atom.factor index e5b9d152cc..e9c468dfd5 100644 --- a/basis/editors/atom/atom.factor +++ b/basis/editors/atom/atom.factor @@ -21,7 +21,7 @@ M: macosx find-atom f ] if* ; -M: atom-editor editor-command ( file line -- command ) +M: atom-editor editor-command [ atom-path get [ find-atom ] unless* , number>string ":" glue , diff --git a/basis/editors/bbedit/bbedit.factor b/basis/editors/bbedit/bbedit.factor index 26e5130a57..baeccc8528 100644 --- a/basis/editors/bbedit/bbedit.factor +++ b/basis/editors/bbedit/bbedit.factor @@ -4,6 +4,6 @@ IN: editors.bbedit SINGLETON: bbedit bbedit editor-class set-global -M: bbedit editor-command ( file line -- command ) +M: bbedit editor-command drop [ "open" , "-a" , "BBEdit" , , ] { } make ; diff --git a/basis/editors/brackets/brackets.factor b/basis/editors/brackets/brackets.factor index 6b1f2c0255..7ec154aa9b 100644 --- a/basis/editors/brackets/brackets.factor +++ b/basis/editors/brackets/brackets.factor @@ -16,7 +16,7 @@ M: macosx brackets-path f ] if* ; -M: brackets-editor editor-command ( file line -- command ) +M: brackets-editor editor-command [ brackets-path "brackets" or , drop , ] { } make ; os windows? [ "editors.brackets.windows" require ] when diff --git a/basis/editors/coteditor/coteditor.factor b/basis/editors/coteditor/coteditor.factor index e7bb45cb2b..af0507f68d 100644 --- a/basis/editors/coteditor/coteditor.factor +++ b/basis/editors/coteditor/coteditor.factor @@ -12,5 +12,5 @@ coteditor editor-class set-global f ] if* ; -M: coteditor editor-command ( file line -- command ) +M: coteditor editor-command [ find-cot-bundle-path , "-l" , number>string , , ] { } make ; diff --git a/basis/editors/editpadpro/editpadpro.factor b/basis/editors/editpadpro/editpadpro.factor index e3d930b2f9..6e85490a98 100644 --- a/basis/editors/editpadpro/editpadpro.factor +++ b/basis/editors/editpadpro/editpadpro.factor @@ -14,7 +14,7 @@ editpadpro editor-class set-global } 0|| ] unless* ; -M: editpadpro editor-command ( file line -- command ) +M: editpadpro editor-command [ editpadpro-path , number>string "/l" prepend , , ] { } make ; diff --git a/basis/editors/editplus/editplus.factor b/basis/editors/editplus/editplus.factor index a3dc23887c..db203e2abd 100644 --- a/basis/editors/editplus/editplus.factor +++ b/basis/editors/editplus/editplus.factor @@ -11,7 +11,7 @@ editplus editor-class set-global [ "editplus.exe" ] unless* ] unless* ; -M: editplus editor-command ( file line -- command ) +M: editplus editor-command [ editplus-path , "-cursor" , number>string , , ] { } make ; diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor index 051f7c1bfb..ec1e08fb5b 100644 --- a/basis/editors/emacs/emacs.factor +++ b/basis/editors/emacs/emacs.factor @@ -10,7 +10,7 @@ SYMBOL: emacsclient-args HOOK: find-emacsclient os ( -- path ) -M: object find-emacsclient ( -- path ) +M: object find-emacsclient "emacsclient" ?find-in-path ; M: windows find-emacsclient @@ -20,7 +20,7 @@ M: windows find-emacsclient [ "emacsclient.exe" ] } 0|| ; -M: emacsclient editor-command ( file line -- command ) +M: emacsclient editor-command [ emacsclient-path get [ find-emacsclient ] unless* , emacsclient-args get [ { "-a=emacs" "--no-wait" } ] unless* % diff --git a/basis/editors/emeditor/emeditor.factor b/basis/editors/emeditor/emeditor.factor index 9f6c3ec745..fe5ee1c725 100644 --- a/basis/editors/emeditor/emeditor.factor +++ b/basis/editors/emeditor/emeditor.factor @@ -11,7 +11,7 @@ emeditor editor-class set-global [ "EmEditor.exe" ] unless* ] unless* ; -M: emeditor editor-command ( file line -- command ) +M: emeditor editor-command [ emeditor-path , "/l" , number>string , , ] { } make ; diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor index 459f5b8ddb..75e8a2252f 100644 --- a/basis/editors/etexteditor/etexteditor.factor +++ b/basis/editors/etexteditor/etexteditor.factor @@ -13,7 +13,7 @@ etexteditor editor-class set-global [ "e.exe" ] unless* ] unless* ; -M: etexteditor editor-command ( file line -- command ) +M: etexteditor editor-command [ etexteditor-path , [ , ] [ "--line" , number>string , ] bi* diff --git a/basis/editors/gedit/gedit.factor b/basis/editors/gedit/gedit.factor index f1d7b9314f..117802001e 100644 --- a/basis/editors/gedit/gedit.factor +++ b/basis/editors/gedit/gedit.factor @@ -12,7 +12,7 @@ gedit editor-class set-global "gedit" ?find-in-path ] unless* ; -M: gedit editor-command ( file line -- command ) +M: gedit editor-command [ gedit-path , number>string "+" prepend , , ] { } make ; diff --git a/basis/editors/jedit/jedit.factor b/basis/editors/jedit/jedit.factor index 26d20375dc..c6544d534c 100644 --- a/basis/editors/jedit/jedit.factor +++ b/basis/editors/jedit/jedit.factor @@ -27,7 +27,7 @@ M: windows find-jedit-path find-jedit-path [ "jedit" ?find-in-path ] unless* ] unless* ; -M: jedit editor-command ( file line -- command/f ) +M: jedit editor-command [ find-jedit-path , "-reuseview" , diff --git a/basis/editors/notepad++/notepad++.factor b/basis/editors/notepad++/notepad++.factor index 9951943dc8..0a3085ec42 100644 --- a/basis/editors/notepad++/notepad++.factor +++ b/basis/editors/notepad++/notepad++.factor @@ -11,7 +11,7 @@ notepad++ editor-class set-global [ "notepad++.exe" ] unless* ] unless* ; -M: notepad++ editor-command ( file line -- command ) +M: notepad++ editor-command [ notepad++-path , number>string "-n" prepend , , diff --git a/basis/editors/notepad/notepad.factor b/basis/editors/notepad/notepad.factor index 7725a4b993..de381cf35c 100644 --- a/basis/editors/notepad/notepad.factor +++ b/basis/editors/notepad/notepad.factor @@ -14,5 +14,5 @@ notepad editor-class set-global [ "notepad.exe" tail? ] find-file ] unless* ; -M: notepad editor-command ( file line -- command ) +M: notepad editor-command drop [ notepad-path ] dip 2array ; diff --git a/basis/editors/notepad2/notepad2.factor b/basis/editors/notepad2/notepad2.factor index 070273994c..9c9f90a0d9 100644 --- a/basis/editors/notepad2/notepad2.factor +++ b/basis/editors/notepad2/notepad2.factor @@ -11,7 +11,7 @@ notepad2 editor-class set-global [ "notepad.exe" ] unless* ] unless* ; -M: notepad2 editor-command ( file line -- command ) +M: notepad2 editor-command [ notepad2-path , "/g" , number>string , , diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor index 49e1d74b07..e58229ab14 100644 --- a/basis/editors/scite/scite.factor +++ b/basis/editors/scite/scite.factor @@ -21,7 +21,7 @@ M: windows find-scite-path } "scite.exe" find-in-applications [ "scite.exe" ] unless* ; -M: scite editor-command ( file line -- cmd ) +M: scite editor-command swap [ scite-path get [ find-scite-path ] unless* , diff --git a/basis/editors/sublime/sublime.factor b/basis/editors/sublime/sublime.factor index df08f603c7..a457ded4fe 100644 --- a/basis/editors/sublime/sublime.factor +++ b/basis/editors/sublime/sublime.factor @@ -31,7 +31,7 @@ M: windows find-sublime-path find-sublime-path [ "subl" ?find-in-path ] unless* ] unless* ; -M: sublime editor-command ( file line -- command ) +M: sublime editor-command [ sublime-path , "-a" , number>string ":" glue , ] { } make ; diff --git a/basis/editors/ted-notepad/ted-notepad.factor b/basis/editors/ted-notepad/ted-notepad.factor index c463b0b294..fe1ce8478f 100644 --- a/basis/editors/ted-notepad/ted-notepad.factor +++ b/basis/editors/ted-notepad/ted-notepad.factor @@ -11,7 +11,7 @@ ted-notepad editor-class set-global [ "TedNPad.exe" ] unless* ] unless* ; -M: ted-notepad editor-command ( file line -- command ) +M: ted-notepad editor-command [ ted-notepad-path , number>string "/l" prepend , , diff --git a/basis/editors/textadept/textadept.factor b/basis/editors/textadept/textadept.factor index 0d37095573..1edfbdcf4f 100644 --- a/basis/editors/textadept/textadept.factor +++ b/basis/editors/textadept/textadept.factor @@ -37,7 +37,7 @@ M: windows find-textadept-path find-textadept-path [ "textadept" ?find-in-path ] unless* ] unless* ; -M: textadept editor-command ( file line -- command ) +M: textadept editor-command swap [ textadept-path , "-f" , , "-e" , 1 - number>string "goto_line(" ")" surround , diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor index c21004b06d..9c0c50cc7b 100644 --- a/basis/editors/textedit/textedit.factor +++ b/basis/editors/textedit/textedit.factor @@ -5,6 +5,6 @@ IN: editors.textedit SINGLETON: textedit textedit editor-class set-global -M: textedit editor-command ( file line -- command ) +M: textedit editor-command drop [ "open" , "-a" , "TextEdit" , , ] { } make ; diff --git a/basis/editors/textmate/textmate.factor b/basis/editors/textmate/textmate.factor index 20d1ca928d..8dd5dc1b9a 100644 --- a/basis/editors/textmate/textmate.factor +++ b/basis/editors/textmate/textmate.factor @@ -5,5 +5,5 @@ IN: editors.textmate SINGLETON: textmate textmate editor-class set-global -M: textmate editor-command ( file line -- command ) +M: textmate editor-command [ "mate" , "-a" , "-l" , number>string , , ] { } make ; diff --git a/basis/editors/textpad/textpad.factor b/basis/editors/textpad/textpad.factor index a2b0abb6e6..62cb493d1b 100644 --- a/basis/editors/textpad/textpad.factor +++ b/basis/editors/textpad/textpad.factor @@ -11,7 +11,7 @@ textpad editor-class set-global [ "TextPad.exe" ] unless* ] unless* ; -M: textpad editor-command ( file line -- command ) +M: textpad editor-command [ textpad-path , [ , ] [ number>string "(" ",0)" surround , ] bi* diff --git a/basis/editors/ultraedit/ultraedit.factor b/basis/editors/ultraedit/ultraedit.factor index ec69b80472..10bee45909 100644 --- a/basis/editors/ultraedit/ultraedit.factor +++ b/basis/editors/ultraedit/ultraedit.factor @@ -11,7 +11,7 @@ ultraedit editor-class set-global [ "uedit32.exe" ] unless* ] unless* ; -M: ultraedit editor-command ( file line -- command ) +M: ultraedit editor-command [ ultraedit-path , [ swap % "/" % # "/1" % ] "" make , ] { } make ; diff --git a/basis/editors/vim/vim.factor b/basis/editors/vim/vim.factor index 3040980baf..79618ac08b 100644 --- a/basis/editors/vim/vim.factor +++ b/basis/editors/vim/vim.factor @@ -20,7 +20,7 @@ M: vim find-vim-path "vim" ?find-in-path ; : actual-vim-path ( -- path ) \ vim-path get [ find-vim-path ] unless* ; -M: vim editor-command ( file line -- command ) +M: vim editor-command [ actual-vim-path dup string? [ , ] [ % ] if vim-ui? [ "-g" , ] when diff --git a/basis/editors/visual-studio-code/visual-studio-code.factor b/basis/editors/visual-studio-code/visual-studio-code.factor index 56d4f5a76b..e88181deb6 100644 --- a/basis/editors/visual-studio-code/visual-studio-code.factor +++ b/basis/editors/visual-studio-code/visual-studio-code.factor @@ -45,7 +45,7 @@ M: windows find-visual-studio-code-invocation [ "code.cmd" ] } 0|| ; -M: visual-studio-code editor-command ( file line -- command ) +M: visual-studio-code editor-command [ visual-studio-code-invocation [ , ] [ can't-find-visual-studio-code ] if* diff --git a/basis/editors/wordpad/wordpad.factor b/basis/editors/wordpad/wordpad.factor index ca5aa9a621..3245e0cfd8 100644 --- a/basis/editors/wordpad/wordpad.factor +++ b/basis/editors/wordpad/wordpad.factor @@ -9,5 +9,5 @@ wordpad editor-class set-global { "Windows NT\\Accessories" } "wordpad.exe" find-in-applications ] unless* ; -M: wordpad editor-command ( file line -- command ) +M: wordpad editor-command drop [ wordpad-path ] dip 2array ; diff --git a/basis/editors/xcode/xcode.factor b/basis/editors/xcode/xcode.factor index 0978c94dbd..c59d0edcca 100644 --- a/basis/editors/xcode/xcode.factor +++ b/basis/editors/xcode/xcode.factor @@ -5,6 +5,6 @@ IN: editors.xcode SINGLETON: xcode xcode editor-class set-global -M: xcode editor-command ( file line -- command ) +M: xcode editor-command drop [ "open" , "-a" , "XCode" , , ] { } make ; diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor index 222ba72226..a68e0013ee 100644 --- a/basis/environment/unix/unix.factor +++ b/basis/environment/unix/unix.factor @@ -7,27 +7,27 @@ IN: environment.unix HOOK: environ os ( -- void* ) -M: unix environ ( -- void* ) &: environ ; +M: unix environ &: environ ; -M: unix os-env ( key -- value ) getenv ; +M: unix os-env getenv ; -M: unix set-os-env ( value key -- ) +M: unix set-os-env over [ swap 1 setenv io-error ] [ nip unset-os-env ] if ; -M: unix unset-os-env ( key -- ) unsetenv io-error ; +M: unix unset-os-env unsetenv io-error ; -M: unix (os-envs) ( -- seq ) +M: unix (os-envs) environ void* deref native-string-encoding alien>strings ; : set-void* ( value alien -- ) 0 set-alien-cell ; -M: unix set-os-envs-pointer ( malloc -- ) environ set-void* ; +M: unix set-os-envs-pointer environ set-void* ; -M: unix (set-os-envs) ( seq -- ) +M: unix (set-os-envs) utf8 strings>alien malloc-byte-array set-os-envs-pointer ; os macosx? [ "environment.unix.macosx" require ] when diff --git a/basis/environment/windows/windows.factor b/basis/environment/windows/windows.factor index d3a4a3f437..2ff126c887 100644 --- a/basis/environment/windows/windows.factor +++ b/basis/environment/windows/windows.factor @@ -7,7 +7,7 @@ io.streams.memory io.encodings io specialized-arrays ; SPECIALIZED-ARRAY: TCHAR IN: environment.windows -M: windows os-env ( key -- value ) +M: windows os-env MAX_UNICODE_PATH TCHAR [ dup length GetEnvironmentVariable ] keep over 0 = [ 2drop f @@ -15,16 +15,16 @@ M: windows os-env ( key -- value ) nip alien>native-string ] if ; -M: windows set-os-env ( value key -- ) +M: windows set-os-env swap SetEnvironmentVariable win32-error=0/f ; -M: windows unset-os-env ( key -- ) +M: windows unset-os-env f SetEnvironmentVariable 0 = [ GetLastError ERROR_ENVVAR_NOT_FOUND = [ win32-error ] unless ] when ; -M: windows (os-envs) ( -- seq ) +M: windows (os-envs) GetEnvironmentStrings [ [ utf16n decode-input diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index 9e6fc75e77..bd146487f3 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -141,7 +141,7 @@ TUPLE: dredge-fry-state PRIVATE> -M: callable fry ( quot -- quot' ) +M: callable fry [ [ [ ] ] ] [ 0 swap [ dredge-fry ] [ diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 1bd87be393..0459518853 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -175,7 +175,7 @@ GENERIC: handle-passive-command ( stream obj -- ) : finish-directory ( -- ) "Directory send OK." 226 server-response ; -M: ftp-list handle-passive-command ( stream obj -- ) +M: ftp-list handle-passive-command drop start-directory [ utf8 encode-output [ @@ -184,7 +184,7 @@ M: ftp-list handle-passive-command ( stream obj -- ) harvest [ ftp-send ] each ] with-output-stream finish-directory ; -M: ftp-get handle-passive-command ( stream obj -- ) +M: ftp-get handle-passive-command [ path>> [ transfer-outgoing-file ] @@ -194,7 +194,7 @@ M: ftp-get handle-passive-command ( stream obj -- ) 3drop "File transfer failed" ftp-error ] recover ; -M: ftp-put handle-passive-command ( stream obj -- ) +M: ftp-put handle-passive-command [ path>> [ transfer-incoming-file ] @@ -204,7 +204,7 @@ M: ftp-put handle-passive-command ( stream obj -- ) 3drop "File transfer failed" ftp-error ] recover ; -M: ftp-disconnect handle-passive-command ( stream obj -- ) +M: ftp-disconnect handle-passive-command drop dispose ; : fulfill-client ( obj -- ) @@ -344,7 +344,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- ) handle-client-loop ] with-directory ; -M: ftp-server handle-client* ( server -- ) +M: ftp-server handle-client* [ "New client" \ handle-client* DEBUG log-message ftp-client new client set diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index 18f97aa534..5e0a7664e0 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -100,7 +100,7 @@ CONSTANT: revalidate-url-key "__u" begin-form handle-rest ; -M: action call-responder* ( path action -- response ) +M: action call-responder* [ init-action ] keep request get method>> { { "GET" [ handle-get ] } diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor index 4f2568b636..83664095f9 100644 --- a/basis/furnace/asides/asides.factor +++ b/basis/furnace/asides/asides.factor @@ -87,7 +87,7 @@ ERROR: end-aside-in-get-error ; : end-aside ( default -- response ) aside-id get aside-id off get-aside [ move-on ] [ ] ?if ; -M: asides link-attr ( tag responder -- ) +M: asides link-attr drop "aside" optional-attr { { "none" [ aside-id off ] } @@ -96,13 +96,13 @@ M: asides link-attr ( tag responder -- ) { f [ ] } } case ; -M: asides modify-query ( query asides -- query' ) +M: asides modify-query drop aside-id get [ aside-id-key associate assoc-union ] when* ; -M: asides modify-form ( asides -- xml/f ) +M: asides modify-form drop aside-id get aside-id-key diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index 173984db32..e2930f461b 100644 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -97,7 +97,7 @@ M: user-saver dispose \ init-user DEBUG add-input-logging -M: realm call-responder* ( path responder -- response ) +M: realm call-responder* dup realm namespaces:set logged-in? [ dup init-realm @@ -146,7 +146,7 @@ TUPLE: protected < filter-responder description capabilities ; } cond ] if ; -M: protected call-responder* ( path responder -- response ) +M: protected call-responder* dup protected namespaces:set dup capabilities>> have-capabilities? [ call-next-method ] [ diff --git a/basis/furnace/auth/basic/basic.factor b/basis/furnace/auth/basic/basic.factor index af5f34e3e3..8081193a41 100644 --- a/basis/furnace/auth/basic/basic.factor +++ b/basis/furnace/auth/basic/basic.factor @@ -20,10 +20,10 @@ TUPLE: basic-auth-realm < realm ; 401 "Invalid username or password" [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ; -M: basic-auth-realm login-required* ( description capabilities realm -- response ) +M: basic-auth-realm login-required* 2nip name>> <401> ; -M: basic-auth-realm logged-in-username ( realm -- uid ) +M: basic-auth-realm logged-in-username drop request get "authorization" header parse-basic-auth dup [ over check-login swap and ] [ 2drop f ] if ; diff --git a/basis/furnace/auth/login/login.factor b/basis/furnace/auth/login/login.factor index 48efebfc71..df1fb55d53 100644 --- a/basis/furnace/auth/login/login.factor +++ b/basis/furnace/auth/login/login.factor @@ -29,7 +29,7 @@ M: login-realm init-realm M: login-realm logged-in-username drop permit-id get dup [ get-permit-uid ] when ; -M: login-realm modify-form ( responder -- xml/f ) +M: login-realm modify-form drop permit-id get realm get name>> permit-id-key hidden-form-field ; : ( -- cookie ) @@ -95,7 +95,7 @@ CONSTANT: flashed-variables { description capabilities } [ logout ] >>submit ; -M: login-realm login-required* ( description capabilities login -- response ) +M: login-realm login-required* begin-conversation [ description cset ] [ capabilities cset ] [ secure>> ] tri* [ @@ -106,7 +106,7 @@ M: login-realm login-required* ( description capabilities login -- response ) URL" $realm/login" ] if ; -M: login-realm user-registered ( user realm -- response ) +M: login-realm user-registered drop successful-login ; : ( responder name -- realm ) diff --git a/basis/furnace/auth/providers/assoc/assoc.factor b/basis/furnace/auth/providers/assoc/assoc.factor index 712ef13e98..70af86f283 100644 --- a/basis/furnace/auth/providers/assoc/assoc.factor +++ b/basis/furnace/auth/providers/assoc/assoc.factor @@ -8,11 +8,10 @@ TUPLE: users-in-memory assoc ; : ( -- provider ) H{ } clone users-in-memory boa ; -M: users-in-memory get-user ( username provider -- user/f ) - assoc>> at ; +M: users-in-memory get-user assoc>> at ; -M: users-in-memory update-user ( user provider -- ) 2drop ; +M: users-in-memory update-user 2drop ; -M: users-in-memory new-user ( user provider -- user/f ) +M: users-in-memory new-user [ dup username>> ] dip assoc>> 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ; diff --git a/basis/furnace/auth/providers/couchdb/couchdb.factor b/basis/furnace/auth/providers/couchdb/couchdb.factor index a01c80baac..58f9a61d9d 100644 --- a/basis/furnace/auth/providers/couchdb/couchdb.factor +++ b/basis/furnace/auth/providers/couchdb/couchdb.factor @@ -194,19 +194,19 @@ PRIVATE> : ( base-url username-view -- couchdb-auth-provider ) couchdb-auth-provider new swap >>username-view swap >>base-url ; -M: couchdb-auth-provider get-user ( username provider -- user/f ) +M: couchdb-auth-provider get-user couchdb-auth-provider [ (get-user) [ user-hash>user ] [ f ] if* ] with-variable ; -M: couchdb-auth-provider new-user ( user provider -- user/f ) +M: couchdb-auth-provider new-user couchdb-auth-provider [ dup (new-user) [ username>> couchdb-auth-provider get get-user ] [ drop f ] if ] with-variable ; -M: couchdb-auth-provider update-user ( user provider -- ) +M: couchdb-auth-provider update-user couchdb-auth-provider [ [ username>> (get-user)/throw-on-no-user dup ] [ drop "_id" of get-url ] diff --git a/basis/furnace/conversations/conversations.factor b/basis/furnace/conversations/conversations.factor index e66941bda0..bf6d0552bb 100644 --- a/basis/furnace/conversations/conversations.factor +++ b/basis/furnace/conversations/conversations.factor @@ -106,7 +106,7 @@ M: conversations call-responder* bi ] [ drop ] if* ; -M: conversations modify-form ( conversations -- xml/f ) +M: conversations modify-form drop conversation-id get conversation-id-key diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index 13deeff9a0..917d4f5113 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/basis/furnace/sessions/sessions.factor @@ -98,10 +98,10 @@ CONSTANT: session-id-key "__s" : put-session-cookie ( response -- response' ) put-cookie ; -M: sessions modify-form ( responder -- xml/f ) +M: sessions modify-form drop session get id>> session-id-key hidden-form-field ; -M: sessions call-responder* ( path responder -- response ) +M: sessions call-responder* sessions set request-session [ begin-session ] unless* existing-session put-session-cookie ; diff --git a/basis/game/input/iokit/iokit.factor b/basis/game/input/iokit/iokit.factor index 44518c6ad9..74564bc1d2 100644 --- a/basis/game/input/iokit/iokit.factor +++ b/basis/game/input/iokit/iokit.factor @@ -334,28 +334,30 @@ M: iokit-game-input-backend (close-game-input) f +controller-states+ set-global ] when ; -M: iokit-game-input-backend get-controllers ( -- sequence ) +M: iokit-game-input-backend get-controllers +controller-states+ get-global keys [ controller boa ] map ; : ?join ( pre post sep -- string ) 2over subseq-start [ swap 2nip ] [ [ 2array ] dip join ] if ; -M: iokit-game-input-backend product-string ( controller -- string ) +M: iokit-game-input-backend product-string handle>> [ kIOHIDManufacturerKey device-property ] [ kIOHIDProductKey device-property ] bi " " ?join ; -M: iokit-game-input-backend product-id ( controller -- integer ) + +M: iokit-game-input-backend product-id handle>> [ kIOHIDVendorIDKey device-property ] [ kIOHIDProductIDKey device-property ] bi 2array ; -M: iokit-game-input-backend instance-id ( controller -- integer ) + +M: iokit-game-input-backend instance-id handle>> kIOHIDLocationIDKey device-property ; -M: iokit-game-input-backend read-controller ( controller -- controller-state ) +M: iokit-game-input-backend read-controller handle>> +controller-states+ get-global at clone ; -M: iokit-game-input-backend read-keyboard ( -- keyboard-state ) +M: iokit-game-input-backend read-keyboard +keyboard-state+ get-global clone keyboard-state boa ; -M: iokit-game-input-backend calibrate-controller ( controller -- ) +M: iokit-game-input-backend calibrate-controller drop ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index c23888aa33..69940c614d 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -35,11 +35,9 @@ TUPLE: max-heap < heap ; : ( -- max-heap ) max-heap ; -M: heap heap-empty? ( heap -- ? ) - data>> empty? ; inline +M: heap heap-empty? data>> empty? ; inline -M: heap heap-size ( heap -- n ) - data>> length ; inline +M: heap heap-size data>> length ; inline : >entry< ( entry -- value key ) [ value>> ] [ key>> ] bi ; inline -M: heap heap-peek ( heap -- value key ) +M: heap heap-peek data>> first >entry< ; fhtml -M: fhtml call-template* ( filename -- ) +M: fhtml call-template* path>> utf8 file-contents eval-template ; INSTANCE: fhtml template diff --git a/basis/http/server/dispatchers/dispatchers.factor b/basis/http/server/dispatchers/dispatchers.factor index 1534a5a8cd..ea932c7c20 100644 --- a/basis/http/server/dispatchers/dispatchers.factor +++ b/basis/http/server/dispatchers/dispatchers.factor @@ -23,7 +23,7 @@ TUPLE: dispatcher default responders ; [ [ drop rest-slice ] dip ] [ drop default>> ] if ] if ; -M: dispatcher call-responder* ( path dispatcher -- response ) +M: dispatcher call-responder* find-responder call-responder ; TUPLE: vhost-dispatcher default responders ; @@ -38,7 +38,7 @@ TUPLE: vhost-dispatcher default responders ; url get host>> canonical-host over responders>> at* [ nip ] [ drop default>> ] if ; -M: vhost-dispatcher call-responder* ( path dispatcher -- response ) +M: vhost-dispatcher call-responder* find-vhost call-responder ; : add-responder ( dispatcher responder path -- dispatcher ) diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index 1467ff25f0..8ea64049d5 100644 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -48,13 +48,13 @@ GENERIC: write-full-response ( request response -- ) : write-response-body ( response -- response ) dup body>> call-template ; -M: response write-response ( respose -- ) +M: response write-response write-response-line write-response-header flush drop ; -M: response write-full-response ( request response -- ) +M: response write-full-response dup write-response swap method>> "HEAD" = [ [ content-encoding>> encode-output ] @@ -62,12 +62,12 @@ M: response write-full-response ( request response -- ) bi ] unless drop ; -M: raw-response write-response ( respose -- ) +M: raw-response write-response write-response-line write-response-body drop ; -M: raw-response write-full-response ( request response -- ) +M: raw-response write-full-response nip write-response ; : post-request? ( -- ? ) request get method>> "POST" = ; diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index ba794f047c..c05c6f1d5d 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -178,7 +178,7 @@ TUPLE: file-responder root hook special index-names allow-listings ; [ drop <404> ] if ; -M: file-responder call-responder* ( path responder -- response ) +M: file-responder call-responder* file-responder set ".." over member? [ drop <400> ] [ "/" join serve-object ] if ; diff --git a/basis/images/loader/gdiplus/gdiplus.factor b/basis/images/loader/gdiplus/gdiplus.factor index 7e9bdc08a4..12cb00577d 100644 --- a/basis/images/loader/gdiplus/gdiplus.factor +++ b/basis/images/loader/gdiplus/gdiplus.factor @@ -106,5 +106,5 @@ M: gdi+-image stream>image* gdi+-bitmap>data data>image ; -M: gdi+-image image>stream ( image extension class -- ) +M: gdi+-image image>stream drop startup-gdi+ output-stream get swap write-image-to-stream ; diff --git a/basis/io/backend/unix/bsd/bsd.factor b/basis/io/backend/unix/bsd/bsd.factor index 209d1ab1e0..5f93602052 100644 --- a/basis/io/backend/unix/bsd/bsd.factor +++ b/basis/io/backend/unix/bsd/bsd.factor @@ -5,5 +5,5 @@ unix io.backend io.backend.unix io.backend.unix.multiplexers io.backend.unix.multiplexers.kqueue io.files.unix ; IN: io.backend.unix.bsd -M: bsd init-io ( -- ) +M: bsd init-io mx set-global ; diff --git a/basis/io/backend/unix/freebsd/freebsd.factor b/basis/io/backend/unix/freebsd/freebsd.factor index 24c7518827..9c094679dc 100644 --- a/basis/io/backend/unix/freebsd/freebsd.factor +++ b/basis/io/backend/unix/freebsd/freebsd.factor @@ -2,9 +2,9 @@ USING: io.backend io.backend.unix system namespaces kernel accessors assocs cont << "io.files.unix" require >> ! needed for deploy -M: freebsd init-io ( -- ) +M: freebsd init-io mx set-global ; - + freebsd set-io-backend [ start-signal-pipe-thread ] diff --git a/basis/io/backend/unix/linux/linux.factor b/basis/io/backend/unix/linux/linux.factor index fa0ab2054f..f3e123cd84 100644 --- a/basis/io/backend/unix/linux/linux.factor +++ b/basis/io/backend/unix/linux/linux.factor @@ -5,7 +5,7 @@ io.backend.unix io.backend.unix.multiplexers io.backend.unix.multiplexers.epoll init ; IN: io.backend.unix.linux -M: linux init-io ( -- ) +M: linux init-io mx set-global ; linux set-io-backend diff --git a/basis/io/backend/unix/macosx/macosx.factor b/basis/io/backend/unix/macosx/macosx.factor index c1e31d1f6d..403b97b0ac 100644 --- a/basis/io/backend/unix/macosx/macosx.factor +++ b/basis/io/backend/unix/macosx/macosx.factor @@ -8,10 +8,10 @@ IN: io.backend.unix.macosx SINGLETON: macosx-kqueue -M: macosx-kqueue init-io ( -- ) +M: macosx-kqueue init-io mx set-global ; -M: macosx init-io ( -- ) +M: macosx init-io mx set-global ; macosx set-io-backend diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor index 9921b483f5..b4e941bbe8 100644 --- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -34,18 +34,18 @@ M: epoll-mx dispose* fd>> close-file ; : do-epoll-del ( fd mx events -- ) EPOLL_CTL_DEL swap do-epoll-ctl ; -M: epoll-mx add-input-callback ( thread fd mx -- ) +M: epoll-mx add-input-callback [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ; -M: epoll-mx add-output-callback ( thread fd mx -- ) +M: epoll-mx add-output-callback [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ; -M: epoll-mx remove-input-callbacks ( fd mx -- seq ) +M: epoll-mx remove-input-callbacks 2dup reads>> key? [ [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi ] [ 2drop f ] if ; -M: epoll-mx remove-output-callbacks ( fd mx -- seq ) +M: epoll-mx remove-output-callbacks 2dup writes>> key? [ [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi ] [ 2drop f ] if ; @@ -62,5 +62,5 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq ) : handle-events ( mx n -- ) [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ; -M: epoll-mx wait-for-events ( nanos mx -- ) +M: epoll-mx wait-for-events swap 60000000 or dupd wait-event handle-events ; diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index 5696c2df99..65fab251a4 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -29,19 +29,19 @@ M: kqueue-mx dispose* fd>> close-file ; : register-kevent ( kevent mx -- ) fd>> swap 1 f 0 f kevent-func io-error ; -M: kqueue-mx add-input-callback ( thread fd mx -- ) +M: kqueue-mx add-input-callback [ call-next-method ] [ [ EVFILT_READ flags{ EV_ADD EV_ONESHOT } make-kevent ] dip register-kevent ] 2bi ; -M: kqueue-mx add-output-callback ( thread fd mx -- ) +M: kqueue-mx add-output-callback [ call-next-method ] [ [ EVFILT_WRITE flags{ EV_ADD EV_ONESHOT } make-kevent ] dip register-kevent ] 2bi ; -M: kqueue-mx remove-input-callbacks ( fd mx -- seq ) +M: kqueue-mx remove-input-callbacks 2dup reads>> key? [ [ call-next-method ] [ [ EVFILT_READ EV_DELETE make-kevent ] dip @@ -49,7 +49,7 @@ M: kqueue-mx remove-input-callbacks ( fd mx -- seq ) ] 2bi ] [ 2drop f ] if ; -M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) +M: kqueue-mx remove-output-callbacks 2dup writes>> key? [ [ [ EVFILT_WRITE EV_DELETE make-kevent ] dip @@ -73,6 +73,6 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) [ dup events>> ] dip head-slice [ handle-kevent ] with each ; -M: kqueue-mx wait-for-events ( nanos mx -- ) +M: kqueue-mx wait-for-events swap dup [ make-timespec ] when dupd wait-kevent handle-kevents ; diff --git a/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor index 8ee5c9fb74..b13976e054 100644 --- a/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor +++ b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor @@ -30,5 +30,5 @@ M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ; M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ; M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ; -M: run-loop-mx wait-for-events ( nanos mx -- ) +M: run-loop-mx wait-for-events swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ; diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 5a8b45c7ba..a081a063d9 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -37,7 +37,7 @@ M: fd dispose M: fd handle-fd check-disposed fd>> ; -M: fd cancel-operation ( fd -- ) +M: fd cancel-operation [ fd>> mx get-global @@ -46,10 +46,10 @@ M: fd cancel-operation ( fd -- ) 2bi ] unless-disposed ; -M: unix tell-handle ( handle -- n ) +M: unix tell-handle fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ; -M: unix seek-handle ( n seek-type handle -- ) +M: unix seek-handle swap { { io:seek-absolute [ SEEK_SET ] } { io:seek-relative [ SEEK_CUR ] } @@ -58,10 +58,10 @@ M: unix seek-handle ( n seek-type handle -- ) } case [ fd>> swap ] dip [ lseek ] unix-system-call drop ; -M: unix can-seek-handle? ( handle -- ? ) +M: unix can-seek-handle? fd>> SEEK_CUR 0 lseek -1 = not ; -M: unix handle-length ( handle -- n/f ) +M: unix handle-length fd>> \ stat [ fstat -1 = not ] keep swap [ st_size>> ] [ drop f ] if ; @@ -69,7 +69,7 @@ ERROR: io-timeout ; M: io-timeout summary drop "I/O operation timed out" ; -M: unix wait-for-fd ( handle event -- ) +M: unix wait-for-fd dup +retry+ eq? [ 2drop ] [ [ [ self ] dip handle-fd mx get-global ] dip { { +input+ [ add-input-callback ] } @@ -96,7 +96,7 @@ M: fd refill } case ] if ; -M: unix (wait-to-read) ( port -- ) +M: unix (wait-to-read) dup dup handle>> check-disposed refill dup [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ; @@ -116,12 +116,12 @@ M: fd drain } case ] if ; -M: unix (wait-to-write) ( port -- ) +M: unix (wait-to-write) dup dup handle>> check-disposed drain [ wait-for-port ] [ drop ] if* ; -M: unix io-multiplex ( nanos -- ) +M: unix io-multiplex mx get-global wait-for-events ; ! On Unix, you're not supposed to set stdin to non-blocking diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor index 4ef4fafbfa..8f2c61831f 100644 --- a/basis/io/directories/unix/linux/linux.factor +++ b/basis/io/directories/unix/linux/linux.factor @@ -10,7 +10,7 @@ IN: io.directories.unix.linux readdir64_r [ (throw-errno) ] unless-zero ] 2keep void* deref ; inline -M: linux (directory-entries) ( path -- seq ) +M: linux (directory-entries) [ dirent '[ _ _ next-dirent ] [ >directory-entry ] produce nip diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 2b989fe501..65c1eea8ee 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -11,31 +11,31 @@ CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL } CONSTANT: mkdir-mode flags{ USER-ALL GROUP-ALL OTHER-ALL } ! 0o777 -M: unix touch-file ( path -- ) +M: unix touch-file normalize-path dup exists? [ touch ] [ touch-mode file-mode open-file close-file ] if ; -M: unix move-file-atomically ( from to -- ) +M: unix move-file-atomically [ normalize-path ] bi@ [ rename ] unix-system-call drop ; -M: unix move-file ( from to -- ) +M: unix move-file [ move-file-atomically ] [ dup errno>> EXDEV = [ drop [ copy-file ] [ drop delete-file ] 2bi ] [ rethrow ] if ] recover ; -M: unix delete-file ( path -- ) normalize-path unlink-file ; +M: unix delete-file normalize-path unlink-file ; -M: unix make-directory ( path -- ) +M: unix make-directory normalize-path mkdir-mode [ mkdir ] unix-system-call drop ; -M: unix delete-directory ( path -- ) +M: unix delete-directory normalize-path [ rmdir ] unix-system-call drop ; -M: unix copy-file ( from to -- ) +M: unix copy-file [ call-next-method ] [ [ file-permissions ] dip swap set-file-permissions ] 2bi ; @@ -71,7 +71,7 @@ M: unix copy-file ( from to -- ) dup +unknown+ = [ drop dup file-info type>> ] when ; inline -M: unix (directory-entries) ( path -- seq ) +M: unix (directory-entries) [ dirent '[ _ _ next-dirent ] [ >directory-entry ] produce nip diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor index b6a97b9516..f3e54c56f9 100644 --- a/basis/io/directories/windows/windows.factor +++ b/basis/io/directories/windows/windows.factor @@ -7,17 +7,17 @@ windows.kernel32 alien.c-types sequences splitting fry continuations classes.struct windows.time ; IN: io.directories.windows -M: windows touch-file ( path -- ) +M: windows touch-file [ normalize-path maybe-create-file [ &dispose ] dip [ drop ] [ handle>> f now dup (set-file-times) ] if ] with-destructors ; -M: windows move-file ( from to -- ) +M: windows move-file [ normalize-path ] bi@ MoveFile win32-error=0/f ; -M: windows move-file-atomically ( from to -- ) +M: windows move-file-atomically [ normalize-path ] bi@ 0 MoveFileEx win32-error=0/f ; ERROR: file-delete-failed path error ; @@ -34,16 +34,16 @@ ERROR: file-delete-failed path error ; [ delete-read-only-file ] [ drop win32-error ] if ] [ drop ] if ; -M: windows delete-file ( path -- ) +M: windows delete-file absolute-path [ (delete-file) ] [ file-delete-failed boa rethrow ] recover ; -M: windows make-directory ( path -- ) +M: windows make-directory normalize-path f CreateDirectory win32-error=0/f ; -M: windows delete-directory ( path -- ) +M: windows delete-directory normalize-path RemoveDirectory win32-error=0/f ; @@ -71,7 +71,7 @@ C: windows-directory-entry [ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ] tri ; inline -M: windows (directory-entries) ( path -- seq ) +M: windows (directory-entries) "\\" ?tail drop "\\*" append WIN32_FIND_DATA find-first-file over diff --git a/basis/io/encodings/euc/euc.factor b/basis/io/encodings/euc/euc.factor index 8bd6c86cf5..1d65e146ac 100644 --- a/basis/io/encodings/euc/euc.factor +++ b/basis/io/encodings/euc/euc.factor @@ -12,7 +12,7 @@ TUPLE: euc { table biassoc read-only } ; : byte? ( ch -- ? ) 0x0 0xff between? ; -M: euc encode-char ( char stream encoding -- ) +M: euc encode-char swapd table>> value-at [ dup byte? [ swap stream-write1 ] [ diff --git a/basis/io/encodings/gb18030/gb18030.factor b/basis/io/encodings/gb18030/gb18030.factor index 7e9d167857..6198b406e9 100644 --- a/basis/io/encodings/gb18030/gb18030.factor +++ b/basis/io/encodings/gb18030/gb18030.factor @@ -92,7 +92,7 @@ ascii xml>gb-data [ ufirst>> - ] [ bfirst>> ] bi + unlinear ] [ encode-error ] if* ; -M: gb18030 encode-char ( char stream encoding -- ) +M: gb18030 encode-char drop [ dup mapping get-global at [ ] [ lookup-range ] ?if @@ -128,7 +128,7 @@ M: gb18030 encode-char ( char stream encoding -- ) [ 3drop replacement-char ] } cond ; -M: gb18030 decode-char ( stream encoding -- char ) +M: gb18030 decode-char drop dup stream-read1 { { [ dup not ] [ 2drop f ] } { [ dup ascii? ] [ nip 1byte-array mapping get-global value-at ] } diff --git a/basis/io/encodings/utf32/utf32.factor b/basis/io/encodings/utf32/utf32.factor index 005922c31a..ba0938e1c0 100644 --- a/basis/io/encodings/utf32/utf32.factor +++ b/basis/io/encodings/utf32/utf32.factor @@ -53,10 +53,10 @@ CONSTANT: bom-be B{ 0 0 0xfe 0xff } bom-be sequence= [ utf32be ] [ missing-bom ] if ] if ; -M: utf32 ( stream utf32 -- decoder ) +M: utf32 drop 4 over stream-read bom>le/be ; -M: utf32 ( stream utf32 -- encoder ) +M: utf32 drop bom-le over stream-write utf32le ; PRIVATE> diff --git a/basis/io/encodings/utf7/utf7.factor b/basis/io/encodings/utf7/utf7.factor index 3fe399c2d5..bf1706a2cf 100644 --- a/basis/io/encodings/utf7/utf7.factor +++ b/basis/io/encodings/utf7/utf7.factor @@ -45,7 +45,7 @@ TUPLE: utf7codec dialect buffer ; ] until ] B{ } make 3nip ; -M: utf7codec encode-string ( str stream codec -- ) +M: utf7codec encode-string swapd encode-utf7-string swap stream-write ; DEFER: emit-char @@ -65,7 +65,7 @@ DEFER: emit-char : replace-all! ( src dst -- ) [ delete-all ] keep push-all ; -M: utf7codec decode-char ( stream codec -- char/f ) +M: utf7codec decode-char swap [ [ dialect>> ] [ buffer>> ] bi [ emit-char ] keep replace-all! ] with-input-stream ; diff --git a/basis/io/files/info/unix/bsd/bsd.factor b/basis/io/files/info/unix/bsd/bsd.factor index 64fcd0b5d6..053c7e0f87 100644 --- a/basis/io/files/info/unix/bsd/bsd.factor +++ b/basis/io/files/info/unix/bsd/bsd.factor @@ -7,9 +7,9 @@ IN: io.files.info.unix.bsd TUPLE: bsd-file-info < unix-file-info birth-time flags gen ; -M: bsd new-file-info ( -- class ) bsd-file-info new ; +M: bsd new-file-info bsd-file-info new ; -M: bsd stat>file-info ( stat -- file-info ) +M: bsd stat>file-info [ call-next-method ] keep { [ st_flags>> >>flags ] diff --git a/basis/io/files/info/unix/freebsd/freebsd.factor b/basis/io/files/info/unix/freebsd/freebsd.factor index d4ceea9843..51966fdf27 100644 --- a/basis/io/files/info/unix/freebsd/freebsd.factor +++ b/basis/io/files/info/unix/freebsd/freebsd.factor @@ -12,9 +12,9 @@ IN: io.files.info.unix.freebsd TUPLE: freebsd-file-info < unix-file-info birth-time flags gen ; -M: freebsd new-file-info ( -- class ) freebsd-file-info new ; +M: freebsd new-file-info freebsd-file-info new ; -M: freebsd stat>file-info ( stat -- file-info ) +M: freebsd stat>file-info [ call-next-method ] keep { [ st_flags>> >>flags ] @@ -25,20 +25,20 @@ M: freebsd stat>file-info ( stat -- file-info ) TUPLE: freebsd-file-system-info < unix-file-system-info io-size owner type-id filesystem-subtype ; -M: freebsd file-systems ( -- array ) +M: freebsd file-systems f void* dup 0 getmntinfo dup io-error [ void* deref ] dip \ statfs [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ; M: freebsd new-file-system-info freebsd-file-system-info new ; -M: freebsd file-system-statfs ( normalized-path -- statfs ) +M: freebsd file-system-statfs \ statfs [ statfs-func io-error ] keep ; -M: freebsd file-system-statvfs ( normalized-path -- statvfs ) +M: freebsd file-system-statvfs \ statvfs [ statvfs-func io-error ] keep ; -M: freebsd statfs>file-system-info ( file-system-info byte-array -- file-system-info' ) +M: freebsd statfs>file-system-info { [ f_bsize>> >>block-size ] [ f_iosize>> >>io-size ] @@ -56,7 +56,7 @@ M: freebsd statfs>file-system-info ( file-system-info byte-array -- file-system- [ f_mntfromname>> utf8 alien>string >>device-name ] } cleave ; -M: freebsd statvfs>file-system-info ( file-system-info byte-array -- file-system-info' ) +M: freebsd statvfs>file-system-info { [ f_frsize>> >>preferred-block-size ] [ f_favail>> >>files-available ] diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 52948eccc7..5a2b07f054 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -13,10 +13,10 @@ namelen ; M: linux new-file-system-info linux-file-system-info new ; -M: linux file-system-statfs ( path -- statfs ) +M: linux file-system-statfs \ statfs64 [ statfs64 io-error ] keep ; -M: linux statfs>file-system-info ( file-system-info statfs -- file-system-info' ) +M: linux statfs>file-system-info { [ f_type>> >>type ] [ f_bsize>> >>block-size ] @@ -31,10 +31,10 @@ M: linux statfs>file-system-info ( file-system-info statfs -- file-system-info' ! [ statfs64-f_spare >>spare ] } cleave ; -M: linux file-system-statvfs ( path -- statvfs ) +M: linux file-system-statvfs \ statvfs64 [ statvfs64 io-error ] keep ; -M: linux statvfs>file-system-info ( file-system-info statfs -- file-system-info' ) +M: linux statvfs>file-system-info { [ f_flag>> >>flags ] [ f_namemax>> >>name-max ] @@ -90,7 +90,7 @@ M: linux mount-points M: linux file-systems parse-mtab [ mtab-entry>file-system-info ] map sift ; -M: linux file-system-info ( path -- file-system-info ) +M: linux file-system-info normalize-path [ (file-system-info) ] [ ] bi find-mount-point { diff --git a/basis/io/files/info/unix/macosx/macosx.factor b/basis/io/files/info/unix/macosx/macosx.factor index dd3e555af6..d78705b922 100644 --- a/basis/io/files/info/unix/macosx/macosx.factor +++ b/basis/io/files/info/unix/macosx/macosx.factor @@ -12,9 +12,9 @@ IN: io.files.info.unix.macosx TUPLE: macosx-file-info < unix-file-info birth-time flags gen ; -M: macosx new-file-info ( -- class ) macosx-file-info new ; +M: macosx new-file-info macosx-file-info new ; -M: macosx stat>file-info ( stat -- file-info ) +M: macosx stat>file-info [ call-next-method ] keep { [ st_flags>> >>flags ] @@ -25,20 +25,20 @@ M: macosx stat>file-info ( stat -- file-info ) TUPLE: macosx-file-system-info < unix-file-system-info io-size owner type-id filesystem-subtype ; -M: macosx file-systems ( -- array ) +M: macosx file-systems f void* dup 0 getmntinfo64 dup io-error [ void* deref ] dip \ statfs64 [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ; M: macosx new-file-system-info macosx-file-system-info new ; -M: macosx file-system-statfs ( normalized-path -- statfs ) +M: macosx file-system-statfs \ statfs64 [ statfs64-func io-error ] keep ; -M: macosx file-system-statvfs ( normalized-path -- statvfs ) +M: macosx file-system-statvfs \ statvfs [ statvfs-func io-error ] keep ; -M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' ) +M: macosx statfs>file-system-info { [ f_bsize>> >>block-size ] [ f_iosize>> >>io-size ] @@ -57,7 +57,7 @@ M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-i [ f_mntfromname>> utf8 alien>string >>device-name ] } cleave ; -M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' ) +M: macosx statvfs>file-system-info { [ f_frsize>> >>preferred-block-size ] [ f_favail>> >>files-available ] diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index a6e8a34561..cf19aeb35b 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -57,17 +57,17 @@ HOOK: stat>file-info os ( stat -- file-info ) HOOK: stat>type os ( stat -- file-info ) -M: unix file-info ( path -- info ) +M: unix file-info normalize-path file-status stat>file-info ; -M: unix link-info ( path -- info ) +M: unix link-info normalize-path link-status stat>file-info ; -M: unix new-file-info ( -- class ) unix-file-info new ; +M: unix new-file-info unix-file-info new ; CONSTANT: standard-unix-block-size 512 -M: unix stat>file-info ( stat -- file-info ) +M: unix stat>file-info [ new-file-info ] dip { [ stat>type >>type ] @@ -99,7 +99,7 @@ M: unix stat>file-info ( stat -- file-info ) [ drop +unknown+ ] } case ; -M: unix stat>type ( stat -- type ) +M: unix stat>type st_mode>> n>file-type ; file-info ] if ; -M: windows file-info ( path -- info ) +M: windows file-info normalize-path [ get-file-information-stat ] [ set-windows-size-on-disk ] bi ; -M: windows link-info ( path -- info ) +M: windows link-info file-info ; : file-executable-type ( path -- executable/f ) @@ -168,7 +168,7 @@ ERROR: not-absolute-path ; PRIVATE> -M: windows file-system-info ( path -- file-system-info ) +M: windows file-system-info normalize-path root-directory (file-system-info) ; CONSTANT: names-buf-length 16384 @@ -216,7 +216,7 @@ CONSTANT: names-buf-length 16384 ! Can error with T{ windows-error f 21 "The device is not ready." } ! if there is a D: that is not ready, for instance. Ignore these drives. -M: windows file-systems ( -- array ) +M: windows file-systems find-volumes [ volume>paths ] map concat [ [ (file-system-info) ] [ 2drop f ] recover ] map sift ; diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index 3f67bb453f..456ae95193 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -4,15 +4,15 @@ USING: io.backend io.files io.files.links io.pathnames kernel sequences system unix unix.ffi ; IN: io.files.links.unix -M: unix make-link ( path1 path2 -- ) +M: unix make-link normalize-path [ symlink ] unix-system-call drop ; -M: unix make-hard-link ( path1 path2 -- ) +M: unix make-hard-link normalize-path [ link ] unix-system-call drop ; -M: unix read-link ( path -- path' ) +M: unix read-link normalize-path read-symbolic-link ; -M: unix resolve-symlinks ( path -- path' ) +M: unix resolve-symlinks path-components "/" [ append-path dup exists? [ follow-links ] when ] reduce ; diff --git a/basis/io/files/unique/unix/unix.factor b/basis/io/files/unique/unix/unix.factor index 11b5931887..31e7dde767 100644 --- a/basis/io/files/unique/unix/unix.factor +++ b/basis/io/files/unique/unix/unix.factor @@ -6,5 +6,5 @@ IN: io.files.unique.unix CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL } -M: unix (touch-unique-file) ( path -- ) +M: unix (touch-unique-file) open-unique-flags file-mode open-file close-file ; diff --git a/basis/io/files/unique/windows/windows.factor b/basis/io/files/unique/windows/windows.factor index faa025a6ec..59223fee30 100644 --- a/basis/io/files/unique/windows/windows.factor +++ b/basis/io/files/unique/windows/windows.factor @@ -2,5 +2,5 @@ USING: destructors environment io.files.unique.private io.files.windows system windows.kernel32 ; IN: io.files.unique.windows -M: windows (touch-unique-file) ( path -- ) +M: windows (touch-unique-file) GENERIC_WRITE CREATE_NEW 0 open-file dispose ; diff --git a/basis/io/files/unix/unix.factor b/basis/io/files/unix/unix.factor index 47aa5bb34d..09743b144e 100644 --- a/basis/io/files/unix/unix.factor +++ b/basis/io/files/unix/unix.factor @@ -14,16 +14,16 @@ IN: io.files.unix ] [ rethrow ] if ] recover ; -M: unix cwd ( -- path ) +M: unix cwd 4096 (cwd) ; -M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; +M: unix cd [ chdir ] unix-system-call drop ; CONSTANT: read-flags flags{ O_RDONLY } : open-read ( path -- fd ) read-flags file-mode open-file ; -M: unix (file-reader) ( path -- stream ) +M: unix (file-reader) open-read init-fd ; CONSTANT: write-flags flags{ O_WRONLY O_CREAT O_TRUNC } @@ -31,7 +31,7 @@ CONSTANT: write-flags flags{ O_WRONLY O_CREAT O_TRUNC } : open-write ( path -- fd ) write-flags file-mode open-file ; -M: unix (file-writer) ( path -- stream ) +M: unix (file-writer) open-write init-fd ; CONSTANT: append-flags flags{ O_WRONLY O_APPEND O_CREAT } @@ -42,7 +42,7 @@ CONSTANT: append-flags flags{ O_WRONLY O_APPEND O_CREAT } dup 0 SEEK_END [ lseek ] unix-system-call drop ] with-destructors ; -M: unix (file-appender) ( path -- stream ) +M: unix (file-appender) open-append init-fd ; M: unix home "HOME" os-env ; diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index 4bd2c90879..7f9bdfb960 100644 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -102,10 +102,10 @@ SYMBOL: master-completion-port M: win32-handle cancel-operation [ handle>> CancelIo win32-error=0/f ] unless-disposed ; -M: windows io-multiplex ( nanos -- ) +M: windows io-multiplex handle-overlapped [ 0 io-multiplex ] when ; -M: windows init-io ( -- ) +M: windows init-io master-completion-port set-global H{ } clone pending-overlapped set-global ; @@ -125,9 +125,9 @@ ERROR: seek-before-start n ; : set-seek-ptr ( n handle -- ) [ dup 0 < [ seek-before-start ] when ] dip ptr<< ; -M: windows tell-handle ( handle -- n ) ptr>> ; +M: windows tell-handle ptr>> ; -M: windows seek-handle ( n seek-type handle -- ) +M: windows seek-handle swap { { seek-absolute [ set-seek-ptr ] } { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] } @@ -135,10 +135,10 @@ M: windows seek-handle ( n seek-type handle -- ) [ bad-seek-type ] } case ; -M: windows can-seek-handle? ( handle -- ? ) +M: windows can-seek-handle? handle>> handle>file-size >boolean ; -M: windows handle-length ( handle -- n/f ) +M: windows handle-length handle>> handle>file-size dup { 0 f } member? [ drop f ] when ; @@ -182,7 +182,7 @@ M: windows handle-length ( handle -- n/f ) : finish-write ( n port -- ) [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; -M: object drain ( port handle -- event/f ) +M: object drain [ make-FileArgs dup setup-write WriteFile ] [ drop [ wait-for-file ] [ finish-write ] bi ] 2bi f ; @@ -197,14 +197,14 @@ M: object drain ( port handle -- event/f ) : finish-read ( n port -- ) [ update-file-ptr ] [ buffer>> buffer+ ] 2bi ; -M: object refill ( port handle -- event/f ) +M: object refill [ make-FileArgs dup setup-read ReadFile ] [ drop [ wait-for-file ] [ finish-read ] bi ] 2bi f ; -M: windows (wait-to-write) ( port -- ) +M: windows (wait-to-write) [ dup handle>> drain ] with-destructors drop ; -M: windows (wait-to-read) ( port -- ) +M: windows (wait-to-read) [ dup handle>> refill ] with-destructors drop ; : make-fd-set ( socket -- fd_set ) @@ -215,7 +215,7 @@ M: windows (wait-to-read) ( port -- ) CONSTANT: select-timeval S{ timeval { sec 0 } { usec 1000 } } -M: windows wait-for-fd ( handle event -- ) +M: windows wait-for-fd [ file>> handle>> 1 swap ] dip select-sets select-timeval select drop yield ; @@ -255,13 +255,13 @@ M: windows init-stdio [ [ handle>> ] dip d>w/w LONG ] dip SetFilePointer INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ; -M: windows (file-reader) ( path -- stream ) +M: windows (file-reader) open-read ; -M: windows (file-writer) ( path -- stream ) +M: windows (file-writer) open-write ; -M: windows (file-appender) ( path -- stream ) +M: windows (file-appender) open-append ; SYMBOLS: +read-only+ +hidden+ +system+ @@ -314,7 +314,7 @@ M: windows cd CONSTANT: unicode-prefix "\\\\?\\" -M: windows root-directory? ( path -- ? ) +M: windows root-directory? { { [ dup empty? ] [ drop f ] } { [ dup [ path-separator? ] all? ] [ drop t ] } @@ -354,7 +354,7 @@ M: windows root-path remove-unicode-prefix root-path* ; M: windows relative-path remove-unicode-prefix relative-path* ; -M: windows normalize-path ( string -- string' ) +M: windows normalize-path dup unc-path? [ normalize-separators ] [ diff --git a/basis/io/launcher/unix/unix.factor b/basis/io/launcher/unix/unix.factor index c82ee9ff8c..0b299331f8 100644 --- a/basis/io/launcher/unix/unix.factor +++ b/basis/io/launcher/unix/unix.factor @@ -99,12 +99,12 @@ IN: io.launcher.unix [ setup-environment ] [ 2drop 253 _exit ] recover [ get-arguments posix-spawn ] [ drop ] recover ; -M: unix (current-process) ( -- handle ) getpid ; +M: unix (current-process) getpid ; -M: unix (run-process) ( process -- pid ) +M: unix (run-process) '[ _ fork-process ] [ ] with-fork ; -M: unix (kill-process) ( process -- ) +M: unix (kill-process) [ handle>> SIGTERM ] [ group>> ] bi { { +same-group+ [ kill ] } { +new-group+ [ killpg ] } @@ -117,7 +117,7 @@ M: unix (kill-process) ( process -- ) : code>status ( code -- obj ) dup WIFSIGNALED [ WTERMSIG sig:signal boa ] [ WEXITSTATUS ] if ; -M: unix (wait-for-processes) ( -- ? ) +M: unix (wait-for-processes) { int } [ -1 swap WNOHANG waitpid ] with-out-parameters swap dup 0 <= [ 2drop t diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 4897aa07f0..613cb70f88 100644 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -146,7 +146,7 @@ TUPLE: CreateProcess-args fill-startup-info nip ; -M: windows (current-process) ( -- handle ) +M: windows (current-process) GetCurrentProcessId ; ERROR: launch-error process error ; @@ -157,7 +157,7 @@ M: launch-error error. "Launch descriptor:" print nl process>> . ; -M: windows (kill-process) ( process -- ) +M: windows (kill-process) handle>> hProcess>> 255 TerminateProcess win32-error=0/f ; : dispose-process ( process-information -- ) @@ -176,7 +176,7 @@ M: windows (kill-process) ( process -- ) over handle>> dispose-process notify-exit ; -M: windows (wait-for-processes) ( -- ? ) +M: windows (wait-for-processes) processes get keys dup [ handle>> hProcess>> ] void*-array{ } map-as [ length ] keep 0 0 @@ -285,7 +285,7 @@ M: windows (wait-for-processes) ( -- ? ) [ [ redirect-stderr ] dip hStdError<< ] [ [ redirect-stdin ] dip hStdInput<< ] 3tri ; -M: windows (run-process) ( process -- handle ) +M: windows (run-process) [ [ dup make-CreateProcess-args diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 67c245d956..1d6a3344e2 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -35,7 +35,7 @@ PRIVATE> HOOK: close-mapped-file io-backend ( mmap -- ) -M: mapped-file dispose* ( mmap -- ) close-mapped-file ; +M: mapped-file dispose* close-mapped-file ; : with-mapped-file ( path quot -- ) [ ] dip with-disposal ; inline diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index ff6a3f4937..ddbad1cb9f 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -21,6 +21,6 @@ M: unix (mapped-file-reader) flags{ MAP_FILE MAP_SHARED } O_RDONLY mmap-open ; -M: unix close-mapped-file ( mmap -- ) +M: unix close-mapped-file [ [ address>> ] [ length>> ] bi munmap io-error ] [ handle>> close-file ] bi ; diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index bd18c12eda..525190383d 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -44,7 +44,7 @@ M: windows (mapped-file-reader) -rot ] with-destructors ; -M: windows close-mapped-file ( mapped-file -- ) +M: windows close-mapped-file [ [ handle>> &dispose drop ] [ address>> UnmapViewOfFile win32-error=0/f ] bi diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor index 4b73cb708c..44078c935e 100644 --- a/basis/io/monitors/linux/linux.factor +++ b/basis/io/monitors/linux/linux.factor @@ -44,7 +44,7 @@ TUPLE: linux-monitor < monitor wd inotify watches ; "Calling outside with-monitors" throw ] unless ; -M: linux (monitor) ( path recursive? mailbox -- monitor ) +M: linux (monitor) swap [ ] [ @@ -52,7 +52,7 @@ M: linux (monitor) ( path recursive? mailbox -- monitor ) IN_CHANGE_EVENTS swap add-watch ] if ; -M: linux-monitor dispose* ( monitor -- ) +M: linux-monitor dispose* [ [ wd>> ] [ watches>> ] bi delete-at ] [ dup inotify>> disposed>> [ drop ] [ diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index 6c6a364097..9df6c52a5f 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -8,7 +8,7 @@ IN: io.pipes TUPLE: pipe in out ; -M: pipe dispose ( pipe -- ) +M: pipe dispose [ [ in>> &dispose drop ] [ out>> &dispose drop ] bi @@ -42,7 +42,7 @@ M: callable run-pipeline-element GENERIC: ( obj -- pipes ) -M: integer ( n -- pipes ) +M: integer [ [ (pipe) |dispose ] replicate T{ pipe } [ prefix ] [ suffix ] bi diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor index 92058e805f..f950a9d6be 100644 --- a/basis/io/pipes/unix/unix.factor +++ b/basis/io/pipes/unix/unix.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.data system kernel unix math sequences -io.backend.unix io.ports libc specialized-arrays accessors unix.ffi ; -QUALIFIED: io.pipes +USING: alien.c-types alien.data io.backend.unix io.pipes kernel +libc sequences specialized-arrays system unix.ffi ; SPECIALIZED-ARRAY: int IN: io.pipes.unix -M: unix io.pipes:(pipe) ( -- pair ) +M: unix (pipe) 2 int - [ pipe io-error ] + [ unix.ffi:pipe io-error ] [ first2 [ init-fd ] bi@ io.pipes:pipe boa ] bi ; diff --git a/basis/io/pipes/windows/windows.factor b/basis/io/pipes/windows/windows.factor index 7a87df65e8..ccfa24f13f 100644 --- a/basis/io/pipes/windows/windows.factor +++ b/basis/io/pipes/windows/windows.factor @@ -39,7 +39,7 @@ IN: io.pipes.windows nano-count # ] "" make ; -M: windows (pipe) ( -- pipe ) +M: windows (pipe) [ unique-pipe-name [ create-named-pipe ] [ open-other-end ] bi diff --git a/basis/io/sockets/secure/debug/debug.factor b/basis/io/sockets/secure/debug/debug.factor index eb7d55e45f..9088915788 100644 --- a/basis/io/sockets/secure/debug/debug.factor +++ b/basis/io/sockets/secure/debug/debug.factor @@ -3,17 +3,15 @@ USING: accessors io.sockets.secure kernel ; IN: io.sockets.secure.debug - GENERIC: * ( obj -- config ) - -M: TLSv1 * ( obj -- config ) +M: TLSv1 * drop "vocab:openssl/test-1.0/server.pem" >>key-file "vocab:openssl/test-1.0/dh1024.pem" >>dh-file "password" >>password ; -M: object * ( obj -- config ) +M: object * drop "vocab:openssl/test-1.2/server.pem" >>key-file "vocab:openssl/test-1.2/dh1024.pem" >>dh-file diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index a7ca47d3e5..e0d0f44cd6 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -160,7 +160,7 @@ M: bio dispose* handle>> BIO_free ssl-error ; V{ } clone >>aliens H{ } clone >>sessions ; -M: openssl ( config -- context ) +M: openssl maybe-init-ssl [ dup method>> ssl-method SSL_CTX_new @@ -276,7 +276,7 @@ SYMBOL: default-secure-context { { SSL_ERROR_ZERO_RETURN [ drop f ] } } check-ssl-error ] keep swap [ 2nip ] [ swap buffer+ f ] if* ; -M: ssl-handle refill ( port handle -- event/f ) +M: ssl-handle refill dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-read ; ! Output ports @@ -284,7 +284,7 @@ M: ssl-handle refill ( port handle -- event/f ) 2dup swap [ buffer@ ] [ buffer-length ] bi SSL_write [ f check-ssl-error ] keep swap [ 2nip ] [ swap buffer-consume f ] if* ; -M: ssl-handle drain ( port handle -- event/f ) +M: ssl-handle drain dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-write ; ! Connect @@ -380,7 +380,7 @@ M: ssl-handle dispose* [ 2drop ] [ subject-name-verify-error ] if ] [ certificate-missing-error ] if* ; -M: openssl check-certificate ( host ssl -- ) +M: openssl check-certificate current-secure-context config>> verify>> [ handle>> [ nip check-verify-result ] @@ -413,7 +413,7 @@ M: openssl send-secure-handshake host>> swap handle>> check-certificate ] [ 2drop ] if ; -M: openssl accept-secure-handshake ( -- ) +M: openssl accept-secure-handshake input/output-ports make-input/output-secure ; diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor index b0f896f722..182e724051 100644 --- a/basis/io/sockets/secure/secure.factor +++ b/basis/io/sockets/secure/secure.factor @@ -66,7 +66,7 @@ M: secure (server) addrspec>> (server) ; CONSULT: inet secure addrspec>> ; -M: secure resolve-host ( secure -- seq ) +M: secure resolve-host [ addrspec>> resolve-host ] [ hostname>> ] bi [ ] curry map ; diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index 28cf6298c0..fe6d8838d2 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -14,14 +14,14 @@ M: ssl-handle handle-fd file>> handle-fd ; M: unix socket-handle fd>> ; -M: secure remote>handle ( secure -- handle ) +M: secure remote>handle [ addrspec>> remote>handle ] [ hostname>> ] bi ; M: secure parse-sockaddr addrspec>> parse-sockaddr f ; M: secure (get-local-address) addrspec>> (get-local-address) ; -M: secure establish-connection ( client-out remote -- ) +M: secure establish-connection addrspec>> [ establish-connection ] [ secure-connection ] 2bi ; M: secure (accept) @@ -52,4 +52,4 @@ M: ssl-handle shutdown f >>connected [ (shutdown) ] with-timeout ] [ drop ] if ; -M: unix non-ssl-socket? ( obj -- ? ) fd? ; +M: unix non-ssl-socket? fd? ; diff --git a/basis/io/sockets/secure/windows/windows.factor b/basis/io/sockets/secure/windows/windows.factor index 815200c11b..16de5da82b 100644 --- a/basis/io/sockets/secure/windows/windows.factor +++ b/basis/io/sockets/secure/windows/windows.factor @@ -57,14 +57,14 @@ M: openssl ssl-certificate-verification-supported? f ; M: windows socket-handle handle>> alien-address ; -M: secure remote>handle ( addrspec -- handle ) +M: secure remote>handle [ addrspec>> remote>handle ] [ hostname>> ] bi ; GENERIC: windows-socket-handle ( obj -- handle ) M: ssl-handle windows-socket-handle file>> ; M: win32-socket windows-socket-handle ; -M: secure (get-local-address) ( handle remote -- sockaddr ) +M: secure (get-local-address) [ windows-socket-handle ] [ addrspec>> ] bi* (get-local-address) ; M: secure parse-sockaddr addrspec>> parse-sockaddr f ; diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index a6ef8984b5..b9b06158dc 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -89,10 +89,10 @@ PRIVATE> : ( host -- ipv4 ) dup check-ipv4 ipv4 boa ; -M: ipv4 inet-ntop ( data addrspec -- str ) +M: ipv4 inet-ntop drop 4 memory>byte-array join-ipv4 ; -M: ipv4 inet-pton ( str addrspec -- data ) +M: ipv4 inet-pton drop [ ?parse-ipv4 ] [ invalid-ipv4 ] recover ; M: ipv4 address-size drop 4 ; @@ -109,17 +109,17 @@ M: ipv4 empty-sockaddr drop sockaddr-in ; swap port>> 0 or htons >>port ; inline -M: ipv4 make-sockaddr ( inet -- sockaddr ) +M: ipv4 make-sockaddr [ make-sockaddr-part ] [ host>> "0.0.0.0" or ] [ inet-pton uint deref >>addr ] tri ; -M: ipv4 make-sockaddr-outgoing ( inet -- sockaddr ) +M: ipv4 make-sockaddr-outgoing [ make-sockaddr-part ] [ host>> dup { f "0.0.0.0" } member? [ drop "127.0.0.1" ] when ] [ inet-pton uint deref >>addr ] tri ; -M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec ) +M: ipv4 parse-sockaddr [ addr>> uint ] dip inet-ntop ; TUPLE: inet4 < ipv4 { port maybe{ integer } read-only } ; @@ -129,7 +129,7 @@ TUPLE: inet4 < ipv4 { port maybe{ integer } read-only } ; M: ipv4 with-port [ host>> ] dip ; -M: inet4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec ) +M: inet4 parse-sockaddr [ call-next-method ] [ drop port>> ntohs ] 2bi with-port ; M: inet4 present @@ -154,7 +154,7 @@ PRIVATE> : ( host -- ipv6 ) dup check-ipv6 0 ipv6 boa ; -M: ipv6 inet-ntop ( data addrspec -- str ) +M: ipv6 inet-ntop drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; -M: ipv6 inet-pton ( str addrspec -- data ) +M: ipv6 inet-pton drop [ parse-ipv6 ipv6-bytes ] [ invalid-ipv6 ] recover ; M: ipv6 address-size drop 16 ; @@ -181,13 +181,13 @@ M: ipv6 empty-sockaddr drop sockaddr-in6 ; swap port>> 0 or htons >>port ; inline -M: ipv6 make-sockaddr ( inet -- sockaddr ) +M: ipv6 make-sockaddr [ make-sockaddr-in6-part ] [ [ host>> "::" or ] keep inet-pton >>addr ] [ scope-id>> >>scopeid ] tri ; -M: ipv6 make-sockaddr-outgoing ( inet -- sockaddr ) +M: ipv6 make-sockaddr-outgoing [ make-sockaddr-in6-part ] [ [ host>> dup { f "::" } member? [ drop "::1" ] when ] keep inet-pton >>addr ] [ scope-id>> >>scopeid ] @@ -247,7 +247,7 @@ GENERIC: (client) ( remote -- client-in client-out local ) M: array (client) [ (client) 3array ] attempt-all first3 ; -M: object (client) ( remote -- client-in client-out local ) +M: object (client) [ [ remote>handle ] keep [ diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor index 9651b7917f..7dbc8f9f6a 100644 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -17,17 +17,17 @@ IN: io.sockets.windows : set-ioctl-socket ( handle cmd arg -- ) [ handle>> ] 2dip ulong ioctlsocket socket-error ; -M: windows addrinfo-error-string ( n -- string ) +M: windows addrinfo-error-string n>win32-error-string ; -M: windows sockaddr-of-family ( alien af -- addrspec ) +M: windows sockaddr-of-family { { AF_INET [ sockaddr-in memory>struct ] } { AF_INET6 [ sockaddr-in6 memory>struct ] } [ 2drop f ] } case ; -M: windows addrspec-of-family ( af -- addrspec ) +M: windows addrspec-of-family { { AF_INET [ T{ ipv4 } ] } { AF_INET6 [ T{ ipv6 } ] } @@ -39,7 +39,7 @@ TUPLE: win32-socket < win32-file ; : ( handle -- win32-socket ) win32-socket new-win32-handle ; -M: win32-socket dispose* ( stream -- ) +M: win32-socket dispose* handle>> closesocket socket-error* ; : unspecific-sockaddr/size ( addrspec -- sockaddr len ) @@ -54,18 +54,18 @@ M: win32-socket dispose* ( stream -- ) dup socket-error opened-socket ; -M: object (get-local-address) ( socket addrspec -- sockaddr ) +M: object (get-local-address) [ handle>> ] dip empty-sockaddr/size int [ getsockname socket-error ] keepd ; -M: object (get-remote-address) ( socket addrspec -- sockaddr ) +M: object (get-remote-address) [ handle>> ] dip empty-sockaddr/size int [ getpeername socket-error ] keepd ; : bind-socket ( win32-socket sockaddr len -- ) [ handle>> ] 2dip bind socket-error ; -M: object remote>handle ( addrspec -- handle ) +M: object remote>handle [ SOCK_STREAM open-socket ] keep [ bind-local-address get @@ -81,19 +81,19 @@ M: object remote>handle ( addrspec -- handle ) ! NOTE: Possibly tweak this because of SYN flood attacks : listen-backlog ( -- n ) 0x7fffffff ; inline -M: object (server) ( addrspec -- handle ) +M: object (server) [ SOCK_STREAM server-socket dup handle>> listen-backlog listen winsock-return-check ] with-destructors ; -M: windows (datagram) ( addrspec -- handle ) +M: windows (datagram) [ SOCK_DGRAM server-socket ] with-destructors ; -M: windows (raw) ( addrspec -- handle ) +M: windows (raw) [ SOCK_RAW server-socket ] with-destructors ; -M: windows (broadcast) ( datagram -- datagram ) +M: windows (broadcast) dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ; : malloc-int ( n -- alien ) @@ -146,7 +146,7 @@ TUPLE: ConnectEx-args port stdcall alien-indirect drop winsock-error ; inline -M: object establish-connection ( client-out remote -- ) +M: object establish-connection make-sockaddr/size-outgoing swap >>port dup port>> handle>> handle>> >>s @@ -203,7 +203,7 @@ TUPLE: AcceptEx-args port ] [ port>> addr>> protocol-family ] bi sockaddr-of-family ; inline -M: object (accept) ( server addr -- handle sockaddr ) +M: object (accept) [ { @@ -265,7 +265,7 @@ TUPLE: WSARecvFrom-args port [ lpFromLen>> int deref ] tri memcpy ; inline -M: windows (receive-unsafe) ( n buf datagram -- count addrspec ) +M: windows (receive-unsafe) [ [ call-WSARecvFrom ] @@ -309,7 +309,7 @@ TUPLE: WSASendTo-args port [ lpCompletionRoutine>> ] } cleave WSASendTo socket-error* ; inline -M: windows (send) ( packet addrspec datagram -- ) +M: windows (send) [ [ call-WSASendTo ] diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index 79438d5bc5..4b2ae2d2e7 100644 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -22,11 +22,11 @@ INSTANCE: limited-stream input-stream GENERIC#: limit-stream 1 ( stream limit -- stream' ) -M: decoder limit-stream ( stream limit -- stream' ) +M: decoder limit-stream '[ stream>> _ limit-stream ] [ code>> ] [ cr>> ] tri decoder boa ; inline -M: object limit-stream ( stream limit -- stream' ) +M: object limit-stream ; : limited-input ( limit -- ) @@ -147,10 +147,10 @@ M: limited-stream stream-element-type GENERIC: unlimit-stream ( stream -- stream' ) -M: decoder unlimit-stream ( stream -- stream' ) +M: decoder unlimit-stream [ stream>> stream>> ] [ code>> ] [ cr>> ] tri decoder boa ; -M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ; +M: limited-stream unlimit-stream stream>> ; : unlimited-input ( -- ) input-stream [ unlimit-stream ] change ; diff --git a/basis/libc/freebsd/freebsd.factor b/basis/libc/freebsd/freebsd.factor index 2a9bc96eab..c98b26f6cd 100644 --- a/basis/libc/freebsd/freebsd.factor +++ b/basis/libc/freebsd/freebsd.factor @@ -39,7 +39,7 @@ CONSTANT: SIGTHR 32 FUNCTION: int strerror_r ( int errno, char* buf, size_t buflen ) -M: freebsd strerror ( errno -- str ) +M: freebsd strerror [ 1024 [ malloc &free ] keep [ strerror_r ] keepd nip alien>native-string diff --git a/basis/libc/linux/linux.factor b/basis/libc/linux/linux.factor index 46fcdb33e5..b390b29594 100644 --- a/basis/libc/linux/linux.factor +++ b/basis/libc/linux/linux.factor @@ -172,7 +172,7 @@ CONSTANT: SIGSYS 31 FUNCTION: c-string strerror_r ( int errno, char* buf, size_t buflen ) -M: linux strerror ( errno -- str ) +M: linux strerror [ 1024 [ malloc &free ] keep strerror_r ] with-destructors ; diff --git a/basis/libc/macosx/macosx.factor b/basis/libc/macosx/macosx.factor index 5221846fa7..ba6dfcf6a0 100644 --- a/basis/libc/macosx/macosx.factor +++ b/basis/libc/macosx/macosx.factor @@ -143,7 +143,7 @@ CONSTANT: SIGUSR2 31 FUNCTION: int strerror_r ( int errno, char* buf, size_t buflen ) -M: macosx strerror ( errno -- str ) +M: macosx strerror [ 1024 [ malloc &free ] keep [ strerror_r ] keepd nip alien>native-string diff --git a/basis/libc/windows/windows.factor b/basis/libc/windows/windows.factor index 449031882d..79dc9653fb 100644 --- a/basis/libc/windows/windows.factor +++ b/basis/libc/windows/windows.factor @@ -108,7 +108,7 @@ LIBRARY: libc FUNCTION: int strerror_s ( char *buffer, size_t numberOfElements, int errnum ) -M: windows strerror ( errno -- str ) +M: windows strerror [ [ 1024 [ malloc &free ] keep ] dip [ strerror_s drop ] keepdd diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor index 66282c58b3..6a80d482b4 100644 --- a/basis/lists/lists.factor +++ b/basis/lists/lists.factor @@ -14,9 +14,9 @@ TUPLE: cons-state { car read-only } { cdr read-only } ; C: cons cons-state -M: cons-state car ( cons -- car ) car>> ; +M: cons-state car car>> ; -M: cons-state cdr ( cons -- cdr ) cdr>> ; +M: cons-state cdr cdr>> ; SINGLETON: +nil+ M: +nil+ nil? drop t ; diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index 9cd29f28d0..fc506ce3d7 100644 --- a/basis/locals/parser/parser.factor +++ b/basis/locals/parser/parser.factor @@ -59,7 +59,7 @@ SINGLETON: lambda-parser : parse-def ( name/paren -- def ) dup "(" = [ drop parse-multi-def ] [ parse-single-def ] if update-locals ; -M: lambda-parser parse-quotation ( -- quotation ) +M: lambda-parser parse-quotation H{ } clone (parse-lambda) ; : parse-let ( -- form ) diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index 812d1b9c92..8ab0f5a213 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -90,5 +90,5 @@ M: object expand-macros* literal ; M: callable expand-macros* expand-macros literal ; -M: callable expand-macros ( quot -- quot' ) +M: callable expand-macros [ begin [ expand-macros* ] each end ] [ ] make ; diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index dac15f6172..526df5578b 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -58,10 +58,10 @@ ERROR: bit-range-error x high low ; GENERIC: (bitfield-quot) ( spec -- quot ) -M: integer (bitfield-quot) ( spec -- quot ) +M: integer (bitfield-quot) '[ _ shift ] ; -M: pair (bitfield-quot) ( spec -- quot ) +M: pair (bitfield-quot) first2-unsafe over word? [ '[ _ execute _ shift ] ] [ diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index a78a565204..4385cdf86d 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -95,24 +95,24 @@ CONSTANT: ppc-rounding-mode>bit CONSTANT: ppc-denormal-mode-bits 0x4 -M: ppc-fpu-env (get-exception-flags) ( register -- exceptions ) +M: ppc-fpu-env (get-exception-flags) fpscr>> ppc-exception-flag>bit mask> ; inline -M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' ) +M: ppc-fpu-env (set-exception-flags) [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpscr ; inline -M: ppc-fpu-env (get-fp-traps) ( register -- exceptions ) +M: ppc-fpu-env (get-fp-traps) fpscr>> ppc-fp-traps>bit mask> ; inline -M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' ) +M: ppc-fpu-env (set-fp-traps) [ ppc-fp-traps>bit >mask ppc-fp-traps-bits remask ] curry change-fpscr ; inline -M: ppc-fpu-env (get-rounding-mode) ( register -- mode ) +M: ppc-fpu-env (get-rounding-mode) fpscr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline -M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' ) +M: ppc-fpu-env (set-rounding-mode) [ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpscr ; inline -M: ppc-fpu-env (get-denormal-mode) ( register -- mode ) +M: ppc-fpu-env (get-denormal-mode) fpscr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline -M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' ) +M: ppc-fpu-env (set-denormal-mode) [ { { +denormal-keep+ [ ppc-denormal-mode-bits unmask ] } @@ -122,24 +122,24 @@ M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' ) CONSTANT: vmx-denormal-mode-bits 0x10000 -M: ppc-vmx-env (get-exception-flags) ( register -- exceptions ) +M: ppc-vmx-env (get-exception-flags) drop { } ; inline -M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' ) +M: ppc-vmx-env (set-exception-flags) drop ; -M: ppc-vmx-env (get-fp-traps) ( register -- exceptions ) +M: ppc-vmx-env (get-fp-traps) drop { } ; inline -M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' ) +M: ppc-vmx-env (set-fp-traps) drop ; -M: ppc-vmx-env (get-rounding-mode) ( register -- mode ) +M: ppc-vmx-env (get-rounding-mode) drop +round-nearest+ ; -M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' ) +M: ppc-vmx-env (set-rounding-mode) drop ; -M: ppc-vmx-env (get-denormal-mode) ( register -- mode ) +M: ppc-vmx-env (get-denormal-mode) vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline -M: ppc-vmx-env (set-denormal-mode) ( register mode -- register ) +M: ppc-vmx-env (set-denormal-mode) [ { { +denormal-keep+ [ vmx-denormal-mode-bits unmask ] } diff --git a/basis/math/floats/env/x86/x86.factor b/basis/math/floats/env/x86/x86.factor index 2659e2bb57..133f6f8785 100644 --- a/basis/math/floats/env/x86/x86.factor +++ b/basis/math/floats/env/x86/x86.factor @@ -63,24 +63,24 @@ CONSTANT: sse-rounding-mode>bit CONSTANT: sse-denormal-mode-bits 0x8040 -M: sse-env (get-exception-flags) ( register -- exceptions ) +M: sse-env (get-exception-flags) mxcsr>> sse-exception-flag>bit mask> ; inline -M: sse-env (set-exception-flags) ( register exceptions -- register' ) +M: sse-env (set-exception-flags) [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline -M: sse-env (get-fp-traps) ( register -- exceptions ) +M: sse-env (get-fp-traps) mxcsr>> bitnot sse-fp-traps>bit mask> ; inline -M: sse-env (set-fp-traps) ( register exceptions -- register' ) +M: sse-env (set-fp-traps) [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline -M: sse-env (get-rounding-mode) ( register -- mode ) +M: sse-env (get-rounding-mode) mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline -M: sse-env (set-rounding-mode) ( register mode -- register' ) +M: sse-env (set-rounding-mode) [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline -M: sse-env (get-denormal-mode) ( register -- mode ) +M: sse-env (get-denormal-mode) mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline -M: sse-env (set-denormal-mode) ( register mode -- register' ) +M: sse-env (set-denormal-mode) [ { { +denormal-keep+ [ sse-denormal-mode-bits unmask ] } @@ -110,24 +110,24 @@ CONSTANT: x87-rounding-mode>bit { +round-zero+ 0x0c00 } } >biassoc ] -M: x87-env (get-exception-flags) ( register -- exceptions ) +M: x87-env (get-exception-flags) status>> x87-exception>bit mask> ; inline -M: x87-env (set-exception-flags) ( register exceptions -- register' ) +M: x87-env (set-exception-flags) drop ; -M: x87-env (get-fp-traps) ( register -- exceptions ) +M: x87-env (get-fp-traps) control>> bitnot x87-exception>bit mask> ; inline -M: x87-env (set-fp-traps) ( register exceptions -- register' ) +M: x87-env (set-fp-traps) [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline -M: x87-env (get-rounding-mode) ( register -- mode ) +M: x87-env (get-rounding-mode) control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline -M: x87-env (set-rounding-mode) ( register mode -- register' ) +M: x87-env (set-rounding-mode) [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline -M: x87-env (get-denormal-mode) ( register -- mode ) +M: x87-env (get-denormal-mode) drop +denormal-keep+ ; inline -M: x87-env (set-denormal-mode) ( register mode -- register' ) +M: x87-env (set-denormal-mode) drop ; cpu { diff --git a/basis/math/functions/integer-logs/integer-logs.factor b/basis/math/functions/integer-logs/integer-logs.factor index 2d31459d35..42803cc10f 100644 --- a/basis/math/functions/integer-logs/integer-logs.factor +++ b/basis/math/functions/integer-logs/integer-logs.factor @@ -79,7 +79,7 @@ ERROR: log-expects-positive x ; GENERIC: (integer-log2) ( x -- n ) foldable -M: integer (integer-log2) ( x -- n ) (log2) ; inline +M: integer (integer-log2) (log2) ; inline : ((ratio-integer-log)) ( ratio quot -- log ) [ >integer ] dip call ; inline @@ -92,9 +92,9 @@ M: integer (integer-log2) ( x -- n ) (log2) ; inline [ 1 + ] unless neg ] if ; inline -M: ratio (integer-log2) ( r -- n ) [ (integer-log2) ] 2 (ratio-integer-log) ; +M: ratio (integer-log2) [ (integer-log2) ] 2 (ratio-integer-log) ; -M: ratio (integer-log10) ( r -- n ) [ (integer-log10) ] 10 (ratio-integer-log) ; +M: ratio (integer-log10) [ (integer-log10) ] 10 (ratio-integer-log) ; : (integer-log) ( x quot -- n ) [ dup 0 > ] dip [ log-expects-positive ] if ; inline diff --git a/basis/math/hashcodes/hashcodes.factor b/basis/math/hashcodes/hashcodes.factor index 9fd454e51e..e0cb48bab1 100644 --- a/basis/math/hashcodes/hashcodes.factor +++ b/basis/math/hashcodes/hashcodes.factor @@ -37,13 +37,13 @@ M: integer number-hashcode 1 hash-fraction ; M: ratio number-hashcode >fraction hash-fraction ; -M: float number-hashcode ( x -- h ) +M: float number-hashcode { { [ dup fp-nan? ] [ drop 0 ] } { [ dup fp-infinity? ] [ 0 > 314159 -314159 ? ] } [ double>ratio number-hashcode ] } cond ; -M: complex number-hashcode ( x -- h ) +M: complex number-hashcode >rect [ number-hashcode ] bi@ 1000003 * + cell-bits on-bits bitand dup -1 = [ drop -2 ] when ; diff --git a/basis/math/quaternions/quaternions.factor b/basis/math/quaternions/quaternions.factor index 69b65d4aae..5ccdf6b863 100644 --- a/basis/math/quaternions/quaternions.factor +++ b/basis/math/quaternions/quaternions.factor @@ -26,7 +26,7 @@ PRIVATE> } 2cleave (q*sign) ; inline GENERIC: qconjugate ( u -- u' ) -M: object qconjugate ( u -- u' ) +M: object qconjugate { 1 -1 -1 -1 } v* ; inline : qrecip ( u -- 1/u ) diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 5511756092..18a6c49aba 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -21,9 +21,9 @@ PRIVATE> [ sign/mod 0 < [ 1 + ] unless 0 max ] keep range boa ; inline -M: range length ( seq -- n ) length>> ; inline +M: range length length>> ; inline -M: range nth-unsafe ( n range -- obj ) +M: range nth-unsafe [ step>> * ] keep from>> + ; inline ! We want M\ tuple hashcode, not M\ sequence hashcode here! diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor index ab925b901a..0d67ad2ea5 100644 --- a/basis/math/vectors/simd/simd.factor +++ b/basis/math/vectors/simd/simd.factor @@ -353,7 +353,7 @@ SIMD-128: double-2 ! misc -M: simd-128 vshuffle ( u perm -- v ) +M: simd-128 vshuffle vshuffle-bytes ; inline M: uchar-16 v*hs+ diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index ac2f443dc7..4dd4581bec 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -131,7 +131,7 @@ M: object vshuffle2-elements GENERIC#: vshuffle-bytes 1 ( v perm -- w ) GENERIC: vshuffle ( v perm -- w ) -M: array vshuffle ( v perm -- w ) +M: array vshuffle vshuffle-elements ; inline GENERIC#: vlshift 1 ( v n -- w ) diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index 90358acbc6..7bf6690cb9 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -26,30 +26,30 @@ ERROR: read-only-slot slot ; [ offset>> ] } cond ; inline -M: mirror set-at ( val key mirror -- ) +M: mirror set-at [ object-slots slot-named check-set-slot ] [ object>> ] bi swap set-slot ; ERROR: mirror-slot-removal slots mirror method ; -M: mirror delete-at ( key mirror -- ) +M: mirror delete-at \ delete-at mirror-slot-removal ; -M: mirror clear-assoc ( mirror -- ) +M: mirror clear-assoc [ object-slots ] keep \ clear-assoc mirror-slot-removal ; M: mirror-slot-removal summary drop "Slots cannot be removed from a tuple or a mirror of it" ; -M: mirror >alist ( mirror -- alist ) +M: mirror >alist [ object-slots ] [ object>> ] bi '[ [ name>> ] [ offset>> _ swap slot ] bi ] { } map>assoc ; -M: mirror keys ( mirror -- keys ) +M: mirror keys object-slots [ name>> ] map ; -M: mirror values ( mirror -- values ) +M: mirror values [ object-slots ] [ object>> ] bi '[ offset>> _ swap slot ] map ; diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index b064ef0690..438b572db1 100644 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -7,10 +7,10 @@ IN: pack GENERIC: >n-byte-array ( obj n -- byte-array ) -M: integer >n-byte-array ( m n -- byte-array ) >endian ; +M: integer >n-byte-array >endian ; ! for doing native, platform-dependent sized values -M: object >n-byte-array ( n string -- byte-array ) heap-size >n-byte-array ; +M: object >n-byte-array heap-size >n-byte-array ; : s8>byte-array ( n -- byte-array ) 1 >n-byte-array ; : u8>byte-array ( n -- byte-array ) 1 >n-byte-array ; diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index bb4d42dc20..3a93551ca4 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -354,10 +354,10 @@ SYMBOL: ignore-ws main set ] with-variables ; -M: ebnf (transform) ( ast -- parser ) +M: ebnf (transform) rules>> [ (transform) ] map last ; -M: ebnf-tokenizer (transform) ( ast -- parser ) +M: ebnf-tokenizer (transform) elements>> dup "default" = [ drop default-tokenizer \ tokenizer set-global any-char ] [ @@ -370,13 +370,13 @@ ERROR: redefined-rule name ; M: redefined-rule summary name>> "Rule '" "' defined more than once" surround ; -M: ebnf-rule (transform) ( ast -- parser ) +M: ebnf-rule (transform) dup elements>> (transform) [ swap symbol>> dup get parser? [ redefined-rule ] [ set ] if ] keep ; -M: ebnf-sequence (transform) ( ast -- parser ) +M: ebnf-sequence (transform) ! If ignore-ws is set then each element of the sequence ! ignores leading whitespace. This is not inherited by ! subelements of the sequence. @@ -385,43 +385,43 @@ M: ebnf-sequence (transform) ( ast -- parser ) ignore-ws get [ sp ] when ] map seq [ dup length 1 = [ first ] when ] action ; -M: ebnf-choice (transform) ( ast -- parser ) +M: ebnf-choice (transform) options>> [ (transform) ] map choice ; -M: ebnf-any-character (transform) ( ast -- parser ) +M: ebnf-any-character (transform) drop tokenizer any>> call( -- parser ) ; -M: ebnf-range (transform) ( ast -- parser ) +M: ebnf-range (transform) pattern>> range-pattern ; : transform-group ( ast -- parser ) ! convert a ast node with groups to a parser for that group group>> (transform) ; -M: ebnf-ensure (transform) ( ast -- parser ) +M: ebnf-ensure (transform) transform-group ensure ; -M: ebnf-ensure-not (transform) ( ast -- parser ) +M: ebnf-ensure-not (transform) transform-group ensure-not ; -M: ebnf-ignore (transform) ( ast -- parser ) +M: ebnf-ignore (transform) transform-group [ drop ignore ] action ; -M: ebnf-repeat0 (transform) ( ast -- parser ) +M: ebnf-repeat0 (transform) transform-group repeat0 ; -M: ebnf-repeat1 (transform) ( ast -- parser ) +M: ebnf-repeat1 (transform) transform-group repeat1 ; -M: ebnf-optional (transform) ( ast -- parser ) +M: ebnf-optional (transform) transform-group optional ; -M: ebnf-whitespace (transform) ( ast -- parser ) +M: ebnf-whitespace (transform) t ignore-ws [ transform-group ] with-variable ; GENERIC: build-locals ( code ast -- code ) -M: ebnf-sequence build-locals ( code ast -- code ) +M: ebnf-sequence build-locals ! Note the need to filter out this ebnf items that ! leave nothing in the AST elements>> filter-hidden dup length 1 = [ @@ -447,7 +447,7 @@ M: ebnf-sequence build-locals ( code ast -- code ) ] if ] if ; -M: ebnf-var build-locals ( code ast -- code ) +M: ebnf-var build-locals [ "[let dup :> " % name>> % " " % @@ -455,7 +455,7 @@ M: ebnf-var build-locals ( code ast -- code ) " nip ]" % ] "" make ; -M: object build-locals ( code ast -- code ) +M: object build-locals drop ; ERROR: bad-effect quot effect ; @@ -481,16 +481,16 @@ ERROR: bad-effect quot effect ; [ string-lines parse-lines ] dip dup 3 + qualified-vocabs delete-slice ; -M: ebnf-action (transform) ( ast -- parser ) +M: ebnf-action (transform) ebnf-transform check-action-effect action ; -M: ebnf-semantic (transform) ( ast -- parser ) +M: ebnf-semantic (transform) ebnf-transform semantic ; -M: ebnf-var (transform) ( ast -- parser ) +M: ebnf-var (transform) parser>> (transform) ; -M: ebnf-terminal (transform) ( ast -- parser ) +M: ebnf-terminal (transform) symbol>> tokenizer one>> call( symbol -- parser ) ; ERROR: ebnf-foreign-not-found name ; @@ -498,7 +498,7 @@ ERROR: ebnf-foreign-not-found name ; M: ebnf-foreign-not-found summary name>> "Foreign word '" "' not found" surround ; -M: ebnf-foreign (transform) ( ast -- parser ) +M: ebnf-foreign (transform) dup word>> search [ word>> ebnf-foreign-not-found ] unless* swap rule>> [ main ] unless* over rule [ nip @@ -508,7 +508,7 @@ M: ebnf-foreign (transform) ( ast -- parser ) ERROR: parser-not-found name ; -M: ebnf-non-terminal (transform) ( ast -- parser ) +M: ebnf-non-terminal (transform) symbol>> [ , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip , diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index c660d20e45..ca4a8654c4 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -14,7 +14,7 @@ CONSTANT: just-pattern [ ] when ] -M: just-parser (compile) ( parser -- quot ) +M: just-parser (compile) p1>> compile-parser-quot just-pattern compose ; : just ( parser -- parser ) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 7470592d88..ca1a795f0a 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -345,7 +345,7 @@ TUPLE: token-parser symbol ; [ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f ] if ; -M: token-parser (compile) ( peg -- quot ) +M: token-parser (compile) symbol>> '[ input-slice _ parse-token ] ; TUPLE: satisfy-parser quot ; diff --git a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor index d623e90019..38e16fe6b4 100644 --- a/basis/persistent/hashtables/nodes/bitmap/bitmap.factor +++ b/basis/persistent/hashtables/nodes/bitmap/bitmap.factor @@ -76,4 +76,4 @@ M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' ) ] if ] if ; -M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ; +M: bitmap-node >alist% nodes>> >alist-each% ; diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 368f7d6d3b..8910e99d3c 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -84,7 +84,7 @@ M: persistent-vector nth-unsafe (ppush-new-tail) do-expansion swap 0 1node >>tail ; -M: persistent-vector ppush ( val pvec -- pvec' ) +M: persistent-vector ppush clone dup tail>> full? [ ppush-new-tail ] [ ppush-tail ] if @@ -106,7 +106,7 @@ M: persistent-vector ppush ( val pvec -- pvec' ) [ (new-nth) ] node-change-nth ] if ; -M: persistent-vector new-nth ( obj i pvec -- pvec' ) +M: persistent-vector new-nth 2dup count>> = [ nip ppush ] [ clone 2dup tail-offset >= [ @@ -159,7 +159,7 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' ) PRIVATE> -M: persistent-vector ppop ( pvec -- pvec' ) +M: persistent-vector ppop dup count>> { { 0 [ empty-error ] } { 1 [ drop T{ persistent-vector } ] } diff --git a/basis/present/present.factor b/basis/present/present.factor index 975973e84d..22f4406a0e 100644 --- a/basis/present/present.factor +++ b/basis/present/present.factor @@ -8,7 +8,7 @@ GENERIC: present ( object -- string ) M: real present number>string ; -M: complex present ( c -- str ) +M: complex present [ real>> number>string ] [ imaginary>> diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index ca91cf7f31..d285ee337a 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -36,7 +36,7 @@ M: anonymous-union word-name* M: anonymous-intersection word-name* class-name "intersection{ " " }" surround ; -M: word word-name* ( word -- str ) +M: word word-name* [ name>> "( no name )" or ] [ record-vocab ] bi ; : pprint-word ( word -- ) @@ -251,7 +251,7 @@ M: vector pprint-narrow? drop t ; M: hashtable pprint-narrow? drop t ; M: tuple pprint-narrow? drop t ; -M: object pprint-object ( obj -- ) +M: object pprint-object [ >overhang ; inline -M: section section-fits? ( section -- ? ) +M: section section-fits? [ end>> 1 - pprinter get last-newline>> - ] [ overhang>> ] bi + text-fits? ; @@ -189,7 +189,7 @@ TUPLE: block < section sections ; : add-line-break ( type -- ) [ add-section ] when* ; -M: block section-fits? ( section -- ? ) +M: block section-fits? line-limit? [ drop t ] [ call-next-method ] if ; : pprint-sections ( block advancer -- ) @@ -199,7 +199,7 @@ M: block section-fits? ( section -- ? ) ] dip [ [ pprint-section ] bi ] curry each ; inline -M: block short-section ( block -- ) +M: block short-section [ advance ] pprint-sections ; : do-break ( break -- ) @@ -262,7 +262,7 @@ TUPLE: flow < block ; : ( -- block ) flow new-block ; -M: flow short-section? ( section -- ? ) +M: flow short-section? ! If we can make room for this entire block by inserting ! a newline, do it; otherwise, don't bother, print it as ! a short section @@ -339,7 +339,7 @@ SYMBOL: next : ?break-group ( seq -- ) dup break-group? [ first > chop-break group-flow [ dup ?break-group [ diff --git a/basis/random/random.factor b/basis/random/random.factor index cbc9e6dc0b..0040ee77fb 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -35,9 +35,9 @@ ERROR: no-random-number-generator ; M: no-random-number-generator summary drop "Random number generator is not defined." ; -M: f random-bytes* ( n obj -- * ) no-random-number-generator ; +M: f random-bytes* no-random-number-generator ; -M: f random-32* ( obj -- * ) no-random-number-generator ; +M: f random-32* no-random-number-generator ; : random-32 ( -- n ) random-generator get random-32* ; @@ -77,8 +77,8 @@ PRIVATE> ] while drop [ m * ] [ neg shift ] bi* ; inline GENERIC#: (random-integer) 1 ( m obj -- n ) -M: fixnum (random-integer) ( m obj -- n ) random-integer-loop ; -M: bignum (random-integer) ( m obj -- n ) random-integer-loop ; +M: fixnum (random-integer) random-integer-loop ; +M: bignum (random-integer) random-integer-loop ; : random-integer ( m -- n ) random-generator get (random-integer) ; diff --git a/basis/random/sfmt/sfmt.factor b/basis/random/sfmt/sfmt.factor index f4a50cde72..46e1e3384b 100644 --- a/basis/random/sfmt/sfmt.factor +++ b/basis/random/sfmt/sfmt.factor @@ -150,10 +150,10 @@ M:: sfmt generate ( sfmt -- ) PRIVATE> -M: sfmt random-32* ( sfmt -- n ) +M: sfmt random-32* dup refill-sfmt? [ dup generate ] when next ; inline -M: sfmt seed-random ( sfmt seed -- sfmt ) +M: sfmt seed-random [ [ state>> ] dip >>seed drop ] [ drop init-sfmt ] 2bi ; diff --git a/basis/random/unix/unix.factor b/basis/random/unix/unix.factor index ffddde9f5b..060d1afe50 100644 --- a/basis/random/unix/unix.factor +++ b/basis/random/unix/unix.factor @@ -12,8 +12,9 @@ TUPLE: unix-random reader ; M: unix-random dispose reader>> dispose ; -M: unix-random random-bytes* ( n tuple -- byte-array ) +M: unix-random random-bytes* reader>> stream-read ; + HINTS: M\ unix-random random-bytes* { fixnum unix-random } ; [ diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index c2acd47ddd..a4611bf1bf 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -6,7 +6,7 @@ IN: random.windows TUPLE: windows-crypto-context < win32-handle provider type ; -M: windows-crypto-context dispose* ( tuple -- ) +M: windows-crypto-context dispose* [ handle>> 0 CryptReleaseContext win32-error=0/f ] [ f >>handle drop ] bi ; @@ -45,7 +45,7 @@ ERROR: acquire-crypto-context-failed provider type error ; swap >>provider initialize-crypto-context ; inline -M: windows-crypto-context random-bytes* ( n windows-crypto-context -- bytes ) +M: windows-crypto-context random-bytes* handle>> swap dup [ CryptGenRandom win32-error=0/f ] keep ; diff --git a/basis/refs/refs.factor b/basis/refs/refs.factor index c1119604ea..cf6b0b6d2c 100644 --- a/basis/refs/refs.factor +++ b/basis/refs/refs.factor @@ -60,7 +60,7 @@ INSTANCE: box ref TUPLE: assoc-ref assoc key ; : >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline -M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ; +M: assoc-ref delete-ref >assoc-ref< delete-at ; TUPLE: key-ref < assoc-ref ; C: key-ref diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index eb57112a38..c3ff7410f0 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -32,53 +32,53 @@ C: script-class GENERIC: class-member? ( obj class -- ? ) -M: t class-member? ( obj class -- ? ) 2drop t ; inline +M: t class-member? 2drop t ; inline -M: integer class-member? ( obj class -- ? ) = ; inline +M: integer class-member? = ; inline -M: range-class class-member? ( obj class -- ? ) +M: range-class class-member? [ from>> ] [ to>> ] bi between? ; inline -M: letter-class class-member? ( obj class -- ? ) +M: letter-class class-member? drop letter? ; inline -M: LETTER-class class-member? ( obj class -- ? ) +M: LETTER-class class-member? drop LETTER? ; inline -M: Letter-class class-member? ( obj class -- ? ) +M: Letter-class class-member? drop Letter? ; inline -M: ascii-class class-member? ( obj class -- ? ) +M: ascii-class class-member? drop ascii? ; inline -M: digit-class class-member? ( obj class -- ? ) +M: digit-class class-member? drop digit? ; inline : c-identifier-char? ( ch -- ? ) { [ alpha? ] [ CHAR: _ = ] } 1|| ; -M: c-identifier-class class-member? ( obj class -- ? ) +M: c-identifier-class class-member? drop c-identifier-char? ; inline -M: alpha-class class-member? ( obj class -- ? ) +M: alpha-class class-member? drop alpha? ; inline : punct? ( ch -- ? ) "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ; -M: punctuation-class class-member? ( obj class -- ? ) +M: punctuation-class class-member? drop punct? ; inline : java-printable? ( ch -- ? ) { [ alpha? ] [ punct? ] } 1|| ; -M: java-printable-class class-member? ( obj class -- ? ) +M: java-printable-class class-member? drop java-printable? ; inline -M: non-newline-blank-class class-member? ( obj class -- ? ) +M: non-newline-blank-class class-member? drop { [ blank? ] [ CHAR: \n = not ] } 1&& ; inline -M: control-character-class class-member? ( obj class -- ? ) +M: control-character-class class-member? drop control? ; inline : hex-digit? ( ch -- ? ) @@ -88,7 +88,7 @@ M: control-character-class class-member? ( obj class -- ? ) [ CHAR: 0 CHAR: 9 between? ] } 1|| ; -M: hex-digit-class class-member? ( obj class -- ? ) +M: hex-digit-class class-member? drop hex-digit? ; inline : java-blank? ( ch -- ? ) @@ -97,13 +97,13 @@ M: hex-digit-class class-member? ( obj class -- ? ) CHAR: \v CHAR: \a CHAR: \r } member? ; -M: java-blank-class class-member? ( obj class -- ? ) +M: java-blank-class class-member? drop java-blank? ; inline -M: unmatchable-class class-member? ( obj class -- ? ) +M: unmatchable-class class-member? 2drop f ; inline -M: terminator-class class-member? ( obj class -- ? ) +M: terminator-class class-member? drop "\r\n\u000085\u002029\u002028" member? ; inline M: f class-member? 2drop f ; inline diff --git a/basis/regexp/negation/negation.factor b/basis/regexp/negation/negation.factor index 85b7741a52..1b82b3633a 100644 --- a/basis/regexp/negation/negation.factor +++ b/basis/regexp/negation/negation.factor @@ -52,5 +52,5 @@ CONSTANT: fail-state -1 : ast>dfa ( parse-tree -- minimal-dfa ) ast>nfa construct-dfa minimize ; -M: negation nfa-node ( node -- start end ) +M: negation nfa-node term>> ast>dfa negate-table adjoin-dfa ; diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index 5cac3c229d..2cc276d756 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -72,7 +72,7 @@ M: ^ modify-epsilon M: tagged-epsilon nfa-node clone [ modify-epsilon ] change-tag add-simple-entry ; -M: concatenation nfa-node ( node -- start end ) +M: concatenation nfa-node [ first>> ] [ second>> ] bi reversed-regexp option? [ swap ] when [ nfa-node ] bi@ @@ -87,7 +87,7 @@ M: concatenation nfa-node ( node -- start end ) s3 s5 epsilon-transition s4 s5 ; -M: alternation nfa-node ( node -- start end ) +M: alternation nfa-node [ first>> ] [ second>> ] bi [ nfa-node ] bi@ alternate-nodes ; @@ -103,7 +103,7 @@ M: integer modify-class ] when ] when ; -M: integer nfa-node ( node -- start end ) +M: integer nfa-node modify-class add-simple-entry ; M: primitive-class modify-class @@ -151,7 +151,7 @@ M: range-class modify-class M: object nfa-node modify-class add-simple-entry ; -M: with-options nfa-node ( node -- start end ) +M: with-options nfa-node dup options>> [ tree>> nfa-node ] using-options ; : construct-nfa ( ast -- nfa-table ) diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index c31571c718..1e7bbab962 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -16,13 +16,15 @@ TUPLE: reverse-regexp < regexp ; quot ! Returns ( index string -- ? ) +M: lookahead question>quot + ! Returns ( index string -- ? ) term>> ast>dfa dfa>shortest-word '[ f _ execute ] ; : ( ast -- reversed ) "r" string>options ; -M: lookbehind question>quot ! Returns ( index string -- ? ) +M: lookbehind question>quot + ! Returns ( index string -- ? ) term>> ast>dfa dfa>reverse-shortest-word '[ [ 1 - ] dip f _ execute ] ; @@ -156,13 +158,13 @@ GENERIC: compile-regexp ( regex -- regexp ) : regexp-initial-word ( i string regexp -- i/f ) [ compile-regexp ] with-compilation-unit match-index-from ; -M: regexp compile-regexp ( regexp -- regexp ) +M: regexp compile-regexp dup '[ dup \ regexp-initial-word = [ drop _ get-ast ast>dfa dfa>word ] when ] change-dfa ; -M: reverse-regexp compile-regexp ( regexp -- regexp ) +M: reverse-regexp compile-regexp t backwards? [ call-next-method ] with-variable ; DEFER: compile-next-match diff --git a/basis/see/see.factor b/basis/see/see.factor index a88b858432..b07dfb3e81 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -165,7 +165,7 @@ M: predicate-class see-class* "predicate-definition" word-prop pprint-elements pprint-; block> block> ; -M: singleton-class see-class* ( class -- ) +M: singleton-class see-class* \ SINGLETON: pprint-word pprint-word ; GENERIC: pprint-slot-name ( object -- ) diff --git a/basis/sequences/merged/merged.factor b/basis/sequences/merged/merged.factor index 233683c47a..55c3e305c1 100644 --- a/basis/sequences/merged/merged.factor +++ b/basis/sequences/merged/merged.factor @@ -22,10 +22,10 @@ C: merged M: merged length seqs>> [ [ length ] [ min ] map-reduce ] [ length ] bi * ; inline -M: merged virtual@ ( n seq -- n' seq' ) +M: merged virtual@ seqs>> [ length /mod ] [ nth-unsafe ] bi ; inline -M: merged virtual-exemplar ( merged -- seq ) +M: merged virtual-exemplar seqs>> ?first ; inline INSTANCE: merged virtual-sequence diff --git a/basis/serialize/serialize.factor b/basis/serialize/serialize.factor index 0d0c34431a..2e5e33d137 100644 --- a/basis/serialize/serialize.factor +++ b/basis/serialize/serialize.factor @@ -65,10 +65,10 @@ SYMBOL: serialized [ CHAR: o write1 serialize-cell drop ] ] dip if* ; inline -M: f (serialize) ( obj -- ) +M: f (serialize) drop CHAR: n write1 ; -M: integer (serialize) ( obj -- ) +M: integer (serialize) [ CHAR: z write1 ] [ @@ -76,7 +76,7 @@ M: integer (serialize) ( obj -- ) serialize-cell ] if-zero ; -M: float (serialize) ( obj -- ) +M: float (serialize) CHAR: F write1 double>bits serialize-cell ; @@ -88,7 +88,7 @@ M: float (serialize) ( obj -- ) [ [ (serialize) ] each ] tri ] curry serialize-shared ; -M: tuple (serialize) ( obj -- ) +M: tuple (serialize) [ CHAR: T write1 [ class-of (serialize) ] @@ -97,22 +97,22 @@ M: tuple (serialize) ( obj -- ) tri ] serialize-shared ; -M: array (serialize) ( obj -- ) +M: array (serialize) CHAR: a serialize-seq ; -M: quotation (serialize) ( obj -- ) +M: quotation (serialize) [ CHAR: q write1 [ >array (serialize) ] [ add-object ] bi ] serialize-shared ; -M: hashtable (serialize) ( obj -- ) +M: hashtable (serialize) [ CHAR: h write1 [ add-object ] [ >alist (serialize) ] bi ] serialize-shared ; -M: byte-array (serialize) ( obj -- ) +M: byte-array (serialize) [ CHAR: A write1 [ add-object ] @@ -120,7 +120,7 @@ M: byte-array (serialize) ( obj -- ) [ write ] tri ] serialize-shared ; -M: string (serialize) ( obj -- ) +M: string (serialize) [ CHAR: s write1 [ add-object ] @@ -149,14 +149,14 @@ M: string (serialize) ( obj -- ) [ vocabulary>> (serialize) ] bi ; -M: word (serialize) ( obj -- ) +M: word (serialize) { { [ dup t eq? ] [ serialize-true ] } { [ dup vocabulary>> not ] [ serialize-gensym ] } [ serialize-word ] } cond ; -M: wrapper (serialize) ( obj -- ) +M: wrapper (serialize) CHAR: W write1 wrapped>> (serialize) ; diff --git a/basis/system-info/macosx/macosx.factor b/basis/system-info/macosx/macosx.factor index 7f6b5e9aaa..ab8cf8e942 100644 --- a/basis/system-info/macosx/macosx.factor +++ b/basis/system-info/macosx/macosx.factor @@ -75,11 +75,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi : machine ( -- str ) { 6 1 } sysctl-query-string ; : model ( -- str ) { 6 2 } sysctl-query-string ; -M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ; +M: macosx cpus { 6 3 } sysctl-query-uint ; : byte-order ( -- n ) { 6 4 } sysctl-query-uint ; ! Only an int, not large enough. Deprecated. -! M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-int ; +! M: macosx physical-mem { 6 5 } sysctl-query-int ; ! : user-mem ( -- n ) { 6 6 } sysctl-query-uint ; : page-size ( -- n ) { 6 7 } sysctl-query-uint ; @@ -90,7 +90,7 @@ M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ; : machine-arch ( -- n ) { 6 12 } sysctl-query-string ; : vector-unit ( -- n ) { 6 13 } sysctl-query-uint ; : bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ; -M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ; +M: macosx cpu-mhz { 6 15 } sysctl-query-uint ; : cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ; : l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ; : l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ; @@ -99,7 +99,7 @@ M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ; : l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ; : l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ; : tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ; -M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ; +M: macosx physical-mem { 6 24 } sysctl-query-ulonglong ; : available-cpus ( -- n ) { 6 25 } sysctl-query-uint ; M: macosx computer-name { 1 10 } sysctl-query-string "." split1 drop ; diff --git a/basis/system-info/windows/windows.factor b/basis/system-info/windows/windows.factor index 1e7bc07d69..2c719fb4d9 100644 --- a/basis/system-info/windows/windows.factor +++ b/basis/system-info/windows/windows.factor @@ -33,7 +33,7 @@ IN: system-info.windows : windows-minor ( -- n ) os-version-struct dwMinorVersion>> ; -M: windows os-version ( -- obj ) +M: windows os-version os-version-struct [ dwMajorVersion>> ] [ dwMinorVersion>> ] bi 2array ; : windows-build# ( -- n ) @@ -67,7 +67,7 @@ M: windows os-version ( -- obj ) : system-windows-directory ( -- str ) \ GetSystemWindowsDirectory get-directory ; -M: windows cpus ( -- n ) +M: windows cpus system-info dwNumberOfProcessors>> ; : memory-status ( -- MEMORYSTATUSEX ) @@ -75,28 +75,28 @@ M: windows cpus ( -- n ) MEMORYSTATUSEX heap-size >>dwLength dup GlobalMemoryStatusEx win32-error=0/f ; -M: windows memory-load ( -- n ) +M: windows memory-load memory-status dwMemoryLoad>> ; -M: windows physical-mem ( -- n ) +M: windows physical-mem memory-status ullTotalPhys>> ; -M: windows available-mem ( -- n ) +M: windows available-mem memory-status ullAvailPhys>> ; -M: windows total-page-file ( -- n ) +M: windows total-page-file memory-status ullTotalPageFile>> ; -M: windows available-page-file ( -- n ) +M: windows available-page-file memory-status ullAvailPageFile>> ; -M: windows total-virtual-mem ( -- n ) +M: windows total-virtual-mem memory-status ullTotalVirtual>> ; -M: windows available-virtual-mem ( -- n ) +M: windows available-virtual-mem memory-status ullAvailVirtual>> ; -M: windows computer-name ( -- string ) +M: windows computer-name MAX_COMPUTERNAME_LENGTH 1 + [ dup ] keep uint GetComputerName win32-error=0/f alien>native-string ; diff --git a/basis/tools/coverage/coverage.factor b/basis/tools/coverage/coverage.factor index bfcabbc98c..d0352f4d29 100644 --- a/basis/tools/coverage/coverage.factor +++ b/basis/tools/coverage/coverage.factor @@ -84,7 +84,7 @@ GENERIC: coverage ( object -- seq ) M: string coverage [ dup coverage 2array ] map-words ; -M: word coverage ( word -- seq ) +M: word coverage "coverage" word-prop [ drop executed?>> ] assoc-reject values ; diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index d148c80e8d..d6cbb9ed79 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -39,7 +39,7 @@ M: callable quot-uses seq-uses ; M: wrapper quot-uses [ wrapped>> ] dip quot-uses ; -M: callable uses ( quot -- seq ) +M: callable uses IHS{ } clone visited [ HS{ } clone [ quot-uses ] keep members ] with-variable ; diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 9b091136a9..1c28c983b6 100644 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -85,7 +85,7 @@ SINGLETON: udis-disassembler ] loop ] { } make ; -M: udis-disassembler disassemble* ( from to -- buffer ) +M: udis-disassembler disassemble* '[ _ _ [ drop ud_set_pc ] diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 574dc7d647..262d598b52 100644 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -58,7 +58,7 @@ ERROR: unknown-file-spec symbol ; HOOK: file-spec>string os ( file-listing spec -- string ) -M: object file-spec>string ( file-listing spec -- string ) +M: object file-spec>string { { +file-name+ [ directory-entry>> name>> ] } { +directory-or-size+ [ file-info>> dir-or-size ] } diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor index 642ee164cc..fdc55c864d 100644 --- a/basis/tools/files/unix/unix.factor +++ b/basis/tools/files/unix/unix.factor @@ -45,7 +45,7 @@ IN: tools.files.unix [ drop "" ] } cond ; -M: unix (directory.) ( path -- lines ) +M: unix (directory.) { +permissions+ +nlinks+ +user+ +group+ @@ -54,7 +54,7 @@ M: unix (directory.) ( path -- lines ) { { directory-entry>> name>> <=> } } >>sort [ [ list-files ] with-group-cache ] with-user-cache ; -M: unix file-spec>string ( file-listing spec -- string ) +M: unix file-spec>string { { +file-name/type+ [ directory-entry>> [ name>> ] [ file-type>trailing ] bi append diff --git a/basis/tools/files/windows/windows.factor b/basis/tools/files/windows/windows.factor index 874b2ef5c1..ca6d9c218c 100644 --- a/basis/tools/files/windows/windows.factor +++ b/basis/tools/files/windows/windows.factor @@ -7,7 +7,7 @@ IN: tools.files.windows { +file-datetime+ +directory-or-size+ +file-name+ } >>specs { { directory-entry>> name>> <=> } } >>sort diff --git a/basis/tools/ps/linux/linux.factor b/basis/tools/ps/linux/linux.factor index 0a6d201f87..56cc146379 100644 --- a/basis/tools/ps/linux/linux.factor +++ b/basis/tools/ps/linux/linux.factor @@ -17,7 +17,7 @@ IN: tools.ps.linux : safe-ps-cmdline ( path -- string/f ) [ ps-cmdline ] [ 2drop f ] recover ; -M: linux ps ( -- assoc ) +M: linux ps "/proc" [ "." directory-files [ string>number ] filter [ dup safe-ps-cmdline 2array ] map sift-values diff --git a/basis/tools/ps/macosx/macosx.factor b/basis/tools/ps/macosx/macosx.factor index e2bd4e2912..a7e9d42387 100644 --- a/basis/tools/ps/macosx/macosx.factor +++ b/basis/tools/ps/macosx/macosx.factor @@ -145,6 +145,6 @@ STRUCT: kinfo_proc PRIVATE> -M: macosx ps ( -- assoc ) +M: macosx ps procs [ kp_proc>> p_pid>> 0 > ] filter [ kp_proc>> [ p_pid>> ] [ ps-arg ] bi ] { } map>assoc ; diff --git a/basis/tools/ps/windows/windows.factor b/basis/tools/ps/windows/windows.factor index b1a3004ff1..470318edcb 100644 --- a/basis/tools/ps/windows/windows.factor +++ b/basis/tools/ps/windows/windows.factor @@ -95,4 +95,4 @@ IN: tools.ps.windows ] map sift ] with-destructors ; -M: windows ps ( -- assoc ) process-list ; +M: windows ps process-list ; diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index b264dcf44a..214bfeb7c7 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -142,7 +142,7 @@ M: array add-using [ add-using ] each ; M: string add-using drop ; -M: object add-using ( object -- ) +M: object add-using vocabulary>> using get [ adjoin ] [ drop ] if* ; : ($values.) ( array -- ) @@ -378,4 +378,4 @@ ${example-indent}} HOOK: scaffold-emacs os ( -- ) -M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ; +M: unix scaffold-emacs ".emacs" scaffold-rc ; diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 9c2d5ca76c..114d8ebab7 100644 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -82,7 +82,7 @@ M: pasteboard set-clipboard-contents ] if ] [ first2 -> setFrameTopLeftPoint: ] if ; -M: cocoa-ui-backend set-title ( string world -- ) +M: cocoa-ui-backend set-title handle>> window>> swap -> setTitle: ; : enter-fullscreen ( world -- ) @@ -96,10 +96,10 @@ M: cocoa-ui-backend set-title ( string world -- ) [ view>> f -> exitFullScreenModeWithOptions: ] [ [ window>> ] [ view>> ] bi -> makeFirstResponder: drop ] bi ; -M: cocoa-ui-backend (set-fullscreen) ( world ? -- ) +M: cocoa-ui-backend (set-fullscreen) [ enter-fullscreen ] [ exit-fullscreen ] if ; -M: cocoa-ui-backend (fullscreen?) ( world -- ? ) +M: cocoa-ui-backend (fullscreen?) handle>> view>> -> isInFullScreenMode zero? not ; ! XXX: Until someone tests OSX with a tiling window manager, @@ -138,14 +138,14 @@ M:: cocoa-ui-backend (open-window) ( world -- ) window f -> makeKeyAndOrderFront: t world active?<< ; -M: cocoa-ui-backend (close-window) ( handle -- ) +M: cocoa-ui-backend (close-window) [ view>> dup -> isInFullScreenMode zero? [ drop ] [ f -> exitFullScreenModeWithOptions: ] if ] [ window>> -> release ] bi ; -M: cocoa-ui-backend (grab-input) ( handle -- ) +M: cocoa-ui-backend (grab-input) 0 CGAssociateMouseAndMouseCursorPosition drop CGMainDisplayID CGDisplayHideCursor drop window>> -> frame CGRect>rect rect-center @@ -154,31 +154,31 @@ M: cocoa-ui-backend (grab-input) ( handle -- ) [ GetCurrentButtonState zero? not ] [ yield ] while CGWarpMouseCursorPosition drop ; -M: cocoa-ui-backend (ungrab-input) ( handle -- ) +M: cocoa-ui-backend (ungrab-input) drop CGMainDisplayID CGDisplayShowCursor drop 1 CGAssociateMouseAndMouseCursorPosition drop ; -M: cocoa-ui-backend close-window ( gadget -- ) +M: cocoa-ui-backend close-window find-world [ handle>> [ window>> -> close ] when* ] when* ; -M: cocoa-ui-backend raise-window* ( world -- ) +M: cocoa-ui-backend raise-window* handle>> [ window>> dup f -> orderFront: -> makeKeyWindow NSApp 1 -> activateIgnoringOtherApps: ] when* ; -M: window-handle select-gl-context ( handle -- ) +M: window-handle select-gl-context view>> -> openGLContext -> makeCurrentContext ; -M: window-handle flush-gl-context ( handle -- ) +M: window-handle flush-gl-context view>> -> openGLContext -> flushBuffer ; -M: cocoa-ui-backend beep ( -- ) +M: cocoa-ui-backend beep NSBeep ; M: cocoa-ui-backend resize-window diff --git a/basis/ui/backend/gtk/gtk.factor b/basis/ui/backend/gtk/gtk.factor index ea6e668758..128ac48b89 100644 --- a/basis/ui/backend/gtk/gtk.factor +++ b/basis/ui/backend/gtk/gtk.factor @@ -391,12 +391,12 @@ M: gtk-ui-backend (make-pixel-format) M: gtk-ui-backend (free-pixel-format) handle>> g_object_unref ; -M: window-handle select-gl-context ( handle -- ) +M: window-handle select-gl-context drawable>> [ gtk_widget_get_gl_window ] [ gtk_widget_get_gl_context ] bi gdk_gl_drawable_make_current drop ; -M: window-handle flush-gl-context ( handle -- ) +M: window-handle flush-gl-context drawable>> gtk_widget_get_gl_window gdk_gl_drawable_swap_buffers ; @@ -448,7 +448,7 @@ M:: gtk-ui-backend (open-window) ( world -- ) win world window-controls>> configure-window-controls win gtk_widget_show_all ; -M: gtk-ui-backend (close-window) ( handle -- ) +M: gtk-ui-backend (close-window) window>> [ gtk_widget_destroy ] [ unregister-window ] bi event-loop? [ gtk_main_quit ] unless ; diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 7c63f37a7f..8165898bc1 100644 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -196,7 +196,7 @@ M: world selection-request-event [ drop send-notify-failure ] } cond ; -M: x11-ui-backend (close-window) ( handle -- ) +M: x11-ui-backend (close-window) [ xic>> XDestroyIC ] [ glx>> destroy-glx ] [ window>> [ unregister-window ] [ destroy-window ] bi ] @@ -249,7 +249,7 @@ M: x-clipboard paste-clipboard XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor" utf8 encode dup length XChangeProperty drop ; -M: x11-ui-backend set-title ( string world -- ) +M: x11-ui-backend set-title handle>> window>> swap [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ; @@ -271,14 +271,14 @@ M: x11-ui-backend set-title ( string world -- ) flags{ SubstructureNotifyMask SubstructureRedirectMask } ] dip XSendEvent drop ; -M: x11-ui-backend (set-fullscreen) ( world ? -- ) +M: x11-ui-backend (set-fullscreen) [ handle>> window>> ] dip make-fullscreen-msg send-event ; -M: x11-ui-backend (fullscreen?) ( world -- ? ) +M: x11-ui-backend (fullscreen?) handle>> window>> XA_NET_WM_STATE get-atom-properties XA_NET_WM_STATE_FULLSCREEN swap member? ; -M: x11-ui-backend (open-window) ( world -- ) +M: x11-ui-backend (open-window) dup gadget-window handle>> window>> [ set-closable ] [ [ dpy get ] dip set-class ] @@ -303,22 +303,22 @@ M: x11-ui-backend (open-window) ( world -- ) [ XRaiseWindow drop ] 2bi ; -M: x11-ui-backend raise-window* ( world -- ) +M: x11-ui-backend raise-window* handle>> [ window>> XA_NET_ACTIVE_WINDOW net-wm-hint-supported? [ raise-window-new ] [ raise-window-old ] if ] when* ; -M: x11-handle select-gl-context ( handle -- ) +M: x11-handle select-gl-context dpy get swap [ window>> ] [ glx>> ] bi glXMakeCurrent [ "Failed to set current GLX context" throw ] unless ; -M: x11-handle flush-gl-context ( handle -- ) +M: x11-handle flush-gl-context dpy get swap window>> glXSwapBuffers ; -M: x11-ui-backend (with-ui) ( quot -- ) +M: x11-ui-backend (with-ui) f [ [ init-clipboard @@ -327,7 +327,7 @@ M: x11-ui-backend (with-ui) ( quot -- ) ] with-xim ] with-x ; -M: x11-ui-backend beep ( -- ) +M: x11-ui-backend beep dpy get 100 XBell drop ; > "com-" ?head drop "." ?tail drop dup first Letter? [ rest ] unless (command-name) ; -M: word command-description ( word -- str ) +M: word command-description +description+ word-prop ; : default-flags ( -- assoc ) @@ -102,9 +102,9 @@ M: word command-description ( word -- str ) [ 1quotation ] [ +nullary+ word-prop ] bi [ nip ] [ curry ] if ; -M: word invoke-command ( target command -- ) +M: word invoke-command command-quot call( -- ) ; M: word command-word ; -M: f invoke-command ( target command -- ) 2drop ; +M: f invoke-command 2drop ; diff --git a/basis/ui/gadgets/books/books.factor b/basis/ui/gadgets/books/books.factor index ca9aa2d2d2..9d101316a0 100644 --- a/basis/ui/gadgets/books/books.factor +++ b/basis/ui/gadgets/books/books.factor @@ -10,7 +10,7 @@ TUPLE: book < gadget ; : current-page ( book -- gadget ) [ control-value ] keep nth-gadget ; -M: book model-changed ( model book -- ) +M: book model-changed nip dup hide-all dup current-page show-gadget @@ -26,9 +26,9 @@ M: book model-changed ( model book -- ) : ( model -- book ) book new-book ; -M: book pref-dim* ( book -- dim ) children>> pref-dims max-dims ; +M: book pref-dim* children>> pref-dims max-dims ; -M: book layout* ( book -- ) +M: book layout* [ children>> ] [ dim>> ] bi '[ _ >>dim drop ] each ; -M: book focusable-child* ( book -- child/t ) current-page ; +M: book focusable-child* current-page ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 6906257453..c045a91aed 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -234,7 +234,7 @@ TUPLE: selected-line start end first? last? ; PRIVATE> -M: editor draw-line ( line index editor -- ) +M: editor draw-line [ selected-lines get at ] dip over [ draw-selected-line ] [ nip draw-unselected-line ] if ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 2a81f56718..e06ab08c91 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -79,10 +79,10 @@ PRIVATE> rect rect-bounds v+ axis children quot (fast-children-on) ?1+ children ; inline -M: gadget contains-rect? ( bounds gadget -- ? ) +M: gadget contains-rect? dup visible?>> [ call-next-method ] [ 2drop f ] if ; -M: gadget contains-point? ( loc gadget -- ? ) +M: gadget contains-point? dup visible?>> [ call-next-method ] [ 2drop f ] if ; : pick-up ( point gadget -- child/f ) @@ -182,7 +182,7 @@ M: gadget dim-changed PRIVATE> -M: gadget dim<< ( dim gadget -- ) +M: gadget dim<< 2dup dim>> = [ 2drop ] [ [ nip ] [ call-next-method ] 2bi dim-changed ] if ; diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor index 73dc62267c..58ae904a1e 100644 --- a/basis/ui/gadgets/grids/grids.factor +++ b/basis/ui/gadgets/grids/grids.factor @@ -113,7 +113,7 @@ M: grid pref-dim* grid-pref-dim ; M: grid layout* [ grid>> ] [ ] bi layout-grid ; -M: grid children-on ( rect gadget -- seq ) +M: grid children-on dup children>> empty? [ 2drop f ] [ [ { 0 1 } ] dip [ grid>> ] [ dim>> ] bi diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor index b3e6248ce4..d4a0cd03e4 100644 --- a/basis/ui/gadgets/labels/labels.factor +++ b/basis/ui/gadgets/labels/labels.factor @@ -12,7 +12,7 @@ TUPLE: label < aligned-gadget text font ; SLOT: string -M: label string>> ( label -- string ) +M: label string>> text>> dup string? [ "\n" join ] unless ; inline : ?string-lines ( string -- string/array ) CHAR: \n over member-eq? [ string-lines ] when ; -M: label string<< ( string label -- ) +M: label string<< [ dup string-array? [ string check-instance ?string-lines diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor index 9e7b8eb4f2..cc5281c9db 100644 --- a/basis/ui/gadgets/packs/packs.factor +++ b/basis/ui/gadgets/packs/packs.factor @@ -96,5 +96,5 @@ M: pack cap-height* pack-cap-height ; M: pack layout* dup children>> pref-dims pack-layout ; -M: pack children-on ( rect gadget -- seq ) +M: pack children-on [ orientation>> ] [ children>> ] bi [ loc>> ] fast-children-on ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index fce19fa098..139d516efc 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -201,7 +201,7 @@ M: pane-stream write-gadget TUPLE: pane-control < pane quot ; -M: pane-control model-changed ( model pane-control -- ) +M: pane-control model-changed [ value>> ] [ dup quot>> ] bi* '[ _ call( value -- ) ] with-pane ; @@ -364,7 +364,7 @@ M: paragraph pane-line GENERIC: sloppy-pick-up* ( loc gadget -- n ) -M: pack sloppy-pick-up* ( loc gadget -- n ) +M: pack sloppy-pick-up* [ orientation>> ] [ children>> ] bi [ loc>> ] (fast-children-on) ; diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 32cf0fd1eb..db685b64e4 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -216,7 +216,7 @@ M: table draw-gadget* ] with-variable ] if ; -M: table line-height* ( table -- y ) +M: table line-height* [ font>> ] [ renderer>> prototype-row ] bi [ cell-dim + nip ] with [ max ] map-reduce ; diff --git a/basis/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor index 11ff0fb51d..0b13311723 100644 --- a/basis/ui/gadgets/tracks/tracks.factor +++ b/basis/ui/gadgets/tracks/tracks.factor @@ -35,7 +35,7 @@ TUPLE: track < pack sizes ; } cleave '[ [ _ n*v _ set-axis ] when* ] 2map ; -M: track layout* ( track -- ) dup track-layout pack-layout ; +M: track layout* dup track-layout pack-layout ; : track-pref-dims-1 ( track -- dim ) [ children>> pref-dims max-dims ] @@ -48,7 +48,7 @@ M: track layout* ( track -- ) dup track-layout pack-layout ; max-dims ] [ gap-dim ] bi v+ ; -M: track pref-dim* ( gadget -- dim ) +M: track pref-dim* [ track-pref-dims-1 ] [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ] [ orientation>> ] diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index abfab5ce48..8e8a702e02 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -112,7 +112,7 @@ ERROR: no-world-found ; [ (request-focus) ] keep ] unless focus-child ; -M: world request-focus-on ( child gadget -- ) +M: world request-focus-on 2dup eq? [ 2drop ] [ dup focused?>> (request-focus) ] if ; @@ -248,7 +248,7 @@ PREDICATE: specific-drag < drag #>> ; : generalize-gesture ( gesture -- ) clone f >># button-gesture ; -M: world handle-gesture ( gesture gadget -- ? ) +M: world handle-gesture 2dup call-next-method [ { { [ over specific-button-up? ] [ drop generalize-gesture f ] } diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 64f0fb2ab2..bcb56c5cb0 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -18,7 +18,7 @@ M: object handle-gesture GENERIC: handles-gesture? ( gesture gadget -- ? ) -M: object handles-gesture? ( gesture gadget -- ? ) +M: object handles-gesture? get-gesture-handler >boolean ; : parents-handle-gesture? ( gesture gadget -- ? ) diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor index a441ca9273..7eb5a65a24 100644 --- a/basis/ui/operations/operations.factor +++ b/basis/ui/operations/operations.factor @@ -91,5 +91,5 @@ operations [ ] initialize : operation-quot ( target operation -- quot ) [ translator>> ] [ command>> ] bi '[ _ @ _ execute ] ; -M: operation invoke-command ( target command -- ) +M: operation invoke-command operation-quot call( -- ) ; diff --git a/basis/ui/pens/gradient/gradient.factor b/basis/ui/pens/gradient/gradient.factor index aa91644895..58c72f7505 100644 --- a/basis/ui/pens/gradient/gradient.factor +++ b/basis/ui/pens/gradient/gradient.factor @@ -24,7 +24,7 @@ TUPLE: gradient < caching-pen colors last-vertices last-colors ; [ >rgba-components 4array dup 2array ] map concat concat float >c-array ; -M: gradient recompute-pen ( gadget gradient -- ) +M: gradient recompute-pen [ nip ] [ [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi* ] 2bi [ gradient-vertices >>last-vertices ] [ gradient-colors >>last-colors ] diff --git a/basis/ui/pens/tile/tile.factor b/basis/ui/pens/tile/tile.factor index 72f9c44421..e2ee3dd066 100644 --- a/basis/ui/pens/tile/tile.factor +++ b/basis/ui/pens/tile/tile.factor @@ -38,7 +38,7 @@ M: tile-pen pen-pref-dim swap draw-scaled-image ] with-translation ; -M: tile-pen draw-interior ( gadget pen -- ) +M: tile-pen draw-interior { [ nip >tile-pen< ] [ compute-tile-xs ] diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor index 80353404a5..1871fc4e38 100644 --- a/basis/ui/text/core-text/core-text.factor +++ b/basis/ui/text/core-text/core-text.factor @@ -41,7 +41,7 @@ M: core-text-renderer string-dim M: core-text-renderer flush-layout-cache cached-lines get-global purge-cache ; -M: core-text-renderer string>image ( font string -- image loc ) +M: core-text-renderer string>image cached-line [ line>image ] [ loc>> scale-dim ] bi ; M:: core-text-renderer x>offset ( x font string -- n ) @@ -59,10 +59,10 @@ M:: core-text-renderer offset>x ( n font string -- x ) f CTLineGetOffsetForStringIndex unscale ; -M: core-text-renderer font-metrics ( font -- metrics ) +M: core-text-renderer font-metrics cache-font-metrics ; -M: core-text-renderer line-metrics ( font string -- metrics ) +M: core-text-renderer line-metrics [ " " line-metrics clone 0 >>width ] [ cached-line metrics>> scale-metrics ] if-empty ; diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor index d9331000bb..6679362e29 100644 --- a/basis/ui/text/pango/pango.factor +++ b/basis/ui/text/pango/pango.factor @@ -187,19 +187,19 @@ M: pango-renderer string-dim M: pango-renderer flush-layout-cache cached-layouts get-global purge-cache ; -M: pango-renderer string>image ( font string -- image loc ) +M: pango-renderer string>image cached-layout [ layout>image ] [ text-position vneg ] bi ; -M: pango-renderer x>offset ( x font string -- n ) +M: pango-renderer x>offset cached-layout swap x>line-offset ; -M: pango-renderer offset>x ( n font string -- x ) +M: pango-renderer offset>x cached-layout swap line-offset>x ; -M: pango-renderer font-metrics ( font -- metrics ) +M: pango-renderer font-metrics " " cached-layout metrics>> clone f >>width ; -M: pango-renderer line-metrics ( font string -- metrics ) +M: pango-renderer line-metrics [ " " line-metrics clone 0 >>width ] [ cached-layout metrics>> ] if-empty ; diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor index 3b73d3d1c7..5115f3d0cf 100644 --- a/basis/ui/text/uniscribe/uniscribe.factor +++ b/basis/ui/text/uniscribe/uniscribe.factor @@ -13,21 +13,21 @@ M: uniscribe-renderer string-dim M: uniscribe-renderer flush-layout-cache cached-script-strings get-global purge-cache ; -M: uniscribe-renderer string>image ( font string -- image loc ) +M: uniscribe-renderer string>image cached-script-string script-string>image { 0 0 } ; -M: uniscribe-renderer x>offset ( x font string -- n ) +M: uniscribe-renderer x>offset [ 2drop 0 ] [ cached-script-string x>line-offset 0 = [ 1 + ] unless ] if-empty ; -M: uniscribe-renderer offset>x ( n font string -- x ) +M: uniscribe-renderer offset>x [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ; -M: uniscribe-renderer font-metrics ( font -- metrics ) +M: uniscribe-renderer font-metrics " " cached-script-string metrics>> clone f >>width ; -M: uniscribe-renderer line-metrics ( font string -- metrics ) +M: uniscribe-renderer line-metrics [ " " line-metrics clone 0 >>width ] [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ] if-empty ; diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 8d34e3d6c5..9eca133cc0 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -140,7 +140,7 @@ M: browser-gadget handle-gesture [ [ dup vocab-link? [ lookup-vocab ] when ] dip in? ] } 2|| ; -M: browser-gadget definitions-changed ( set browser -- ) +M: browser-gadget definitions-changed [ control-value swap showing-definition? ] keep '[ _ [ history-value ] keep set-history-value ] when ; diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 5ce038470b..a8140c52bf 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -173,7 +173,7 @@ M: interactor stream-read1 [ nip first first ] } cond ; -M: interactor stream-read-until ( seps stream -- seq sep/f ) +M: interactor stream-read-until swap '[ _ interactor-read [ "\n" join CHAR: \n suffix @@ -289,10 +289,10 @@ M: string listener-input [ (call-listener) ] with-ctrl-break ] "Listener call" spawn drop ; -M: listener-command invoke-command ( target command -- ) +M: listener-command invoke-command [ command-quot ] [ nip ] 2bi call-listener ; -M: listener-operation invoke-command ( target command -- ) +M: listener-operation invoke-command [ operation-quot ] [ nip command>> ] 2bi call-listener ; : eval-listener ( string -- ) @@ -362,7 +362,7 @@ M: object accept-completion-hook 2drop ; : try-parse ( lines -- quot/f ) [ parse-lines-interactive ] [ nip '[ _ rethrow ] ] recover ; -M: interactor stream-read-quot ( stream -- quot/f ) +M: interactor stream-read-quot dup interactor-yield dup array? [ over interactor-finish try-parse [ ] [ stream-read-quot ] ?if diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 92cf9f258f..be37a97c10 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -24,12 +24,12 @@ GENERIC: group-struct ( obj -- group/f ) : check-group-struct ( group-struct ptr -- group-struct/f ) void* deref [ drop f ] unless ; -M: integer group-struct ( id -- group/f ) +M: integer group-struct (group-struct) [ [ unix.ffi:getgrgid_r ] unix-system-call drop ] keep check-group-struct ; -M: string group-struct ( string -- group/f ) +M: string group-struct (group-struct) [ [ unix.ffi:getgrnam_r ] unix-system-call drop ] keep check-group-struct ; @@ -79,10 +79,10 @@ PRIVATE> GENERIC: user-groups ( string/id -- seq ) -M: string user-groups ( string -- seq ) +M: string user-groups (user-groups) ; -M: integer user-groups ( id -- seq ) +M: integer user-groups user-name (user-groups) ; : all-groups ( -- seq ) @@ -137,14 +137,14 @@ GENERIC: set-effective-group ( obj -- ) PRIVATE> -M: integer set-real-group ( id -- ) +M: integer set-real-group (set-real-group) ; -M: string set-real-group ( string -- ) +M: string set-real-group ?group-id (set-real-group) ; -M: integer set-effective-group ( id -- ) +M: integer set-effective-group (set-effective-group) ; -M: string set-effective-group ( string -- ) +M: string set-effective-group ?group-id (set-effective-group) ; diff --git a/basis/unix/linux/proc/proc.factor b/basis/unix/linux/proc/proc.factor index bf4b7f76b1..c2de4270f8 100644 --- a/basis/unix/linux/proc/proc.factor +++ b/basis/unix/linux/proc/proc.factor @@ -282,12 +282,12 @@ TUPLE: proc-uptime up idle ; GENERIC#: proc-pid-path 1 ( object string -- path ) -M: integer proc-pid-path ( pid string -- path ) +M: integer proc-pid-path [ "/proc/" ] 2dip [ number>string "/" append ] dip 3append ; -M: string proc-pid-path ( pid-string string -- path ) +M: string proc-pid-path [ "/proc/" ] 2dip [ append-path ] dip append-path ; : proc-file-lines ( path -- strings ) utf8 file-lines ; diff --git a/basis/unix/signals/signals.factor b/basis/unix/signals/signals.factor index 25abdfba07..9f972d0e29 100644 --- a/basis/unix/signals/signals.factor +++ b/basis/unix/signals/signals.factor @@ -20,7 +20,7 @@ GENERIC: signal-name ( obj -- str/f ) M: signal signal-name n>> signal-name ; -M: integer signal-name ( n -- str/f ) 1 - signal-names ?nth ; +M: integer signal-name 1 - signal-names ?nth ; : signal-name. ( n -- ) signal-name [ " (" ")" surround write ] when* ; diff --git a/basis/unix/users/macosx/macosx.factor b/basis/unix/users/macosx/macosx.factor index d9c378e629..8575fc6002 100644 --- a/basis/unix/users/macosx/macosx.factor +++ b/basis/unix/users/macosx/macosx.factor @@ -6,9 +6,9 @@ IN: unix.users.macosx TUPLE: macosx-passwd < passwd change class expire fields ; -M: macosx new-passwd ( -- macosx-passwd ) macosx-passwd new ; +M: macosx new-passwd macosx-passwd new ; -M: macosx passwd>new-passwd ( passwd -- macosx-passwd ) +M: macosx passwd>new-passwd [ call-next-method ] keep { [ pw_change>> >>change ] diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 7b77eebefe..d5253d0a50 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -15,10 +15,10 @@ HOOK: passwd>new-passwd os ( passwd -- new-passwd ) new-passwd ( passwd -- seq ) +M: unix passwd>new-passwd [ new-passwd ] dip { [ pw_name>> >>user-name ] @@ -54,11 +54,11 @@ SYMBOL: user-cache GENERIC: user-passwd ( obj -- passwd/f ) -M: integer user-passwd ( id -- passwd/f ) +M: integer user-passwd user-cache get [ at ] [ unix.ffi:getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ; -M: string user-passwd ( string -- passwd/f ) +M: string user-passwd unix.ffi:getpwnam dup [ passwd>new-passwd ] when ; : user-name ( id -- string ) @@ -117,16 +117,16 @@ GENERIC: set-effective-user ( string/id -- ) PRIVATE> -M: integer set-real-user ( id -- ) +M: integer set-real-user (set-real-user) ; -M: string set-real-user ( string -- ) +M: string set-real-user ?user-id (set-real-user) ; -M: integer set-effective-user ( id -- ) +M: integer set-effective-user (set-effective-user) ; -M: string set-effective-user ( string -- ) +M: string set-effective-user ?user-id (set-effective-user) ; ERROR: no-such-user obj ; diff --git a/basis/unix/utmpx/linux/linux.factor b/basis/unix/utmpx/linux/linux.factor index 6374eacaff..521fed343a 100644 --- a/basis/unix/utmpx/linux/linux.factor +++ b/basis/unix/utmpx/linux/linux.factor @@ -4,7 +4,7 @@ USING: accessors calendar.unix combinators kernel system unix.ffi unix.utmpx ; IN: unix.utmpx.linux -M: linux utmpx>utmpx-record ( utmpx -- utmpx-record ) +M: linux utmpx>utmpx-record [ new-utmpx-record ] dip { [ ut_user>> __UT_NAMESIZE memory>string >>user ] [ ut_id>> 4 memory>string >>id ] diff --git a/basis/unix/utmpx/macosx/macosx.factor b/basis/unix/utmpx/macosx/macosx.factor index 3ca89a0687..f99163e1ef 100644 --- a/basis/unix/utmpx/macosx/macosx.factor +++ b/basis/unix/utmpx/macosx/macosx.factor @@ -4,7 +4,7 @@ USING: accessors calendar.unix combinators kernel system unix.ffi unix.utmpx ; IN: unix.utmpx.macosx -M: macosx utmpx>utmpx-record ( utmpx -- utmpx-record ) +M: macosx utmpx>utmpx-record [ new-utmpx-record ] dip { [ ut_user>> _UTX_USERSIZE memory>string >>user ] [ ut_id>> _UTX_IDSIZE memory>string >>id ] diff --git a/basis/vocabs/prettyprint/prettyprint.factor b/basis/vocabs/prettyprint/prettyprint.factor index 6d9ffd1a2a..873bec53c4 100644 --- a/basis/vocabs/prettyprint/prettyprint.factor +++ b/basis/vocabs/prettyprint/prettyprint.factor @@ -27,7 +27,7 @@ IN: vocabs.prettyprint GENERIC: pprint-qualified ( qualified -- ) -M: qualified pprint-qualified ( qualified -- ) +M: qualified pprint-qualified [ dup [ vocab>> vocab-name ] [ prefix>> ] bi = [ \ QUALIFIED: pprint-word @@ -38,7 +38,7 @@ M: qualified pprint-qualified ( qualified -- ) ] if ] with-pprint ; -M: from pprint-qualified ( from -- ) +M: from pprint-qualified [ \ FROM: pprint-word [ vocab>> pprint-vocab "=>" text ] @@ -46,7 +46,7 @@ M: from pprint-qualified ( from -- ) \ ; pprint-word ] with-pprint ; -M: exclude pprint-qualified ( exclude -- ) +M: exclude pprint-qualified [ \ EXCLUDE: pprint-word [ vocab>> pprint-vocab "=>" text ] @@ -54,7 +54,7 @@ M: exclude pprint-qualified ( exclude -- ) \ ; pprint-word ] with-pprint ; -M: rename pprint-qualified ( rename -- ) +M: rename pprint-qualified [ \ RENAME: pprint-word [ word>> text ] diff --git a/basis/webbrowser/freebsd/freebsd.factor b/basis/webbrowser/freebsd/freebsd.factor index 5b9db50b53..cc1399f582 100644 --- a/basis/webbrowser/freebsd/freebsd.factor +++ b/basis/webbrowser/freebsd/freebsd.factor @@ -5,5 +5,5 @@ USING: arrays io.launcher kernel present system webbrowser ; IN: webbrowser.freebsd -M: freebsd open-item ( item -- ) +M: freebsd open-item present "open" swap 2array run-detached drop ; diff --git a/basis/webbrowser/linux/linux.factor b/basis/webbrowser/linux/linux.factor index e5ae19ec26..544abae86f 100644 --- a/basis/webbrowser/linux/linux.factor +++ b/basis/webbrowser/linux/linux.factor @@ -5,5 +5,5 @@ USING: arrays io.launcher kernel present system webbrowser ; IN: webbrowser.linux -M: linux open-item ( item -- ) +M: linux open-item present "xdg-open" swap 2array run-detached drop ; diff --git a/basis/webbrowser/macosx/macosx.factor b/basis/webbrowser/macosx/macosx.factor index 9975c3ce29..4382f56893 100644 --- a/basis/webbrowser/macosx/macosx.factor +++ b/basis/webbrowser/macosx/macosx.factor @@ -5,5 +5,5 @@ USING: arrays io.launcher kernel present system webbrowser ; IN: webbrowser.macosx -M: macosx open-item ( item -- ) +M: macosx open-item present "open" swap 2array run-detached drop ; diff --git a/basis/webbrowser/windows/windows.factor b/basis/webbrowser/windows/windows.factor index 7a7a7dee99..f1752c1622 100644 --- a/basis/webbrowser/windows/windows.factor +++ b/basis/webbrowser/windows/windows.factor @@ -3,6 +3,6 @@ USING: kernel present system webbrowser windows.shell32 windows.user32 ; IN: webbrowser.windows -M: windows open-item ( item -- ) +M: windows open-item [ f "open" ] dip present f f SW_SHOWNORMAL ShellExecute drop ; diff --git a/basis/windows/handles/handles.factor b/basis/windows/handles/handles.factor index 07d6c8f5d2..bada92b738 100644 --- a/basis/windows/handles/handles.factor +++ b/basis/windows/handles/handles.factor @@ -17,5 +17,5 @@ TUPLE: win32-handle < disposable handle ; : ( handle -- win32-handle ) win32-handle new-win32-handle ; -M: win32-handle dispose* ( handle -- ) +M: win32-handle dispose* handle>> CloseHandle win32-error=0/f ; diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 4fb2ef7fbc..f10c13d5a9 100644 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -158,10 +158,10 @@ STRUCT: timeval GENERIC: sockaddr>ip ( sockaddr -- string ) -M: sockaddr-in sockaddr>ip ( sockaddr -- string ) +M: sockaddr-in sockaddr>ip addr>> uint [ number>string ] { } map-as "." join ; -M: sockaddr-in6 sockaddr>ip ( uchar-array -- string ) +M: sockaddr-in6 sockaddr>ip addr>> [ >hex ] { } map-as 2 group [ concat ] map ":" join ; STRUCT: fd_set