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

basis: removing unnecessary method stack effects.

master
John Benediktsson 2020-09-09 14:41:17 -07:00
parent f2deb82829
commit 115b7b62df
217 changed files with 859 additions and 872 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/bitstreams/bitstreams.factor
View File

@ -166,10 +166,10 @@ ERROR: not-enough-bits n bit-reader ;
bs bytes>> subseq endian> execute( seq -- x ) bs bytes>> subseq endian> execute( seq -- x )
n bs subseq-endian execute( bignum n bs -- bits ) ; 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) ; \ le> \ subseq>bits-le (peek) ;
M: msb0-bit-reader peek ( n bs -- bits ) M: msb0-bit-reader peek
\ be> \ subseq>bits-be (peek) ; \ be> \ subseq>bits-be (peek) ;
:: bit-writer-bytes ( writer -- bytes ) :: bit-writer-bytes ( writer -- bytes )

4
basis/channels/channels.factor
View File

@ -31,11 +31,11 @@ GENERIC: from ( channel -- value )
PRIVATE> PRIVATE>
M: channel to ( value channel -- ) M: channel to
dup receivers>> dup receivers>>
[ dup wait to ] [ nip (to) ] if-empty ; [ dup wait to ] [ nip (to) ] if-empty ;
M: channel from ( channel -- value ) M: channel from
[ self ] dip [ self ] dip
notify senders>> notify senders>>
[ (from) ] unless-empty [ (from) ] unless-empty

4
basis/channels/remote/remote.factor
View File

@ -60,10 +60,10 @@ C: <remote-channel> remote-channel
PRIVATE> PRIVATE>
M: remote-channel to ( value remote-channel -- ) M: remote-channel to
[ id>> swap to-message boa ] keep send-message drop ; [ 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 ; [ id>> from-message boa ] keep send-message ;
[ [

2
basis/checksums/adler-32/adler-32.factor
View File

@ -8,7 +8,7 @@ SINGLETON: adler-32
CONSTANT: adler-32-modulus 65521 CONSTANT: adler-32-modulus 65521
M: adler-32 checksum-bytes ( bytes checksum -- value ) M: adler-32 checksum-bytes
drop drop
[ sum 1 + ] [ sum 1 + ]
[ [ dup length [1,b] <reversed> vdot ] [ length ] bi + ] bi [ [ dup length [1,b] <reversed> vdot ] [ length ] bi + ] bi

2
basis/checksums/bsd/bsd.factor
View File

@ -5,7 +5,7 @@ IN: checksums.bsd
SINGLETON: bsd SINGLETON: bsd
M: bsd checksum-bytes ( bytes checksum -- value ) M: bsd checksum-bytes
drop 0 [ drop 0 [
[ [ -1 shift ] [ 1 bitand 15 shift ] bi + ] dip [ [ -1 shift ] [ 1 bitand 15 shift ] bi + ] dip
+ 0xffff bitand + 0xffff bitand

24
basis/checksums/fnv1/fnv1.factor
View File

@ -38,67 +38,67 @@ CONSTANT: fnv1-256-basis 0xdd268dbcaac550362d98c384c4e576ccc8b1536847b6bbb31023b
CONSTANT: fnv1-512-basis 0xb86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9 CONSTANT: fnv1-512-basis 0xb86db0b1171f4416dca1e50f309990acac87d059c90000000000000000000d21e948f68a34c192f62ea79bc942dbe7ce182036415f56e34bac982aac4afe9fd9
CONSTANT: fnv1-1024-basis 0x5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3 CONSTANT: fnv1-1024-basis 0x5f7a76758ecc4d32e56d5a591028b74b29fc4223fdada16c3bf34eda3674da9a21d9000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004c6d7eb6e73802734510a555f256cc005ae556bde8cc9c6a93b21aff4b16c71ee90b3
M: fnv1-32 checksum-bytes ( bytes checksum -- value ) M: fnv1-32 checksum-bytes
drop drop
fnv1-32-basis swap fnv1-32-basis swap
[ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ; [ swap fnv1-32-prime * bitxor fnv1-32-mod bitand ] each ;
M: fnv1a-32 checksum-bytes ( bytes checksum -- value ) M: fnv1a-32 checksum-bytes
drop drop
fnv1-32-basis swap fnv1-32-basis swap
[ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ; [ bitxor fnv1-32-prime * fnv1-32-mod bitand ] each ;
M: fnv1-64 checksum-bytes ( bytes checksum -- value ) M: fnv1-64 checksum-bytes
drop drop
fnv1-64-basis swap fnv1-64-basis swap
[ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ; [ swap fnv1-64-prime * bitxor fnv1-64-mod bitand ] each ;
M: fnv1a-64 checksum-bytes ( bytes checksum -- value ) M: fnv1a-64 checksum-bytes
drop drop
fnv1-64-basis swap fnv1-64-basis swap
[ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ; [ bitxor fnv1-64-prime * fnv1-64-mod bitand ] each ;
M: fnv1-128 checksum-bytes ( bytes checksum -- value ) M: fnv1-128 checksum-bytes
drop drop
fnv1-128-basis swap fnv1-128-basis swap
[ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ; [ swap fnv1-128-prime * bitxor fnv1-128-mod bitand ] each ;
M: fnv1a-128 checksum-bytes ( bytes checksum -- value ) M: fnv1a-128 checksum-bytes
drop drop
fnv1-128-basis swap fnv1-128-basis swap
[ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ; [ bitxor fnv1-128-prime * fnv1-128-mod bitand ] each ;
M: fnv1-256 checksum-bytes ( bytes checksum -- value ) M: fnv1-256 checksum-bytes
drop drop
fnv1-256-basis swap fnv1-256-basis swap
[ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ; [ swap fnv1-256-prime * bitxor fnv1-256-mod bitand ] each ;
M: fnv1a-256 checksum-bytes ( bytes checksum -- value ) M: fnv1a-256 checksum-bytes
drop drop
fnv1-256-basis swap fnv1-256-basis swap
[ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ; [ bitxor fnv1-256-prime * fnv1-256-mod bitand ] each ;
M: fnv1-512 checksum-bytes ( bytes checksum -- value ) M: fnv1-512 checksum-bytes
drop drop
fnv1-512-basis swap fnv1-512-basis swap
[ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ; [ swap fnv1-512-prime * bitxor fnv1-512-mod bitand ] each ;
M: fnv1a-512 checksum-bytes ( bytes checksum -- value ) M: fnv1a-512 checksum-bytes
drop drop
fnv1-512-basis swap fnv1-512-basis swap
[ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ; [ bitxor fnv1-512-prime * fnv1-512-mod bitand ] each ;
M: fnv1-1024 checksum-bytes ( bytes checksum -- value ) M: fnv1-1024 checksum-bytes
drop drop
fnv1-1024-basis swap fnv1-1024-basis swap
[ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ; [ swap fnv1-1024-prime * bitxor fnv1-1024-mod bitand ] each ;
M: fnv1a-1024 checksum-bytes ( bytes checksum -- value ) M: fnv1a-1024 checksum-bytes
drop drop
fnv1-1024-basis swap fnv1-1024-basis swap
[ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ; [ bitxor fnv1-1024-prime * fnv1-1024-mod bitand ] each ;

2
basis/checksums/murmur/murmur.factor
View File

@ -47,7 +47,7 @@ CONSTANT: n 0xe6546b64
PRIVATE> PRIVATE>
M: murmur3-32 checksum-bytes ( bytes checksum -- value ) M: murmur3-32 checksum-bytes
seed>> 32 bits main-loop end-case avalanche ; seed>> 32 bits main-loop end-case avalanche ;
INSTANCE: murmur3-32 checksum INSTANCE: murmur3-32 checksum

6
basis/checksums/openssl/openssl.factor
View File

@ -38,13 +38,13 @@ M: evp-md-context dispose*
: set-digest ( name ctx -- ) : set-digest ( name ctx -- )
handle>> swap digest-named f EVP_DigestInit_ex ssl-error ; 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>> <evp-md-context> [ set-digest ] keep ; maybe-init-ssl name>> <evp-md-context> [ 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 ; [ dup handle>> ] dip dup length EVP_DigestUpdate ssl-error ;
M: evp-md-context get-checksum ( ctx -- value ) M: evp-md-context get-checksum
handle>> handle>>
{ { int EVP_MAX_MD_SIZE } int } { { int EVP_MAX_MD_SIZE } int }
[ EVP_DigestFinal_ex ssl-error ] with-out-parameters [ EVP_DigestFinal_ex ssl-error ] with-out-parameters

2
basis/classes/struct/prettyprint/prettyprint.factor
View File

@ -116,7 +116,7 @@ M: struct-mirror delete-at
M: struct-mirror clear-assoc M: struct-mirror clear-assoc
object>> reset-struct-slots ; object>> reset-struct-slots ;
M: struct-mirror >alist ( mirror -- alist ) M: struct-mirror >alist
object>> [ object>> [
[ drop "underlying" ] [ >c-ptr ] bi 2array 1array [ drop "underlying" ] [ >c-ptr ] bi 2array 1array
] [ ] [

2
basis/colors/gray/gray.factor
View File

@ -7,7 +7,7 @@ TUPLE: gray < color { gray read-only } { alpha read-only } ;
C: <gray> gray C: <gray> gray
M: gray >rgba ( gray -- rgba ) M: gray >rgba
[ gray>> dup dup ] [ alpha>> ] bi <rgba> ; inline [ gray>> dup dup ] [ alpha>> ] bi <rgba> ; inline
M: gray red>> gray>> ; M: gray red>> gray>> ;

2
basis/colors/hsv/hsv.factor
View File

@ -29,7 +29,7 @@ C: <hsva> hsva
PRIVATE> PRIVATE>
M: hsva >rgba ( hsva -- rgba ) M: hsva >rgba
[ [
dup Hi dup Hi
{ {

2
basis/colors/ryb/ryb.factor
View File

@ -61,7 +61,7 @@ C: <ryba> ryba
PRIVATE> PRIVATE>
M: ryba >rgba ( ryba -- rgba ) M: ryba >rgba
[ [
[ red>> ] [ yellow>> ] [ blue>> ] tri [ red>> ] [ yellow>> ] [ blue>> ] tri
[ ryb>rgb ] normalized [ ryb>rgb ] normalized

8
basis/compiler/cfg/builder/alien/alien.factor
View File

@ -95,7 +95,7 @@ IN: compiler.cfg.builder.alien
[ stack-params get [ caller-stack-cleanup ] keep ] [ stack-params get [ caller-stack-cleanup ] keep ]
} cleave ; } cleave ;
M: #alien-invoke emit-node ( block node -- block' ) M: #alien-invoke emit-node
params>> params>>
[ [
[ params>alien-insn-params ] [ params>alien-insn-params ]
@ -104,7 +104,7 @@ M: #alien-invoke emit-node ( block node -- block' )
] ]
[ caller-return ] bi ; [ caller-return ] bi ;
M: #alien-indirect emit-node ( block node -- block' ) M: #alien-indirect emit-node
params>> params>>
[ [
[ ds-pop ^^unbox-any-c-ptr ] dip [ ds-pop ^^unbox-any-c-ptr ] dip
@ -113,7 +113,7 @@ M: #alien-indirect emit-node ( block node -- block' )
] ]
[ caller-return ] bi ; [ caller-return ] bi ;
M: #alien-assembly emit-node ( block node -- block' ) M: #alien-assembly emit-node
params>> params>>
[ [
[ params>alien-insn-params ] [ params>alien-insn-params ]
@ -167,7 +167,7 @@ M: #alien-assembly emit-node ( block node -- block' )
: emit-callback-outputs ( block params -- ) : emit-callback-outputs ( block params -- )
[ emit-callback-return ] keep callback-stack-cleanup ; [ emit-callback-return ] keep callback-stack-cleanup ;
M: #alien-callback emit-node ( block node -- block' ) M: #alien-callback emit-node
dup params>> xt>> dup dup params>> xt>> dup
[ [
t cfg get frame-pointer?<< t cfg get frame-pointer?<<

2
basis/compiler/cfg/builder/alien/boxing/boxing.factor
View File

@ -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? long-long-odd-register? 3array
int-rep long-long-on-stack? f 3array 2array record-reg-reps ; 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 ; [ ^^unbox-any-c-ptr ] dip explode-struct ;
: frob-struct ( c-type -- c-type ) : frob-struct ( c-type -- c-type )

4
basis/compiler/cfg/builder/alien/params/params.factor
View File

@ -8,11 +8,11 @@ SYMBOL: stack-params
GENERIC: alloc-stack-param ( rep -- n ) GENERIC: alloc-stack-param ( rep -- n )
M: object alloc-stack-param ( rep -- n ) M: object alloc-stack-param
stack-params get stack-params get
[ rep-size cell align stack-params +@ ] dip ; [ 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 stack-params get swap rep-size
[ cell align stack-params +@ ] keep [ cell align stack-params +@ ] keep
float-right-align-on-stack? [ + ] [ drop ] if ; float-right-align-on-stack? [ + ] [ drop ] if ;

20
basis/compiler/cfg/builder/builder.factor
View File

@ -71,7 +71,7 @@ GENERIC: emit-node ( block node -- block' )
##branch, [ begin-basic-block ] dip ##branch, [ begin-basic-block ] dip
[ label>> id>> loops get set-at ] [ child>> emit-nodes ] 2bi ; [ 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 ; dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
! #if ! #if
@ -109,28 +109,28 @@ M: #recursive emit-node ( block node -- block' )
! loc>vreg sync ! loc>vreg sync
ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ; 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-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ emit-actual-if ] [ emit-actual-if ]
} cond ; } cond ;
M: #dispatch emit-node ( block node -- block' ) M: #dispatch emit-node
! Inputs to the final instruction need to be copied because of ! Inputs to the final instruction need to be copied because of
! loc>vreg sync. ^^offset>slot always returns a fresh vreg, ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
! though. ! though.
ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ; 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 [ dup word>> dup "intrinsic" word-prop [
nip call( block #call -- block' ) nip call( block #call -- block' )
] [ swap call-height emit-call ] if* ; ] [ 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 ; [ label>> id>> ] [ call-height ] bi emit-call ;
M: #push emit-node ( block node -- block ) M: #push emit-node
literal>> ^^load-literal ds-push ; literal>> ^^load-literal ds-push ;
! #shuffle ! #shuffle
@ -157,7 +157,7 @@ M: #push emit-node ( block node -- block )
[ make-input-map ] [ mapping>> ] [ extract-outputs ] tri [ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
[ [ of of peek-loc ] 2with map ] 2with map ; [ [ 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 [ out-vregs/stack ] keep store-height-changes
first2 [ ds-loc store-vregs ] [ rs-loc store-vregs ] bi* ; first2 [ ds-loc store-vregs ] [ rs-loc store-vregs ] bi* ;
@ -167,14 +167,14 @@ M: #shuffle emit-node ( block node -- block )
t >>kill-block? t >>kill-block?
##safepoint, ##epilogue, ##return, ; ##safepoint, ##epilogue, ##return, ;
M: #return emit-node ( block node -- block' ) M: #return emit-node
drop end-word ; drop end-word ;
M: #return-recursive emit-node ( block node -- block' ) M: #return-recursive emit-node
label>> id>> loops get key? [ ] [ end-word ] if ; label>> id>> loops get key? [ ] [ end-word ] if ;
! #terminate ! #terminate
M: #terminate emit-node ( block node -- block' ) M: #terminate emit-node
drop ##no-tco, end-basic-block f ; drop ##no-tco, end-basic-block f ;
! No-op nodes ! No-op nodes

4
basis/compiler/cfg/liveness/liveness.factor
View File

@ -35,7 +35,7 @@ GENERIC: visit-insn ( live-set insn -- )
: gen-uses ( live-set insn -- ) : gen-uses ( live-set insn -- )
uses-vregs [ swap conjoin ] with each ; inline 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 ; [ kill-defs ] [ gen-uses ] 2bi ;
DEFER: lookup-base-pointer DEFER: lookup-base-pointer
@ -98,7 +98,7 @@ M: vreg-insn lookup-base-pointer* 2drop f ;
: fill-gc-map ( live-set gc-map -- ) : fill-gc-map ( live-set gc-map -- )
[ gc-roots ] dip [ gc-roots<< ] [ derived-roots<< ] bi ; [ 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 ; [ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] 2tri ;
M: ##phi visit-insn kill-defs ; M: ##phi visit-insn kill-defs ;

4
basis/concurrency/distributed/distributed.factor
View File

@ -68,11 +68,11 @@ C: <connection> connection
: send-to-connection ( message connection -- ) : send-to-connection ( message connection -- )
stream>> [ serialize flush ] with-stream* ; stream>> [ serialize flush ] with-stream* ;
M: remote-thread send ( message thread -- ) M: remote-thread send
[ id>> 2array ] [ node>> ] [ thread-connections at ] tri [ id>> 2array ] [ node>> ] [ thread-connections at ] tri
[ nip send-to-connection ] [ send-remote-message ] if* ; [ nip send-to-connection ] [ send-remote-message ] if* ;
M: thread (serialize) ( obj -- ) M: thread (serialize)
id>> [ local-node get insecure>> ] dip <remote-thread> (serialize) ; id>> [ local-node get insecure>> ] dip <remote-thread> (serialize) ;
: stop-node ( -- ) : stop-node ( -- )

2
basis/concurrency/messaging/messaging.factor
View File

@ -13,7 +13,7 @@ M: thread mailbox-of
[ { mailbox } declare ] [ { mailbox } declare ]
[ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
M: thread send ( message thread -- ) M: thread send
mailbox-of mailbox-put ; mailbox-of mailbox-put ;
: my-mailbox ( -- mailbox ) self mailbox-of ; inline : my-mailbox ( -- mailbox ) self mailbox-of ; inline

2
basis/couchdb/couchdb.factor
View File

@ -18,7 +18,7 @@ SYMBOL: couch
TUPLE: couchdb-error { data assoc } ; TUPLE: couchdb-error { data assoc } ;
C: <couchdb-error> couchdb-error C: <couchdb-error> couchdb-error
M: couchdb-error error. ( error -- ) M: couchdb-error error.
"CouchDB Error: " write data>> "CouchDB Error: " write data>>
"error" over at [ print ] when* "error" over at [ print ] when*
"reason" of [ print ] when* ; "reason" of [ print ] when* ;

2
basis/cpu/architecture/architecture.factor
View File

@ -524,7 +524,7 @@ HOOK: immediate-bitwise? cpu ( n -- ? )
HOOK: immediate-comparand? cpu ( n -- ? ) HOOK: immediate-comparand? cpu ( n -- ? )
HOOK: immediate-store? cpu ( n -- ? ) HOOK: immediate-store? cpu ( n -- ? )
M: object immediate-comparand? ( n -- ? ) M: object immediate-comparand?
{ {
{ [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] } { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
{ [ dup not ] [ drop t ] } { [ dup not ] [ drop t ] }

10
basis/cpu/ppc/32/linux/linux.factor
View File

@ -5,13 +5,13 @@ compiler.cfg.builder.alien.boxing sequences arrays
alien.c-types cpu.architecture cpu.ppc alien.complex ; alien.c-types cpu.architecture cpu.ppc alien.complex ;
IN: cpu.ppc.32.linux 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 M: ppc param-regs
drop { drop {
@ -35,7 +35,7 @@ M: ppc long-long-odd-register? t ;
M: ppc float-right-align-on-stack? f ; 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 = ] { [ dup lookup-c-type complex-double lookup-c-type = ]
[ drop { { int-rep f f } { int-rep f f } [ drop { { int-rep f f } { int-rep f f }

10
basis/cpu/ppc/64/linux/linux.factor
View File

@ -7,11 +7,11 @@ IN: cpu.ppc.64.linux
M: linux lr-save 2 cells ; 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 M: ppc param-regs
drop { drop {
@ -33,7 +33,7 @@ M: ppc long-long-odd-register? f ;
M: ppc float-right-align-on-stack? t ; 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 = ] { [ dup lookup-c-type complex-double lookup-c-type = ]
[ drop { { double-rep f f } { double-rep f f } } ] } [ 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 } <repetition> ] [ heap-size cell align cell /i { int-rep f f } <repetition> ]
} cond ; } cond ;
M: ppc flatten-struct-type-return ( type -- seq ) M: ppc flatten-struct-type-return
{ {
{ [ dup lookup-c-type complex-double lookup-c-type = ] { [ dup lookup-c-type complex-double lookup-c-type = ]
[ drop { { double-rep f f } { double-rep f f } } ] } [ drop { { double-rep f f } { double-rep f f } } ] }

6
basis/cpu/ppc/assembler/assembler.factor
View File

@ -115,16 +115,16 @@ IN: cpu.ppc.assembler
! 2.4 Branch Instructions ! 2.4 Branch Instructions
GENERIC: B ( target_addr/label -- ) 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 -- ) 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 ; : BA ( target_addr -- ) -2 shift 1 0 18 i-insn ;
: BLA ( target_addr -- ) -2 shift 1 1 18 i-insn ; : BLA ( target_addr -- ) -2 shift 1 1 18 i-insn ;
GENERIC: BC ( bo bi target_addr/label -- ) 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 ; : BCA ( bo bi target_addr -- ) -2 shift 1 0 16 b-insn ;
: BCL ( bo bi target_addr -- ) -2 shift 0 1 16 b-insn ; : BCL ( bo bi target_addr -- ) -2 shift 0 1 16 b-insn ;

130
basis/cpu/ppc/ppc.factor
View File

@ -34,9 +34,9 @@ HOOK: has-toc os ( -- ? )
HOOK: reserved-area-size os ( -- n ) HOOK: reserved-area-size os ( -- n )
HOOK: allows-null-dereference os ( -- ? ) HOOK: allows-null-dereference os ( -- ? )
M: label B ( label -- ) [ 0 B ] dip rc-relative-ppc-3-pc label-fixup ; M: label B [ 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 BL [ 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 BC [ 0 BC ] dip rc-relative-ppc-2-pc label-fixup ;
CONSTANT: scratch-reg 30 CONSTANT: scratch-reg 30
CONSTANT: fp-scratch-reg 30 CONSTANT: fp-scratch-reg 30
@ -44,16 +44,16 @@ CONSTANT: ds-reg 14
CONSTANT: rs-reg 15 CONSTANT: rs-reg 15
CONSTANT: vm-reg 16 CONSTANT: vm-reg 16
M: ppc machine-registers ( -- assoc ) M: ppc machine-registers
{ {
{ int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] } { int-regs $[ 3 12 [a,b] 17 29 [a,b] append ] }
{ float-regs $[ 0 29 [a,b] ] } { float-regs $[ 0 29 [a,b] ] }
} ; } ;
M: ppc frame-reg ( -- reg ) 31 ; M: ppc frame-reg 31 ;
M: ppc.32 vm-stack-space ( -- n ) 16 ; M: ppc.32 vm-stack-space 16 ;
M: ppc.64 vm-stack-space ( -- n ) 32 ; M: ppc.64 vm-stack-space 32 ;
M: ppc complex-addressing? ( -- ? ) f ; M: ppc complex-addressing? f ;
! PW1-PW8 parameter save slots ! PW1-PW8 parameter save slots
: param-save-size ( -- n ) 8 cells ; foldable : param-save-size ( -- n ) 8 cells ; foldable
@ -67,7 +67,7 @@ M: ppc complex-addressing? ( -- ? ) f ;
: param@ ( n -- offset ) : param@ ( n -- offset )
reserved-area-size + ; reserved-area-size + ;
M: ppc gc-root-offset ( spill-slot -- n ) M: ppc gc-root-offset
n>> spill@ cell /i ; n>> spill@ cell /i ;
: LOAD32 ( r n -- ) : 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.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.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 ; 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 ; 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* ] [ [ 0 %load-cell-imm ] [ %load-cell-imm-rc rel-literal ] bi* ]
[ \ f type-number LI ] [ \ f type-number LI ]
if* ; if* ;
@ -156,11 +156,11 @@ M: ds-loc loc-reg drop ds-reg ;
M: rs-loc loc-reg drop rs-reg ; M: rs-loc loc-reg drop rs-reg ;
! Load value at stack location loc into vreg. ! Load value at stack location loc into vreg.
M: ppc %peek ( vreg loc -- ) M: ppc %peek
[ loc-reg ] [ n>> cells neg ] bi %load-cell ; [ loc-reg ] [ n>> cells neg ] bi %load-cell ;
! Replace value at stack location loc with value in vreg. ! 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 ; [ loc-reg ] [ n>> cells neg ] bi %store-cell ;
! Replace value at stack location with an immediate value. ! Replace value at stack location with an immediate value.
@ -176,45 +176,45 @@ M:: ppc %replace-imm ( src loc -- )
} cond } cond
scratch-reg reg offset %store-cell ; scratch-reg reg offset %store-cell ;
M: ppc %clear ( loc -- ) M: ppc %clear
297 swap %replace-imm ; 297 swap %replace-imm ;
! Increment stack pointer by n cells. ! 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 ; [ 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) (stack-frame-size)
reserved-area-size + reserved-area-size +
param-save-size + param-save-size +
factor-area-size + factor-area-size +
16 align ; 16 align ;
M: ppc %call ( word -- ) M: ppc %call
0 BL rc-relative-ppc-3-pc rel-word-pic ; 0 BL rc-relative-ppc-3-pc rel-word-pic ;
: instrs ( n -- b ) 4 * ; inline : 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 6 0 %load-cell-imm 1 instrs %load-cell-imm-rc rel-here
0 B rc-relative-ppc-3-pc rel-word-pic-tail ; 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 ] [ nip 0 %load-cell-imm 3 instrs %load-cell-imm-rc rel-here ]
[ swap dupd %load-cell-x ] [ swap dupd %load-cell-x ]
[ nip MTCTR ] 2tri BCTR ; [ nip MTCTR ] 2tri BCTR ;
M: ppc %slot ( dst obj slot scale tag -- ) M: ppc %slot
[ 0 assert= ] bi@ %load-cell-x ; [ 0 assert= ] bi@ %load-cell-x ;
M: ppc %slot-imm ( dst obj slot tag -- ) M: ppc %slot-imm
slot-offset scratch-reg swap LI slot-offset scratch-reg swap LI
scratch-reg %load-cell-x ; scratch-reg %load-cell-x ;
M: ppc %set-slot ( src obj slot scale tag -- ) M: ppc %set-slot
[ 0 assert= ] bi@ %store-cell-x ; [ 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 ; slot-offset [ scratch-reg ] dip LI scratch-reg %store-cell-x ;
M: ppc %jump-label B ; 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.32 %bit-count POPCNTW ;
M: ppc.64 %bit-count POPCNTD ; M: ppc.64 %bit-count POPCNTD ;
M: ppc %copy ( dst src rep -- ) M: ppc %copy
2over eq? [ 3drop ] [ 2over eq? [ 3drop ] [
{ {
{ tagged-rep [ MR ] } { tagged-rep [ MR ] }
@ -276,15 +276,15 @@ M: ppc %copy ( dst src rep -- )
{ cc/o [ 0 label BNS ] } { cc/o [ 0 label BNS ] }
} case ; inline } case ; inline
M: ppc %fixnum-add ( label dst src1 src2 cc -- ) M: ppc %fixnum-add
[ ADDO. ] overflow-template ; [ ADDO. ] overflow-template ;
M: ppc %fixnum-sub ( label dst src1 src2 cc -- ) M: ppc %fixnum-sub
[ SUBFO. ] overflow-template ; [ SUBFO. ] overflow-template ;
M: ppc.32 %fixnum-mul ( label dst src1 src2 cc -- ) M: ppc.32 %fixnum-mul
[ MULLWO. ] overflow-template ; [ MULLWO. ] overflow-template ;
M: ppc.64 %fixnum-mul ( label dst src1 src2 cc -- ) M: ppc.64 %fixnum-mul
[ MULLDO. ] overflow-template ; [ MULLDO. ] overflow-template ;
M: ppc %add-float FADD ; M: ppc %add-float FADD ;
@ -292,11 +292,11 @@ M: ppc %sub-float FSUB ;
M: ppc %mul-float FMUL ; M: ppc %mul-float FMUL ;
M: ppc %div-float FDIV ; M: ppc %div-float FDIV ;
M: ppc %min-float ( dst src1 src2 -- ) M: ppc %min-float
2dup [ scratch-reg ] 2dip FSUB 2dup [ scratch-reg ] 2dip FSUB
[ scratch-reg ] 2dip FSEL ; [ scratch-reg ] 2dip FSEL ;
M: ppc %max-float ( dst src1 src2 -- ) M: ppc %max-float
2dup [ scratch-reg ] 2dip FSUB 2dup [ scratch-reg ] 2dip FSUB
[ scratch-reg ] 2dip FSEL ; [ scratch-reg ] 2dip FSEL ;
@ -343,26 +343,26 @@ M:: ppc.64 %float>integer ( dst src -- )
} ; } ;
! Return values of this class go here ! Return values of this class go here
M: ppc return-regs ( -- regs ) M: ppc return-regs
{ {
{ int-regs { 3 4 5 6 } } { int-regs { 3 4 5 6 } }
{ float-regs { 1 2 3 4 } } { float-regs { 1 2 3 4 } }
} ; } ;
! Is this structure small enough to be returned in registers? ! 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?>> ; lookup-c-type return-in-registers?>> ;
! If t, the struct return pointer is never passed in a param reg ! 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 -- ) GENERIC: load-param ( reg src -- )
M: integer load-param ( reg src -- ) int-rep %copy ; M: integer load-param int-rep %copy ;
M: spill-slot load-param ( reg src -- ) [ 1 ] dip n>> spill@ %load-cell ; M: spill-slot load-param [ 1 ] dip n>> spill@ %load-cell ;
GENERIC: store-param ( reg dst -- ) GENERIC: store-param ( reg dst -- )
M: integer store-param ( reg dst -- ) swap int-rep %copy ; M: integer store-param swap int-rep %copy ;
M: spill-slot store-param ( reg dst -- ) [ 1 ] dip n>> spill@ %store-cell ; M: spill-slot store-param [ 1 ] dip n>> spill@ %store-cell ;
M:: ppc %unbox ( dst src func rep -- ) M:: ppc %unbox ( dst src func rep -- )
3 src load-param 3 src load-param
@ -459,10 +459,7 @@ M:: ppc %c-invoke ( name dll gc-map -- )
dead-outputs [ first2 discard-reg-param ] each dead-outputs [ first2 discard-reg-param ] each
; inline ; inline
M: ppc %alien-invoke ( varargs? reg-inputs stack-inputs M: ppc %alien-invoke
reg-outputs dead-outputs
cleanup stack-size
symbols dll gc-map -- )
'[ _ _ _ %c-invoke ] emit-alien-insn ; '[ _ _ _ %c-invoke ] emit-alien-insn ;
M:: ppc %alien-indirect ( src M:: ppc %alien-indirect ( src
@ -483,36 +480,33 @@ M:: ppc %alien-indirect ( src
gc-map gc-map-here gc-map gc-map-here
] emit-alien-insn ; ] emit-alien-insn ;
M: ppc %alien-assembly ( varargs? reg-inputs stack-inputs M: ppc %alien-assembly
reg-outputs dead-outputs
cleanup stack-size
quot -- )
'[ _ call( -- ) ] emit-alien-insn ; '[ _ call( -- ) ] emit-alien-insn ;
M: ppc %callback-inputs ( reg-outputs stack-outputs -- ) M: ppc %callback-inputs
[ [ first3 load-reg-param ] each ] [ [ first3 load-reg-param ] each ]
[ [ first3 load-stack-param ] each ] bi* [ [ first3 load-stack-param ] each ] bi*
3 vm-reg MR 3 vm-reg MR
4 0 LI 4 0 LI
"begin_callback" f f %c-invoke ; "begin_callback" f f %c-invoke ;
M: ppc %callback-outputs ( reg-inputs -- ) M: ppc %callback-outputs
3 vm-reg MR 3 vm-reg MR
"end_callback" f f %c-invoke "end_callback" f f %c-invoke
[ first3 store-reg-param ] each ; [ first3 store-reg-param ] each ;
M: ppc stack-cleanup ( stack-size return abi -- n ) M: ppc stack-cleanup
3drop 0 ; 3drop 0 ;
M: ppc fused-unboxing? f ; 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 ; [ 0 %load-cell-imm ] 2dip %load-cell-imm-rc rel-dlsym ;
M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip %load-cell ; M: ppc %vm-field [ vm-reg ] dip %load-cell ;
M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip %store-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 ; scratch-reg alien-offset LI scratch-reg %load-cell-x ;
! Convert a c-ptr object to a raw C pointer. ! 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 [ ] } { c:ulonglong [ ] }
} case ; } case ;
M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- ) M: ppc.32 %load-memory-imm
[ [
pick %trap-null pick %trap-null
{ {
@ -725,7 +719,7 @@ M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
} case } case
] ?if ; ] ?if ;
M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- ) M: ppc.64 %load-memory-imm
[ [
pick %trap-null pick %trap-null
{ {
@ -747,7 +741,7 @@ M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
] ?if ; ] ?if ;
M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- ) M: ppc.32 %load-memory
[ [ 0 assert= ] bi@ ] 2dip [ [ 0 assert= ] bi@ ] 2dip
[ [
pick %trap-null pick %trap-null
@ -767,7 +761,7 @@ M: ppc.32 %load-memory ( dst base displacement scale offset rep c-type -- )
} case } case
] ?if ; ] ?if ;
M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- ) M: ppc.64 %load-memory
[ [ 0 assert= ] bi@ ] 2dip [ [ 0 assert= ] bi@ ] 2dip
[ [
pick %trap-null pick %trap-null
@ -790,7 +784,7 @@ M: ppc.64 %load-memory ( dst base displacement scale offset rep c-type -- )
] ?if ; ] ?if ;
M: ppc.32 %store-memory-imm ( src base offset rep c-type -- ) M: ppc.32 %store-memory-imm
[ [
{ {
{ c:char [ STB ] } { c:char [ STB ] }
@ -808,7 +802,7 @@ M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
} case } case
] ?if ; ] ?if ;
M: ppc.64 %store-memory-imm ( src base offset rep c-type -- ) M: ppc.64 %store-memory-imm
[ [
{ {
{ c:char [ STB ] } { c:char [ STB ] }
@ -828,7 +822,7 @@ M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
} case } case
] ?if ; ] ?if ;
M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- ) M: ppc.32 %store-memory
[ [ 0 assert= ] bi@ ] 2dip [ [ 0 assert= ] bi@ ] 2dip
[ [
{ {
@ -847,7 +841,7 @@ M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
} case } case
] ?if ; ] ?if ;
M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- ) M: ppc.64 %store-memory
[ [ 0 assert= ] bi@ ] 2dip [ [ 0 assert= ] bi@ ] 2dip
[ [
{ {
@ -914,7 +908,7 @@ M:: ppc %check-nursery-branch ( label size cc temp1 temp2 -- )
{ cc/<= [ 0 label BGT ] } { cc/<= [ 0 label BGT ] }
} case ; } case ;
M: ppc %call-gc ( gc-map -- ) M: ppc %call-gc
\ minor-gc %call gc-map-here ; \ minor-gc %call gc-map-here ;
M:: ppc %prologue ( stack-size -- ) 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 ) src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ; label branch1 branch2 (%branch) ;
M: ppc %spill ( src rep dst -- ) M: ppc %spill
n>> spill@ swap { n>> spill@ swap {
{ int-rep [ [ 1 ] dip %store-cell ] } { int-rep [ [ 1 ] dip %store-cell ] }
{ tagged-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 ] } { scalar-rep [ scratch-reg swap LI 1 scratch-reg STVX ] }
} case ; } case ;
M: ppc %reload ( dst rep src -- ) M: ppc %reload
n>> spill@ swap { n>> spill@ swap {
{ int-rep [ [ 1 ] dip %load-cell ] } { int-rep [ [ 1 ] dip %load-cell ] }
{ tagged-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 ] } { scalar-rep [ scratch-reg swap LI 1 scratch-reg LVX ] }
} case ; } case ;
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ; M: ppc immediate-arithmetic? -32768 32767 between? ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ; M: ppc immediate-bitwise? 0 65535 between? ;
M: ppc immediate-store? ( n -- ? ) immediate-comparand? ; M: ppc immediate-store? immediate-comparand? ;
M: ppc enable-cpu-features ( -- ) M: ppc enable-cpu-features
enable-float-intrinsics ; enable-float-intrinsics ;
USE: vocabs USE: vocabs

30
basis/cpu/x86/32/32.factor
View File

@ -26,18 +26,18 @@ M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ; M: x86.32 stack-reg ESP ;
M: x86.32 frame-reg EBP ; 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 -- ) M:: x86.32 %load-vector ( dst val rep -- )
dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ; 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 ; [ 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 ; [ 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 ; [ 0 MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %mark-card M: x86.32 %mark-card
@ -61,7 +61,7 @@ M: x86.32 vm-stack-space 16 ;
: save-vm-ptr ( n -- ) : save-vm-ptr ( n -- )
stack@ 0 MOV 0 rc-absolute-cell rel-vm ; 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 lookup-c-type
[ return-in-registers?>> ] [ return-in-registers?>> ]
[ heap-size { 1 2 4 8 } member? ] bi [ heap-size { 1 2 4 8 } member? ] bi
@ -87,7 +87,7 @@ M: x86.32 return-regs
M: x86.32 %prepare-jump M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ; 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 ] [ next-stack@ swap pick register? [ %copy ] [
{ {
{ int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] } { int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] }
@ -96,7 +96,7 @@ M: x86.32 %load-stack-param ( dst rep n -- )
} case } case
] if ; ] if ;
M: x86.32 %store-stack-param ( src rep n -- ) M: x86.32 %store-stack-param
stack@ swap pick register? [ swapd %copy ] [ stack@ swap pick register? [ swapd %copy ] [
{ {
{ int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] } { 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 dst ?spill-slot x87-insn execute
] if ; inline ] if ; inline
M: x86.32 %load-reg-param ( vreg rep reg -- ) M: x86.32 %load-reg-param
swap { swap {
{ int-rep [ int-rep %copy ] } { int-rep [ int-rep %copy ] }
{ float-rep [ drop \ FSTPS float-rep load-float-return ] } { 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 src ?spill-slot x87-insn execute
] if ; inline ] if ; inline
M: x86.32 %store-reg-param ( vreg rep reg -- ) M: x86.32 %store-reg-param
swap { swap {
{ int-rep [ swap int-rep %copy ] } { int-rep [ swap int-rep %copy ] }
{ float-rep [ drop \ FLDS float-rep store-float-return ] } { float-rep [ drop \ FLDS float-rep store-float-return ] }
{ double-rep [ drop \ FLDL double-rep store-float-return ] } { double-rep [ drop \ FLDL double-rep store-float-return ] }
} case ; } case ;
M: x86.32 %discard-reg-param ( rep reg -- ) M: x86.32 %discard-reg-param
drop { drop {
{ int-rep [ ] } { int-rep [ ] }
{ float-rep [ ST0 FSTP ] } { 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 M: x86.32 %c-invoke
[ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ; [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ;
M: x86.32 %begin-callback ( -- ) M: x86.32 %begin-callback
0 save-vm-ptr 0 save-vm-ptr
4 stack@ 0 MOV 4 stack@ 0 MOV
"begin_callback" f f %c-invoke ; "begin_callback" f f %c-invoke ;
M: x86.32 %end-callback ( -- ) M: x86.32 %end-callback
0 save-vm-ptr 0 save-vm-ptr
"end_callback" f f %c-invoke ; "end_callback" f f %c-invoke ;
@ -192,7 +192,7 @@ M: x86.32 %end-callback ( -- )
! MINGW ABI incompatibility disaster ! MINGW ABI incompatibility disaster
[ large-struct? ] [ mingw eq? os windows? not or ] bi* and ; [ 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 ) M:: x86.32 stack-cleanup ( stack-size return abi -- n )
! a) Functions which are stdcall/fastcall/thiscall have to ! a) Functions which are stdcall/fastcall/thiscall have to
@ -205,7 +205,7 @@ M:: x86.32 stack-cleanup ( stack-size return abi -- n )
[ 0 ] [ 0 ]
} cond ; } cond ;
M: x86.32 %cleanup ( n -- ) M: x86.32 %cleanup
[ ESP swap SUB ] unless-zero ; [ ESP swap SUB ] unless-zero ;
M: x86.32 %safepoint 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 struct-return-on-stack? os linux? not ;
M: x86.32 (cpuid) ( eax ecx regs -- ) M: x86.32 (cpuid)
void { uint uint void* } cdecl [ void { uint uint void* } cdecl [
! Save ds-reg, rs-reg ! Save ds-reg, rs-reg
EDI PUSH EDI PUSH

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

@ -40,16 +40,16 @@ M: x86.64 machine-registers
: vm-reg ( -- reg ) R13 ; inline : vm-reg ( -- reg ) R13 ; inline
: nv-reg ( -- reg ) RBX ; inline : nv-reg ( -- reg ) RBX ; inline
M: x86.64 %vm-field ( dst offset -- ) M: x86.64 %vm-field
[ vm-reg ] dip [+] MOV ; [ vm-reg ] dip [+] MOV ;
M:: x86.64 %load-vector ( dst val rep -- ) M:: x86.64 %load-vector ( dst val rep -- )
dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ; 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 ; [ vm-reg ] dip [+] swap MOV ;
M: x86.64 %vm-field-ptr ( dst offset -- ) M: x86.64 %vm-field-ptr
[ vm-reg ] dip [+] LEA ; [ vm-reg ] dip [+] LEA ;
M: x86.64 %prepare-jump 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 -- ) M:: x86.64 %store-reg-param ( vreg rep reg -- )
reg vreg rep %copy ; reg vreg rep %copy ;
M: x86.64 %discard-reg-param ( rep reg -- ) M: x86.64 %discard-reg-param
2drop ; 2drop ;
M:: x86.64 %unbox ( dst src func rep -- ) 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 [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip
gc-map-here ; gc-map-here ;
M: x86.64 %begin-callback ( -- ) M: x86.64 %begin-callback
param-reg-0 vm-reg MOV param-reg-0 vm-reg MOV
param-reg-1 0 MOV param-reg-1 0 MOV
"begin_callback" f f %c-invoke ; "begin_callback" f f %c-invoke ;
M: x86.64 %end-callback ( -- ) M: x86.64 %end-callback
param-reg-0 vm-reg MOV param-reg-0 vm-reg MOV
"end_callback" f f %c-invoke ; "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 struct-return-on-stack? f ;
M: x86.64 (cpuid) ( rax rcx regs -- ) M: x86.64 (cpuid)
void { uint uint void* } cdecl [ void { uint uint void* } cdecl [
RAX param-reg-0 MOV RAX param-reg-0 MOV
RCX param-reg-1 MOV RCX param-reg-1 MOV

6
basis/cpu/x86/64/unix/unix.factor
View File

@ -38,14 +38,14 @@ M: x86.64 reserved-stack-space 0 ;
] [ reps ] if ] [ reps ] if
] [ reps ] if ; ] [ reps ] if ;
M: x86.64 flatten-struct-type ( c-type -- seq ) M: x86.64 flatten-struct-type
dup heap-size 16 <= dup heap-size 16 <=
[ flatten-small-struct record-reg-reps ] [ [ flatten-small-struct record-reg-reps ] [
call-next-method unrecord-reg-reps call-next-method unrecord-reg-reps
[ first t f 3array ] map [ first t f 3array ] map
] if ; ] if ;
M: x86.64 return-struct-in-registers? ( c-type -- ? ) M: x86.64 return-struct-in-registers?
heap-size 2 cells <= ; heap-size 2 cells <= ;
M: x86.64 dummy-stack-params? f ; 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 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 [ second reg-class-of float-regs? ] count 8 min
[ EAX EAX XOR ] [ <byte> AL swap MOV ] if-zero ; [ EAX EAX XOR ] [ <byte> AL swap MOV ] if-zero ;

5
basis/cpu/x86/64/windows/windows.factor
View File

@ -13,7 +13,7 @@ M: x86.64 param-regs
M: x86.64 reserved-stack-space 4 cells ; 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? ; heap-size { 1 2 4 8 } member? ;
M: x86.64 value-struct? 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 dummy-fp-params? t ;
M: x86.64 %prepare-var-args ( reg-inputs -- ) M: x86.64 %prepare-var-args drop ;
drop ;

24
basis/cpu/x86/assembler/assembler.factor
View File

@ -338,7 +338,7 @@ M: immediate SBB { 0b011 t 0x80 } immediate-1/4 ;
M: operand SBB 0o030 2-operand ; M: operand SBB 0o030 2-operand ;
GENERIC: AND ( dst src -- ) GENERIC: AND ( dst src -- )
M: immediate AND ( dst src -- ) M: immediate AND
maybe-zero-extend { 0b100 t 0x80 } immediate-1/4 ; maybe-zero-extend { 0b100 t 0x80 } immediate-1/4 ;
M: operand AND 0o040 2-operand ; 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 ; M: operand XOR 0o060 2-operand ;
GENERIC: CMP ( dst src -- ) GENERIC: CMP ( dst src -- )
M: immediate CMP ( dst src -- ) M: immediate CMP { 0b111 t 0x80 } immediate-1/4 ;
{ 0b111 t 0x80 } immediate-1/4 ;
M: operand CMP 0o070 2-operand ; M: operand CMP 0o070 2-operand ;
GENERIC: TEST ( dst src -- ) GENERIC: TEST ( dst src -- )
M: immediate TEST ( dst src -- ) M: immediate TEST maybe-zero-extend { 0b0 t 0xf7 } immediate-4 ;
maybe-zero-extend { 0b0 t 0xf7 } immediate-4 ;
M: operand TEST 0o204 2-operand ; M: operand TEST 0o204 2-operand ;
: XCHG ( dst src -- ) 0o207 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) ; : BSR ( dst src -- ) { 0x0f 0xbd } (2-operand) ;
GENERIC: BT ( value n -- ) GENERIC: BT ( value n -- )
M: immediate BT ( value n -- ) { 0b100 t { 0x0f 0xba } } immediate-1* ; M: immediate BT { 0b100 t { 0x0f 0xba } } immediate-1* ;
M: operand BT ( value n -- ) swap { 0x0f 0xa3 } (2-operand) ; M: operand BT swap { 0x0f 0xa3 } (2-operand) ;
GENERIC: BTC ( value n -- ) GENERIC: BTC ( value n -- )
M: immediate BTC ( value n -- ) { 0b111 t { 0x0f 0xba } } immediate-1* ; M: immediate BTC { 0b111 t { 0x0f 0xba } } immediate-1* ;
M: operand BTC ( value n -- ) swap { 0x0f 0xbb } (2-operand) ; M: operand BTC swap { 0x0f 0xbb } (2-operand) ;
GENERIC: BTR ( value n -- ) GENERIC: BTR ( value n -- )
M: immediate BTR ( value n -- ) { 0b110 t { 0x0f 0xba } } immediate-1* ; M: immediate BTR { 0b110 t { 0x0f 0xba } } immediate-1* ;
M: operand BTR ( value n -- ) swap { 0x0f 0xb3 } (2-operand) ; M: operand BTR swap { 0x0f 0xb3 } (2-operand) ;
GENERIC: BTS ( value n -- ) GENERIC: BTS ( value n -- )
M: immediate BTS ( value n -- ) { 0b101 t { 0x0f 0xba } } immediate-1* ; M: immediate BTS { 0b101 t { 0x0f 0xba } } immediate-1* ;
M: operand BTS ( value n -- ) swap { 0x0f 0xab } (2-operand) ; M: operand BTS swap { 0x0f 0xab } (2-operand) ;
: NOT ( dst -- ) { 0b010 t 0xf7 } 1-operand ; : NOT ( dst -- ) { 0b010 t 0xf7 } 1-operand ;
: NEG ( dst -- ) { 0b011 t 0xf7 } 1-operand ; : NEG ( dst -- ) { 0b011 t 0xf7 } 1-operand ;

74
basis/cpu/x86/sse/sse.factor
View File

@ -35,16 +35,16 @@ M: x86 integer-float-needs-stack-frame? f ;
M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ; M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ;
M: x86 %float>integer CVTTSD2SI ; M: x86 %float>integer CVTTSD2SI ;
M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- ) M: x86 %compare-float-ordered
[ COMISD ] (%compare-float) ; [ COMISD ] (%compare-float) ;
M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- ) M: x86 %compare-float-unordered
[ UCOMISD ] (%compare-float) ; [ UCOMISD ] (%compare-float) ;
M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- ) M: x86 %compare-float-ordered-branch
[ COMISD ] (%compare-float-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) ; [ UCOMISD ] (%compare-float-branch) ;
! SIMD ! SIMD
@ -262,7 +262,7 @@ M: x86 %shuffle-vector-halves-imm-reps
{ sse2? { double-2-rep } } { sse2? { double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %shuffle-vector ( dst src shuffle rep -- ) M: x86 %shuffle-vector
two-operand PSHUFB ; two-operand PSHUFB ;
M: x86 %shuffle-vector-reps M: x86 %shuffle-vector-reps
@ -331,14 +331,14 @@ M: x86 %unsigned-pack-vector-reps
{ sse4.1? { int-4-rep } } { sse4.1? { int-4-rep } }
} available-reps ; } available-reps ;
M: x86 %tail>head-vector ( dst src rep -- ) M: x86 %tail>head-vector
dup { dup {
{ float-4-rep [ drop UNPCKHPD ] } { float-4-rep [ drop UNPCKHPD ] }
{ double-2-rep [ drop UNPCKHPD ] } { double-2-rep [ drop UNPCKHPD ] }
[ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ] [ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ]
} case ; } case ;
M: x86 %unpack-vector-head ( dst src rep -- ) M: x86 %unpack-vector-head
{ {
{ char-16-rep [ PMOVSXBW ] } { char-16-rep [ PMOVSXBW ] }
{ uchar-16-rep [ PMOVZXBW ] } { uchar-16-rep [ PMOVZXBW ] }
@ -349,13 +349,13 @@ M: x86 %unpack-vector-head ( dst src rep -- )
{ float-4-rep [ CVTPS2PD ] } { float-4-rep [ CVTPS2PD ] }
} case ; } case ;
M: x86 %unpack-vector-head-reps ( -- reps ) M: x86 %unpack-vector-head-reps
{ {
{ sse2? { float-4-rep } } { sse2? { float-4-rep } }
{ sse4.1? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } } { sse4.1? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ; } available-reps ;
M: x86 %integer>float-vector ( dst src rep -- ) M: x86 %integer>float-vector
{ {
{ int-4-rep [ CVTDQ2PS ] } { int-4-rep [ CVTDQ2PS ] }
} case ; } case ;
@ -365,7 +365,7 @@ M: x86 %integer>float-vector-reps
{ sse2? { int-4-rep } } { sse2? { int-4-rep } }
} available-reps ; } available-reps ;
M: x86 %float>integer-vector ( dst src rep -- ) M: x86 %float>integer-vector
{ {
{ float-4-rep [ CVTTPS2DQ ] } { float-4-rep [ CVTTPS2DQ ] }
} case ; } case ;
@ -405,7 +405,7 @@ M: x86 %float>integer-vector-reps
{ cc> [ [ PCMPGTQ ] [ PCMPGTD ] [ PCMPGTW ] [ PCMPGTB ] (%compare-int-vector) ] } { cc> [ [ PCMPGTQ ] [ PCMPGTD ] [ PCMPGTW ] [ PCMPGTB ] (%compare-int-vector) ] }
} case ; } case ;
M: x86 %compare-vector ( dst src1 src2 rep cc -- ) M: x86 %compare-vector
[ [ two-operand ] keep ] dip [ [ two-operand ] keep ] dip
over float-vector-rep? over float-vector-rep?
[ %compare-float-vector ] [ %compare-float-vector ]
@ -481,7 +481,7 @@ M: x86 %compare-vector-ccs
[ drop PMOVMSKB 0xffff ] [ drop PMOVMSKB 0xffff ]
} case ; } case ;
M: x86 %move-vector-mask ( dst src rep -- ) M: x86 %move-vector-mask
(%move-vector-mask) drop ; (%move-vector-mask) drop ;
M: x86 %move-vector-mask-reps 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 } } { 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 ; } available-reps ;
M: x86 %add-vector ( dst src1 src2 rep -- ) M: x86 %add-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ADDPS ] } { 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 } } { 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 ; } available-reps ;
M: x86 %saturated-add-vector ( dst src1 src2 rep -- ) M: x86 %saturated-add-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PADDSB ] } { 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 } } { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
} available-reps ; } available-reps ;
M: x86 %add-sub-vector ( dst src1 src2 rep -- ) M: x86 %add-sub-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ADDSUBPS ] } { float-4-rep [ ADDSUBPS ] }
@ -559,7 +559,7 @@ M: x86 %add-sub-vector-reps
{ sse3? { float-4-rep double-2-rep } } { sse3? { float-4-rep double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %sub-vector ( dst src1 src2 rep -- ) M: x86 %sub-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ SUBPS ] } { 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 } } { 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 ; } available-reps ;
M: x86 %saturated-sub-vector ( dst src1 src2 rep -- ) M: x86 %saturated-sub-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PSUBSB ] } { 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 } } { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep } }
} available-reps ; } available-reps ;
M: x86 %mul-vector ( dst src1 src2 rep -- ) M: x86 %mul-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ MULPS ] } { float-4-rep [ MULPS ] }
@ -612,7 +612,7 @@ M: x86 %mul-vector-reps
{ sse4.1? { int-4-rep uint-4-rep } } { sse4.1? { int-4-rep uint-4-rep } }
} available-reps ; } available-reps ;
M: x86 %mul-high-vector ( dst src1 src2 rep -- ) M: x86 %mul-high-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ short-8-rep [ PMULHW ] } { short-8-rep [ PMULHW ] }
@ -624,7 +624,7 @@ M: x86 %mul-high-vector-reps
{ sse2? { short-8-rep ushort-8-rep } } { sse2? { short-8-rep ushort-8-rep } }
} available-reps ; } available-reps ;
M: x86 %mul-horizontal-add-vector ( dst src1 src2 rep -- ) M: x86 %mul-horizontal-add-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PMADDUBSW ] } { char-16-rep [ PMADDUBSW ] }
@ -638,7 +638,7 @@ M: x86 %mul-horizontal-add-vector-reps
{ ssse3? { char-16-rep uchar-16-rep } } { ssse3? { char-16-rep uchar-16-rep } }
} available-reps ; } available-reps ;
M: x86 %div-vector ( dst src1 src2 rep -- ) M: x86 %div-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ DIVPS ] } { float-4-rep [ DIVPS ] }
@ -651,7 +651,7 @@ M: x86 %div-vector-reps
{ sse2? { double-2-rep } } { sse2? { double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %min-vector ( dst src1 src2 rep -- ) M: x86 %min-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PMINSB ] } { 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 } } { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ; } available-reps ;
M: x86 %max-vector ( dst src1 src2 rep -- ) M: x86 %max-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ char-16-rep [ PMAXSB ] } { 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 } } { sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ; } available-reps ;
M: x86 %avg-vector ( dst src1 src2 rep -- ) M: x86 %avg-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ uchar-16-rep [ PAVGB ] } { uchar-16-rep [ PAVGB ] }
@ -726,7 +726,7 @@ M: x86 %sad-vector-reps
{ sse2? { uchar-16-rep } } { sse2? { uchar-16-rep } }
} available-reps ; } available-reps ;
M: x86 %horizontal-add-vector ( dst src1 src2 rep -- ) M: x86 %horizontal-add-vector
[ two-operand ] keep [ two-operand ] keep
signed-rep { signed-rep {
{ float-4-rep [ HADDPS ] } { 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 } } { ssse3? { int-4-rep uint-4-rep short-8-rep ushort-8-rep } }
} available-reps ; } available-reps ;
M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- ) M: x86 %horizontal-shl-vector-imm
two-operand PSLLDQ ; two-operand PSLLDQ ;
M: x86 %horizontal-shl-vector-imm-reps 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 } } { 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 ; } available-reps ;
M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- ) M: x86 %horizontal-shr-vector-imm
two-operand PSRLDQ ; two-operand PSRLDQ ;
M: x86 %horizontal-shr-vector-imm-reps 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 } } { 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 ; } available-reps ;
M: x86 %abs-vector ( dst src rep -- ) M: x86 %abs-vector
{ {
{ char-16-rep [ PABSB ] } { char-16-rep [ PABSB ] }
{ short-8-rep [ PABSW ] } { short-8-rep [ PABSW ] }
@ -769,7 +769,7 @@ M: x86 %abs-vector-reps
{ ssse3? { char-16-rep short-8-rep int-4-rep } } { ssse3? { char-16-rep short-8-rep int-4-rep } }
} available-reps ; } available-reps ;
M: x86 %sqrt-vector ( dst src rep -- ) M: x86 %sqrt-vector
{ {
{ float-4-rep [ SQRTPS ] } { float-4-rep [ SQRTPS ] }
{ double-2-rep [ SQRTPD ] } { double-2-rep [ SQRTPD ] }
@ -781,7 +781,7 @@ M: x86 %sqrt-vector-reps
{ sse2? { double-2-rep } } { sse2? { double-2-rep } }
} available-reps ; } available-reps ;
M: x86 %and-vector ( dst src1 src2 rep -- ) M: x86 %and-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ANDPS ] } { 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 } } { 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 ; } available-reps ;
M: x86 %andn-vector ( dst src1 src2 rep -- ) M: x86 %andn-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ANDNPS ] } { 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 } } { 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 ; } available-reps ;
M: x86 %or-vector ( dst src1 src2 rep -- ) M: x86 %or-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ ORPS ] } { 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 } } { 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 ; } available-reps ;
M: x86 %xor-vector ( dst src1 src2 rep -- ) M: x86 %xor-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ float-4-rep [ XORPS ] } { 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 } } { 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 ; } available-reps ;
M: x86 %shl-vector ( dst src1 src2 rep -- ) M: x86 %shl-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ short-8-rep [ PSLLW ] } { 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 } } { sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ; } available-reps ;
M: x86 %shr-vector ( dst src1 src2 rep -- ) M: x86 %shr-vector
[ two-operand ] keep [ two-operand ] keep
{ {
{ short-8-rep [ PSRAW ] } { short-8-rep [ PSRAW ] }
@ -911,9 +911,9 @@ M: x86 %integer>scalar drop MOVD ;
] } ] }
} case ; } 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 ] } { longlong-scalar-rep [ MOVD ] }
{ ulonglong-scalar-rep [ MOVD ] } { ulonglong-scalar-rep [ MOVD ] }

75
basis/cpu/x86/x86.factor
View File

@ -46,7 +46,7 @@ HOOK: pic-tail-reg cpu ( -- reg )
: align-stack ( n -- n' ) 16 align ; : align-stack ( n -- n' ) 16 align ;
M: x86 stack-frame-size ( stack-frame -- i ) M: x86 stack-frame-size
(stack-frame-size) (stack-frame-size)
reserved-stack-space + reserved-stack-space +
cell + cell +
@ -60,7 +60,7 @@ M: x86 test-instruction? t ;
M: x86 immediate-store? immediate-comparand? ; 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 ; { fixnum } declare [ 32-bit-version-of dup XOR ] [ MOV ] if-zero ;
M: x86 %load-reference M: x86 %load-reference
@ -90,13 +90,13 @@ M: x86 %replace-imm
[ [ 0 MOV ] dip rc-absolute rel-literal ] [ [ 0 MOV ] dip rc-absolute rel-literal ]
} cond ; } cond ;
M: x86 %clear ( loc -- ) M: x86 %clear
297 swap %replace-imm ; 297 swap %replace-imm ;
M: x86 %inc ( loc -- ) M: x86 %inc
[ n>> ] [ ds-loc? ds-reg rs-reg ? ] bi (%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 ) : xt-tail-pic-offset ( -- n )
! See the comment in vm/cpu-x86.hpp ! 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 ( -- ) HOOK: %prepare-jump cpu ( -- )
M: x86 %jump ( word -- ) M: x86 %jump
%prepare-jump %prepare-jump
0 JMP rc-relative rel-word-pic-tail ; 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 <indirect> ; inline : (%slot) ( obj slot scale tag -- op ) neg <indirect> ; inline
: (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline : (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline
M: x86 %slot ( dst obj slot scale tag -- ) (%slot) MOV ; M: x86 %slot (%slot) MOV ;
M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ; M: x86 %slot-imm (%slot-imm) MOV ;
M: x86 %set-slot ( src obj slot scale tag -- ) (%slot) swap MOV ; M: x86 %set-slot (%slot) swap MOV ;
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ; M: x86 %set-slot-imm (%slot-imm) swap MOV ;
:: two-operand ( dst src1 src2 rep -- dst src ) :: two-operand ( dst src1 src2 rep -- dst src )
dst src2 eq? dst src1 eq? not and [ "Cannot handle this case" throw ] when 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 dst ; inline
M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ; M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %add-imm ( dst src1 src2 -- ) M: x86 %add-imm
2over eq? [ 2over eq? [
nip { { 1 [ INC ] } { -1 [ DEC ] } [ ADD ] } case nip { { 1 [ INC ] } { -1 [ DEC ] } [ ADD ] } case
] [ [+] LEA ] if ; ] [ [+] LEA ] if ;
M: x86 %sub int-rep two-operand SUB ; M: x86 %sub int-rep two-operand SUB ;
M: x86 %sub-imm ( dst src1 src2 -- ) M: x86 %sub-imm
2over eq? [ 2over eq? [
nip { { 1 [ DEC ] } { -1 [ INC ] } [ SUB ] } case nip { { 1 [ DEC ] } { -1 [ INC ] } [ SUB ] } case
] [ neg [+] LEA ] if ; ] [ neg [+] LEA ] if ;
@ -173,7 +173,7 @@ M: object copy-memory* copy-register* ;
: ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ; : ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ;
M: x86 %copy ( dst src rep -- ) M: x86 %copy
2over eq? [ 3drop ] [ 2over eq? [ 3drop ] [
[ [ ?spill-slot ] bi@ ] dip [ [ ?spill-slot ] bi@ ] dip
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if 2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
@ -186,16 +186,16 @@ M: x86 %copy ( dst src rep -- )
{ cc/o [ JNO ] } { cc/o [ JNO ] }
} case ; inline } case ; inline
M: x86 %fixnum-add ( label dst src1 src2 cc -- ) M: x86 %fixnum-add
[ ADD ] fixnum-overflow ; [ ADD ] fixnum-overflow ;
M: x86 %fixnum-sub ( label dst src1 src2 cc -- ) M: x86 %fixnum-sub
[ SUB ] fixnum-overflow ; [ SUB ] fixnum-overflow ;
M: x86 %fixnum-mul ( label dst src1 src2 cc -- ) M: x86 %fixnum-mul
[ IMUL2 ] fixnum-overflow ; [ IMUL2 ] fixnum-overflow ;
M: x86 %unbox-alien ( dst src -- ) M: x86 %unbox-alien
alien-offset [+] MOV ; alien-offset [+] MOV ;
M:: x86 %unbox-any-c-ptr ( dst src -- ) 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 -- ) : %sign-extend ( dst src bits -- )
[ MOVSX ] (%convert-integer) ; inline [ MOVSX ] (%convert-integer) ; inline
M: x86 %convert-integer ( dst src c-type -- ) M: x86 %convert-integer
{ {
{ c:char [ 8 %sign-extend ] } { c:char [ 8 %sign-extend ] }
{ c:uchar [ 8 %zero-extend ] } { c:uchar [ 8 %zero-extend ] }
@ -411,10 +411,10 @@ M: x86 %convert-integer ( dst src c-type -- )
} case } case
] [ nipd %copy ] ?if ; ] [ nipd %copy ] ?if ;
M: x86 %load-memory ( dst base displacement scale offset rep c-type -- ) M: x86 %load-memory
(%memory) (%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) ; (%memory-imm) (%load-memory) ;
: (%store-memory) ( src exclude address rep c-type -- ) : (%store-memory) ( src exclude address rep c-type -- )
@ -429,10 +429,10 @@ M: x86 %load-memory-imm ( dst base offset rep c-type -- )
} case } case
] [ [ nip swap ] dip %copy ] ?if ; ] [ [ nip swap ] dip %copy ] ?if ;
M: x86 %store-memory ( src base displacement scale offset rep c-type -- ) M: x86 %store-memory
(%memory) (%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) ; (%memory-imm) (%store-memory) ;
: shift-count? ( reg -- ? ) { ECX RCX } member-eq? ; : 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 M: x86 gc-root-offset
n>> spill-offset special-offset cell + cell /i ; n>> spill-offset special-offset cell + cell /i ;
M: x86 %call-gc ( gc-map -- ) M: x86 %call-gc
\ minor-gc %call \ minor-gc %call
gc-map-here ; gc-map-here ;
M: x86 %alien-global ( dst symbol library -- ) M: x86 %alien-global
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ; [ 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 -- ) :: (%boolean) ( dst temp insn -- )
dst \ f type-number MOV dst \ f type-number MOV
@ -610,10 +610,10 @@ M:: x86 %dispatch ( src temp -- )
[ (align-code) ] [ (align-code) ]
bi ; bi ;
M: x86 %spill ( src rep dst -- ) M: x86 %spill
-rot %copy ; -rot %copy ;
M: x86 %reload ( dst rep src -- ) M: x86 %reload
swap %copy ; swap %copy ;
M:: x86 %local-allot ( dst size align offset -- ) 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 reg-outputs [ first3 %load-reg-param ] each
dead-outputs [ first2 %discard-reg-param ] each ; dead-outputs [ first2 %discard-reg-param ] each ;
M: x86 %alien-invoke ( varargs? reg-inputs stack-inputs M: x86 %alien-invoke
reg-outputs dead-outputs
cleanup stack-size
symbols dll gc-map -- )
'[ _ _ _ %c-invoke ] %alien-assembly ; '[ _ _ _ %c-invoke ] %alien-assembly ;
M:: x86 %alien-indirect ( src M:: x86 %alien-indirect ( src
@ -681,14 +678,14 @@ M:: x86 %alien-indirect ( src
HOOK: %begin-callback cpu ( -- ) HOOK: %begin-callback cpu ( -- )
M: x86 %callback-inputs ( reg-outputs stack-outputs -- ) M: x86 %callback-inputs
[ [ first3 %load-reg-param ] each ] [ [ first3 %load-reg-param ] each ]
[ [ first3 %load-stack-param ] each ] bi* [ [ first3 %load-stack-param ] each ] bi*
%begin-callback ; %begin-callback ;
HOOK: %end-callback cpu ( -- ) HOOK: %end-callback cpu ( -- )
M: x86 %callback-outputs ( reg-inputs -- ) M: x86 %callback-outputs
%end-callback %end-callback
[ first3 %store-reg-param ] each ; [ 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 float-right-align-on-stack? f ;
M: x86 immediate-arithmetic? ( n -- ? ) M: x86 immediate-arithmetic?
-0x80000000 0x7fffffff between? ; -0x80000000 0x7fffffff between? ;
M: x86 immediate-bitwise? ( n -- ? ) M: x86 immediate-bitwise?
-0x80000000 0x7fffffff between? ; -0x80000000 0x7fffffff between? ;
:: %cmov-float= ( dst src -- ) :: %cmov-float= ( dst src -- )
@ -778,7 +775,7 @@ M:: x86 %bit-test ( dst src1 src2 temp -- )
src1 src2 BT src1 src2 BT
dst temp \ CMOVB (%boolean) ; dst temp \ CMOVB (%boolean) ;
M: x86 enable-cpu-features ( -- ) M: x86 enable-cpu-features
enable-min/max enable-min/max
enable-log2 enable-log2
enable-bit-test enable-bit-test

8
basis/cpu/x86/x87/x87.factor
View File

@ -86,14 +86,14 @@ M:: x86 %float>integer ( dst src -- )
src2 shuffle-down quot call src2 shuffle-down quot call
ST0 FSTP ; inline ST0 FSTP ; inline
M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- ) M: x86 %compare-float-ordered
[ [ FCOMI ] compare-op ] (%compare-float) ; [ [ 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) ; [ [ 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) ; [ [ 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) ; [ [ FUCOMI ] compare-op ] (%compare-float-branch) ;

10
basis/db/db.factor
View File

@ -26,7 +26,7 @@ HOOK: parse-db-error db-connection ( error -- error' )
: dispose-statements ( assoc -- ) values dispose-each ; : dispose-statements ( assoc -- ) values dispose-each ;
M: db-connection dispose ( db-connection -- ) M: db-connection dispose
dup db-connection [ dup db-connection [
[ dispose-statements H{ } clone ] change-insert-statements [ dispose-statements H{ } clone ] change-insert-statements
[ dispose-statements H{ } clone ] change-update-statements [ dispose-statements H{ } clone ] change-update-statements
@ -76,7 +76,7 @@ GENERIC: bind-tuple ( tuple statement -- )
GENERIC: execute-statement* ( statement type -- ) GENERIC: execute-statement* ( statement type -- )
M: object execute-statement* ( statement type -- ) M: object execute-statement*
'[ '[
_ _ drop query-results dispose _ _ drop query-results dispose
] [ ] [
@ -138,9 +138,9 @@ HOOK: begin-transaction db-connection ( -- )
HOOK: commit-transaction db-connection ( -- ) HOOK: commit-transaction db-connection ( -- )
HOOK: rollback-transaction db-connection ( -- ) HOOK: rollback-transaction db-connection ( -- )
M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ; M: db-connection begin-transaction "BEGIN" sql-command ;
M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ; M: db-connection commit-transaction "COMMIT" sql-command ;
M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ; M: db-connection rollback-transaction "ROLLBACK" sql-command ;
: in-transaction? ( -- ? ) in-transaction get ; : in-transaction? ( -- ? ) in-transaction get ;

2
basis/db/pools/pools.factor
View File

@ -13,7 +13,7 @@ TUPLE: db-pool < pool db ;
: with-db-pool ( db quot -- ) : with-db-pool ( db quot -- )
[ <db-pool> ] dip with-pool ; inline [ <db-pool> ] dip with-pool ; inline
M: db-pool make-connection ( pool -- conn ) M: db-pool make-connection
db>> db-open ; db>> db-open ;
: with-pooled-db ( pool quot -- ) : with-pooled-db ( pool quot -- )

4
basis/db/postgresql/lib/lib.factor
View File

@ -31,7 +31,7 @@ IN: db.postgresql.lib
ERROR: postgresql-result-null ; ERROR: postgresql-result-null ;
M: postgresql-result-null summary ( obj -- str ) M: postgresql-result-null summary
drop "PQexec returned f." ; drop "PQexec returned f." ;
: postgresql-result-ok? ( res -- ? ) : postgresql-result-ok? ( res -- ? )
@ -126,7 +126,7 @@ M: postgresql-result-null summary ( obj -- str )
TUPLE: postgresql-malloc-destructor alien ; TUPLE: postgresql-malloc-destructor alien ;
C: <postgresql-malloc-destructor> postgresql-malloc-destructor C: <postgresql-malloc-destructor> postgresql-malloc-destructor
M: postgresql-malloc-destructor dispose ( obj -- ) M: postgresql-malloc-destructor dispose
alien>> PQfreemem ; alien>> PQfreemem ;
: &postgresql-free ( alien -- alien ) : &postgresql-free ( alien -- alien )

56
basis/db/postgresql/postgresql.factor
View File

@ -25,7 +25,7 @@ TUPLE: postgresql-statement < statement ;
TUPLE: postgresql-result-set < result-set ; TUPLE: postgresql-result-set < result-set ;
M: postgresql-db db-open ( db -- db-connection ) M: postgresql-db db-open
{ {
[ host>> ] [ host>> ]
[ port>> ] [ port>> ]
@ -36,46 +36,46 @@ M: postgresql-db db-open ( db -- db-connection )
[ password>> ] [ password>> ]
} cleave connect-postgres <postgresql-db-connection> ; } cleave connect-postgres <postgresql-db-connection> ;
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 ) 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 <low-level-binding> ; slot-name>> swap get-slot-named <low-level-binding> ;
M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object ) M: literal-bind postgresql-bind-conversion
nip value>> <low-level-binding> ; nip value>> <low-level-binding> ;
M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object ) M: generator-bind postgresql-bind-conversion
dup generator-singleton>> eval-generator dup generator-singleton>> eval-generator
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ; [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
M: postgresql-statement bind-tuple ( tuple statement -- ) M: postgresql-statement bind-tuple
[ nip ] [ [ nip ] [
in-params>> in-params>>
[ postgresql-bind-conversion ] with map [ postgresql-bind-conversion ] with map
] 2bi ] 2bi
>>bind-params drop ; >>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n ) M: postgresql-result-set #rows
handle>> PQntuples ; handle>> PQntuples ;
M: postgresql-result-set #columns ( result-set -- n ) M: postgresql-result-set #columns
handle>> PQnfields ; handle>> PQnfields ;
: result-handle-n ( result-set -- handle n ) : result-handle-n ( result-set -- handle n )
[ handle>> ] [ n>> ] bi ; [ 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 ; [ 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>> dup pick out-params>> nth type>>
[ result-handle-n ] 2dip postgresql-column-typed ; [ result-handle-n ] 2dip postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set ) M: postgresql-statement query-results
dup bind-params>> [ dup bind-params>> [
over [ bind-statement ] keep over [ bind-statement ] keep
do-postgresql-bound-statement do-postgresql-bound-statement
@ -85,17 +85,17 @@ M: postgresql-statement query-results ( query -- result-set )
postgresql-result-set new-result-set postgresql-result-set new-result-set
dup init-result-set ; dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- ) M: postgresql-result-set advance-row
[ 1 + ] change-n drop ; [ 1 + ] change-n drop ;
M: postgresql-result-set more-rows? ( result-set -- ? ) M: postgresql-result-set more-rows?
[ n>> ] [ max>> ] bi < ; [ n>> ] [ max>> ] bi < ;
M: postgresql-statement dispose ( query -- ) M: postgresql-statement dispose
dup handle>> PQclear dup handle>> PQclear
f >>handle drop ; f >>handle drop ;
M: postgresql-result-set dispose ( result-set -- ) M: postgresql-result-set dispose
[ handle>> PQclear ] [ handle>> PQclear ]
[ [
0 >>n 0 >>n
@ -103,27 +103,27 @@ M: postgresql-result-set dispose ( result-set -- )
f >>handle drop f >>handle drop
] bi ; ] bi ;
M: postgresql-statement prepare-statement ( statement -- ) M: postgresql-statement prepare-statement
dup dup
[ db-connection get handle>> f ] dip [ db-connection get handle>> f ] dip
[ sql>> ] [ in-params>> ] bi [ sql>> ] [ in-params>> ] bi
length f PQprepare postgresql-error length f PQprepare postgresql-error
>>handle drop ; >>handle drop ;
M: postgresql-db-connection <simple-statement> ( sql in out -- statement ) M: postgresql-db-connection <simple-statement>
postgresql-statement new-statement ; postgresql-statement new-statement ;
M: postgresql-db-connection <prepared-statement> ( sql in out -- statement ) M: postgresql-db-connection <prepared-statement>
<simple-statement> dup prepare-statement ; <simple-statement> dup prepare-statement ;
: bind-name% ( -- ) : bind-name% ( -- )
CHAR: $ 0, CHAR: $ 0,
sql-counter [ inc ] [ get 0# ] bi ; sql-counter [ inc ] [ get 0# ] bi ;
M: postgresql-db-connection bind% ( spec -- ) M: postgresql-db-connection bind%
bind-name% 1, ; bind-name% 1, ;
M: postgresql-db-connection bind# ( spec object -- ) M: postgresql-db-connection bind#
[ bind-name% f swap type>> ] dip [ bind-name% f swap type>> ] dip
<literal-bind> 1, ; <literal-bind> 1, ;
@ -169,7 +169,7 @@ M: postgresql-db-connection bind# ( spec object -- )
"_seq'');' language sql;" 0% "_seq'');' language sql;" 0%
] query-make ; ] query-make ;
M: postgresql-db-connection create-sql-statement ( class -- seq ) M: postgresql-db-connection create-sql-statement
[ [
[ create-table-sql , ] keep [ create-table-sql , ] keep
dup db-assigned? [ create-function-sql , ] [ drop ] if 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 "drop table " 0% 0% drop
] query-make ; ] query-make ;
M: postgresql-db-connection drop-sql-statement ( class -- seq ) M: postgresql-db-connection drop-sql-statement
[ [
[ drop-table-sql , ] keep [ drop-table-sql , ] keep
dup db-assigned? [ drop-function-sql , ] [ drop ] if dup db-assigned? [ drop-function-sql , ] [ drop ] if
] { } make ; ] { } make ;
M: postgresql-db-connection <insert-db-assigned-statement> ( class -- statement ) M: postgresql-db-connection <insert-db-assigned-statement>
[ [
"select add_" 0% 0% "select add_" 0% 0%
"(" 0% "(" 0%
@ -205,7 +205,7 @@ M: postgresql-db-connection <insert-db-assigned-statement> ( class -- statement
");" 0% ");" 0%
] query-make ; ] query-make ;
M: postgresql-db-connection <insert-user-assigned-statement> ( class -- statement ) M: postgresql-db-connection <insert-user-assigned-statement>
[ [
"insert into " 0% 0% "insert into " 0% 0%
"(" 0% "(" 0%
@ -228,10 +228,10 @@ M: postgresql-db-connection <insert-user-assigned-statement> ( class -- statemen
");" 0% ");" 0%
] query-make ; ] query-make ;
M: postgresql-db-connection insert-tuple-set-key ( tuple statement -- ) M: postgresql-db-connection insert-tuple-set-key
query-modify-tuple ; query-modify-tuple ;
M: postgresql-db-connection persistent-table ( -- hashtable ) M: postgresql-db-connection persistent-table
H{ H{
{ +db-assigned-id+ { "integer" "serial" f } } { +db-assigned-id+ { "integer" "serial" f } }
{ +user-assigned-id+ { f f f } } { +user-assigned-id+ { f f f } }
@ -271,7 +271,7 @@ M: postgresql-db-connection persistent-table ( -- hashtable )
} ; } ;
ERROR: no-compound-found string object ; ERROR: no-compound-found string object ;
M: postgresql-db-connection compound ( string object -- string' ) M: postgresql-db-connection compound
over { over {
{ "default" [ first number>string " " glue ] } { "default" [ first number>string " " glue ] }
{ "varchar" [ first number>string "(" ")" surround append ] } { "varchar" [ first number>string "(" ")" surround append ] }

28
basis/db/queries/queries.factor
View File

@ -33,7 +33,7 @@ SINGLETON: retryable
] if ] if
] 2map >>bind-params ; ] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- ) M: retryable execute-statement*
drop [ retries>> <iota> ] [ drop [ retries>> <iota> ] [
[ [
nip nip
@ -62,7 +62,7 @@ M: retryable execute-statement* ( statement type -- )
dup column-name>> 0% " = " 0% bind% dup column-name>> 0% " = " 0% bind%
] interleave ; ] interleave ;
M: db-connection <update-tuple-statement> ( class -- statement ) M: db-connection <update-tuple-statement>
[ [
"update " 0% 0% "update " 0% 0%
" set " 0% " set " 0%
@ -71,7 +71,7 @@ M: db-connection <update-tuple-statement> ( class -- statement )
where-primary-key% where-primary-key%
] query-make ; ] query-make ;
M: random-id-generator eval-generator ( singleton -- obj ) M: random-id-generator eval-generator
drop drop
system-random-generator get [ system-random-generator get [
63 [ random-bits ] keep 1 - set-bit 63 [ random-bits ] keep 1 - set-bit
@ -102,32 +102,32 @@ M: random-id-generator eval-generator ( singleton -- obj )
: in-parens ( quot -- ) : in-parens ( quot -- )
"(" 0% call ")" 0% ; inline "(" 0% call ")" 0% ; inline
M: interval where ( spec obj -- ) M: interval where
[ [
[ from>> "from" where-interval ] [ [ from>> "from" where-interval ] [
nip infinite-interval? [ " and " 0% ] unless nip infinite-interval? [ " and " 0% ] unless
] [ to>> "to" where-interval ] 2tri ] [ to>> "to" where-interval ] 2tri
] in-parens ; ] in-parens ;
M: sequence where ( spec obj -- ) M: sequence where
[ [
[ " or " 0% ] [ dupd where ] interleave drop [ " or " 0% ] [ dupd where ] interleave drop
] in-parens ; ] in-parens ;
M: byte-array where ( spec obj -- ) M: byte-array where
over column-name>> 0% " = " 0% bind# ; over column-name>> 0% " = " 0% bind# ;
M: NULL where ( spec obj -- ) M: NULL where
drop column-name>> 0% " is NULL" 0% ; drop column-name>> 0% " is NULL" 0% ;
: object-where ( spec obj -- ) : object-where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ; 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' ) : filter-slots ( tuple specs -- specs' )
[ [
@ -145,7 +145,7 @@ M: string where ( spec obj -- ) object-where ;
: where-clause ( tuple specs -- ) : where-clause ( tuple specs -- )
dupd filter-slots [ drop ] [ many-where ] if-empty ; dupd filter-slots [ drop ] [ many-where ] if-empty ;
M: db-connection <delete-tuples-statement> ( tuple table -- sql ) M: db-connection <delete-tuples-statement>
[ [
"delete from " 0% 0% "delete from " 0% 0%
where-clause where-clause
@ -153,7 +153,7 @@ M: db-connection <delete-tuples-statement> ( tuple table -- sql )
ERROR: all-slots-ignored class ; ERROR: all-slots-ignored class ;
M: db-connection <select-by-slots-statement> ( tuple class -- statement ) M: db-connection <select-by-slots-statement>
[ [
"select " 0% "select " 0%
[ dupd filter-ignores ] dip [ dupd filter-ignores ] dip
@ -188,13 +188,13 @@ M: db-connection <select-by-slots-statement> ( tuple class -- statement )
[ offset>> [ do-offset ] [ drop ] if* ] [ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ; } 2cleave ;
M: db-connection query>statement ( query -- tuple ) M: db-connection query>statement
[ tuple>> dup class-of ] keep [ tuple>> dup class-of ] keep
[ <select-by-slots-statement> ] dip make-query* ; [ <select-by-slots-statement> ] dip make-query* ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
M: db-connection <count-statement> ( query -- statement ) M: db-connection <count-statement>
[ tuple>> dup class-of ] keep [ tuple>> dup class-of ] keep
[ [ "select count(*) from " 0% 0% where-clause ] query-make ] [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
dip make-query* ; dip make-query* ;

52
basis/db/sqlite/sqlite.factor
View File

@ -22,19 +22,19 @@ TUPLE: sqlite-db-connection < db-connection ;
PRIVATE> PRIVATE>
M: sqlite-db db-open ( db -- db-connection ) M: sqlite-db db-open
path>> sqlite-open <sqlite-db-connection> ; path>> sqlite-open <sqlite-db-connection> ;
M: sqlite-db-connection db-close ( handle -- ) sqlite-close ; M: sqlite-db-connection db-close sqlite-close ;
TUPLE: sqlite-statement < statement ; TUPLE: sqlite-statement < statement ;
TUPLE: sqlite-result-set < result-set has-more? ; TUPLE: sqlite-result-set < result-set has-more? ;
M: sqlite-db-connection <simple-statement> ( str in out -- obj ) M: sqlite-db-connection <simple-statement>
<prepared-statement> ; <prepared-statement> ;
M: sqlite-db-connection <prepared-statement> ( str in out -- obj ) M: sqlite-db-connection <prepared-statement>
sqlite-statement new-statement ; sqlite-statement new-statement ;
: sqlite-maybe-prepare ( statement -- statement ) : sqlite-maybe-prepare ( statement -- statement )
@ -43,22 +43,22 @@ M: sqlite-db-connection <prepared-statement> ( str in out -- obj )
>>handle >>handle
] unless ; ] unless ;
M: sqlite-statement dispose ( statement -- ) M: sqlite-statement dispose
handle>> handle>>
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ; [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- ) M: sqlite-result-set dispose
f >>handle drop ; f >>handle drop ;
: reset-bindings ( statement -- ) : reset-bindings ( statement -- )
sqlite-maybe-prepare sqlite-maybe-prepare
handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ; 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 [ handle>> ] [ bind-params>> ] bi
[ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ; [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( statement -- ) M: sqlite-statement bind-statement*
sqlite-maybe-prepare sqlite-maybe-prepare
dup bound?>> [ dup reset-bindings ] when dup bound?>> [ dup reset-bindings ] when
low-level-bind ; low-level-bind ;
@ -72,12 +72,12 @@ TUPLE: sqlite-low-level-binding < low-level-binding key type ;
swap >>value swap >>value
swap >>key ; swap >>key ;
M: sql-spec sqlite-bind-conversion ( tuple spec -- array ) M: sql-spec sqlite-bind-conversion
[ column-name>> ":" prepend ] [ column-name>> ":" prepend ]
[ slot-name>> rot get-slot-named ] [ slot-name>> rot get-slot-named ]
[ type>> ] tri <sqlite-low-level-binding> ; [ type>> ] tri <sqlite-low-level-binding> ;
M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) M: literal-bind sqlite-bind-conversion
nip [ key>> ] [ value>> ] [ type>> ] tri nip [ key>> ] [ value>> ] [ type>> ] tri
<sqlite-low-level-binding> ; <sqlite-low-level-binding> ;
@ -87,7 +87,7 @@ M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
obj name tuple set-slot-named obj name tuple set-slot-named
generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ; generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ;
M: sqlite-statement bind-tuple ( tuple statement -- ) M: sqlite-statement bind-tuple
[ [
in-params>> [ sqlite-bind-conversion ] with map in-params>> [ sqlite-bind-conversion ] with map
] keep bind-statement ; ] keep bind-statement ;
@ -98,31 +98,31 @@ ERROR: sqlite-last-id-fail ;
db-connection get handle>> sqlite3_last_insert_rowid db-connection get handle>> sqlite3_last_insert_rowid
dup zero? [ sqlite-last-id-fail ] when ; 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 ; 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 ; handle>> sqlite-#columns ;
M: sqlite-result-set row-column ( result-set n -- obj ) M: sqlite-result-set row-column
[ handle>> ] [ sqlite-column ] bi* ; [ 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>> dup pick out-params>> nth type>>
[ handle>> ] 2dip sqlite-column-typed ; [ 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 ; dup handle>> sqlite-next >>has-more? drop ;
M: sqlite-result-set more-rows? ( result-set -- ? ) M: sqlite-result-set more-rows?
has-more?>> ; has-more?>> ;
M: sqlite-statement query-results ( query -- result-set ) M: sqlite-statement query-results
sqlite-maybe-prepare sqlite-maybe-prepare
dup handle>> sqlite-result-set new-result-set dup handle>> sqlite-result-set new-result-set
dup advance-row ; dup advance-row ;
M: sqlite-db-connection <insert-db-assigned-statement> ( class -- statement ) M: sqlite-db-connection <insert-db-assigned-statement>
[ [
"insert into " 0% 0% "insert into " 0% 0%
"(" 0% "(" 0%
@ -143,19 +143,19 @@ M: sqlite-db-connection <insert-db-assigned-statement> ( class -- statement )
");" 0% ");" 0%
] query-make ; ] query-make ;
M: sqlite-db-connection <insert-user-assigned-statement> ( class -- statement ) M: sqlite-db-connection <insert-user-assigned-statement>
<insert-db-assigned-statement> ; <insert-db-assigned-statement> ;
M: sqlite-db-connection bind# ( spec obj -- ) M: sqlite-db-connection bind#
[ [
[ column-name>> ":" next-sql-counter surround dup 0% ] [ column-name>> ":" next-sql-counter surround dup 0% ]
[ type>> ] bi [ type>> ] bi
] dip <literal-bind> 1, ; ] dip <literal-bind> 1, ;
M: sqlite-db-connection bind% ( spec -- ) M: sqlite-db-connection bind%
dup 1, column-name>> ":" prepend 0% ; dup 1, column-name>> ":" prepend 0% ;
M: sqlite-db-connection persistent-table ( -- assoc ) M: sqlite-db-connection persistent-table
H{ H{
{ +db-assigned-id+ { "integer" "integer" f } } { +db-assigned-id+ { "integer" "integer" f } }
{ +user-assigned-id+ { f f f } } { +user-assigned-id+ { f f f } }
@ -314,16 +314,16 @@ M: sqlite-db-connection persistent-table ( -- assoc )
");" 0% ");" 0%
] 2bi ; ] 2bi ;
M: sqlite-db-connection create-sql-statement ( class -- statement ) M: sqlite-db-connection create-sql-statement
[ [
[ sqlite-create-table ] [ sqlite-create-table ]
[ drop create-db-triggers ] 2bi [ drop create-db-triggers ] 2bi
] query-make ; ] 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 ; [ nip "drop table " 0% 0% ";" 0% ] query-make ;
M: sqlite-db-connection compound ( string seq -- new-string ) M: sqlite-db-connection compound
over { over {
{ "default" [ first number>string " " glue ] } { "default" [ first number>string " " glue ] }
{ "references" [ >reference-string ] } { "references" [ >reference-string ] }

2
basis/debugger/unix/unix.factor
View File

@ -4,6 +4,6 @@ USING: debugger io kernel prettyprint sequences system
unix.signals ; unix.signals ;
IN: debugger.unix IN: debugger.unix
M: unix signal-error. ( obj -- ) M: unix signal-error.
"Unix signal #" write "Unix signal #" write
third [ pprint ] [ signal-name. ] bi nl ; third [ pprint ] [ signal-name. ] bi nl ;

2
basis/editors/atom/atom.factor
View File

@ -21,7 +21,7 @@ M: macosx find-atom
f f
] if* ; ] if* ;
M: atom-editor editor-command ( file line -- command ) M: atom-editor editor-command
[ [
atom-path get [ find-atom ] unless* , atom-path get [ find-atom ] unless* ,
number>string ":" glue , number>string ":" glue ,

2
basis/editors/bbedit/bbedit.factor
View File

@ -4,6 +4,6 @@ IN: editors.bbedit
SINGLETON: bbedit SINGLETON: bbedit
bbedit editor-class set-global bbedit editor-class set-global
M: bbedit editor-command ( file line -- command ) M: bbedit editor-command
drop drop
[ "open" , "-a" , "BBEdit" , , ] { } make ; [ "open" , "-a" , "BBEdit" , , ] { } make ;

2
basis/editors/brackets/brackets.factor
View File

@ -16,7 +16,7 @@ M: macosx brackets-path
f f
] if* ; ] if* ;
M: brackets-editor editor-command ( file line -- command ) M: brackets-editor editor-command
[ brackets-path "brackets" or , drop , ] { } make ; [ brackets-path "brackets" or , drop , ] { } make ;
os windows? [ "editors.brackets.windows" require ] when os windows? [ "editors.brackets.windows" require ] when

2
basis/editors/coteditor/coteditor.factor
View File

@ -12,5 +12,5 @@ coteditor editor-class set-global
f f
] if* ; ] if* ;
M: coteditor editor-command ( file line -- command ) M: coteditor editor-command
[ find-cot-bundle-path , "-l" , number>string , , ] { } make ; [ find-cot-bundle-path , "-l" , number>string , , ] { } make ;

2
basis/editors/editpadpro/editpadpro.factor
View File

@ -14,7 +14,7 @@ editpadpro editor-class set-global
} 0|| } 0||
] unless* ; ] unless* ;
M: editpadpro editor-command ( file line -- command ) M: editpadpro editor-command
[ [
editpadpro-path , number>string "/l" prepend , , editpadpro-path , number>string "/l" prepend , ,
] { } make ; ] { } make ;

2
basis/editors/editplus/editplus.factor
View File

@ -11,7 +11,7 @@ editplus editor-class set-global
[ "editplus.exe" ] unless* [ "editplus.exe" ] unless*
] unless* ; ] unless* ;
M: editplus editor-command ( file line -- command ) M: editplus editor-command
[ [
editplus-path , "-cursor" , number>string , , editplus-path , "-cursor" , number>string , ,
] { } make ; ] { } make ;

4
basis/editors/emacs/emacs.factor
View File

@ -10,7 +10,7 @@ SYMBOL: emacsclient-args
HOOK: find-emacsclient os ( -- path ) HOOK: find-emacsclient os ( -- path )
M: object find-emacsclient ( -- path ) M: object find-emacsclient
"emacsclient" ?find-in-path ; "emacsclient" ?find-in-path ;
M: windows find-emacsclient M: windows find-emacsclient
@ -20,7 +20,7 @@ M: windows find-emacsclient
[ "emacsclient.exe" ] [ "emacsclient.exe" ]
} 0|| ; } 0|| ;
M: emacsclient editor-command ( file line -- command ) M: emacsclient editor-command
[ [
emacsclient-path get [ find-emacsclient ] unless* , emacsclient-path get [ find-emacsclient ] unless* ,
emacsclient-args get [ { "-a=emacs" "--no-wait" } ] unless* % emacsclient-args get [ { "-a=emacs" "--no-wait" } ] unless* %

2
basis/editors/emeditor/emeditor.factor
View File

@ -11,7 +11,7 @@ emeditor editor-class set-global
[ "EmEditor.exe" ] unless* [ "EmEditor.exe" ] unless*
] unless* ; ] unless* ;
M: emeditor editor-command ( file line -- command ) M: emeditor editor-command
[ [
emeditor-path , "/l" , number>string , , emeditor-path , "/l" , number>string , ,
] { } make ; ] { } make ;

2
basis/editors/etexteditor/etexteditor.factor
View File

@ -13,7 +13,7 @@ etexteditor editor-class set-global
[ "e.exe" ] unless* [ "e.exe" ] unless*
] unless* ; ] unless* ;
M: etexteditor editor-command ( file line -- command ) M: etexteditor editor-command
[ [
etexteditor-path , etexteditor-path ,
[ , ] [ "--line" , number>string , ] bi* [ , ] [ "--line" , number>string , ] bi*

2
basis/editors/gedit/gedit.factor
View File

@ -12,7 +12,7 @@ gedit editor-class set-global
"gedit" ?find-in-path "gedit" ?find-in-path
] unless* ; ] unless* ;
M: gedit editor-command ( file line -- command ) M: gedit editor-command
[ [
gedit-path , number>string "+" prepend , , gedit-path , number>string "+" prepend , ,
] { } make ; ] { } make ;

2
basis/editors/jedit/jedit.factor
View File

@ -27,7 +27,7 @@ M: windows find-jedit-path
find-jedit-path [ "jedit" ?find-in-path ] unless* find-jedit-path [ "jedit" ?find-in-path ] unless*
] unless* ; ] unless* ;
M: jedit editor-command ( file line -- command/f ) M: jedit editor-command
[ [
find-jedit-path , find-jedit-path ,
"-reuseview" , "-reuseview" ,

2
basis/editors/notepad++/notepad++.factor
View File

@ -11,7 +11,7 @@ notepad++ editor-class set-global
[ "notepad++.exe" ] unless* [ "notepad++.exe" ] unless*
] unless* ; ] unless* ;
M: notepad++ editor-command ( file line -- command ) M: notepad++ editor-command
[ [
notepad++-path , notepad++-path ,
number>string "-n" prepend , , number>string "-n" prepend , ,

2
basis/editors/notepad/notepad.factor
View File

@ -14,5 +14,5 @@ notepad editor-class set-global
[ "notepad.exe" tail? ] find-file [ "notepad.exe" tail? ] find-file
] unless* ; ] unless* ;
M: notepad editor-command ( file line -- command ) M: notepad editor-command
drop [ notepad-path ] dip 2array ; drop [ notepad-path ] dip 2array ;

2
basis/editors/notepad2/notepad2.factor
View File

@ -11,7 +11,7 @@ notepad2 editor-class set-global
[ "notepad.exe" ] unless* [ "notepad.exe" ] unless*
] unless* ; ] unless* ;
M: notepad2 editor-command ( file line -- command ) M: notepad2 editor-command
[ [
notepad2-path , notepad2-path ,
"/g" , number>string , , "/g" , number>string , ,

2
basis/editors/scite/scite.factor
View File

@ -21,7 +21,7 @@ M: windows find-scite-path
} "scite.exe" find-in-applications } "scite.exe" find-in-applications
[ "scite.exe" ] unless* ; [ "scite.exe" ] unless* ;
M: scite editor-command ( file line -- cmd ) M: scite editor-command
swap swap
[ [
scite-path get [ find-scite-path ] unless* , scite-path get [ find-scite-path ] unless* ,

2
basis/editors/sublime/sublime.factor
View File

@ -31,7 +31,7 @@ M: windows find-sublime-path
find-sublime-path [ "subl" ?find-in-path ] unless* find-sublime-path [ "subl" ?find-in-path ] unless*
] unless* ; ] unless* ;
M: sublime editor-command ( file line -- command ) M: sublime editor-command
[ [
sublime-path , "-a" , number>string ":" glue , sublime-path , "-a" , number>string ":" glue ,
] { } make ; ] { } make ;

2
basis/editors/ted-notepad/ted-notepad.factor
View File

@ -11,7 +11,7 @@ ted-notepad editor-class set-global
[ "TedNPad.exe" ] unless* [ "TedNPad.exe" ] unless*
] unless* ; ] unless* ;
M: ted-notepad editor-command ( file line -- command ) M: ted-notepad editor-command
[ [
ted-notepad-path , ted-notepad-path ,
number>string "/l" prepend , , number>string "/l" prepend , ,

2
basis/editors/textadept/textadept.factor
View File

@ -37,7 +37,7 @@ M: windows find-textadept-path
find-textadept-path [ "textadept" ?find-in-path ] unless* find-textadept-path [ "textadept" ?find-in-path ] unless*
] unless* ; ] unless* ;
M: textadept editor-command ( file line -- command ) M: textadept editor-command
swap [ swap [
textadept-path , "-f" , , "-e" , textadept-path , "-f" , , "-e" ,
1 - number>string "goto_line(" ")" surround , 1 - number>string "goto_line(" ")" surround ,

2
basis/editors/textedit/textedit.factor
View File

@ -5,6 +5,6 @@ IN: editors.textedit
SINGLETON: textedit SINGLETON: textedit
textedit editor-class set-global textedit editor-class set-global
M: textedit editor-command ( file line -- command ) M: textedit editor-command
drop drop
[ "open" , "-a" , "TextEdit" , , ] { } make ; [ "open" , "-a" , "TextEdit" , , ] { } make ;

2
basis/editors/textmate/textmate.factor
View File

@ -5,5 +5,5 @@ IN: editors.textmate
SINGLETON: textmate SINGLETON: textmate
textmate editor-class set-global textmate editor-class set-global
M: textmate editor-command ( file line -- command ) M: textmate editor-command
[ "mate" , "-a" , "-l" , number>string , , ] { } make ; [ "mate" , "-a" , "-l" , number>string , , ] { } make ;

2
basis/editors/textpad/textpad.factor
View File

@ -11,7 +11,7 @@ textpad editor-class set-global
[ "TextPad.exe" ] unless* [ "TextPad.exe" ] unless*
] unless* ; ] unless* ;
M: textpad editor-command ( file line -- command ) M: textpad editor-command
[ [
textpad-path , textpad-path ,
[ , ] [ number>string "(" ",0)" surround , ] bi* [ , ] [ number>string "(" ",0)" surround , ] bi*

2
basis/editors/ultraedit/ultraedit.factor
View File

@ -11,7 +11,7 @@ ultraedit editor-class set-global
[ "uedit32.exe" ] unless* [ "uedit32.exe" ] unless*
] unless* ; ] unless* ;
M: ultraedit editor-command ( file line -- command ) M: ultraedit editor-command
[ [
ultraedit-path , [ swap % "/" % # "/1" % ] "" make , ultraedit-path , [ swap % "/" % # "/1" % ] "" make ,
] { } make ; ] { } make ;

2
basis/editors/vim/vim.factor
View File

@ -20,7 +20,7 @@ M: vim find-vim-path "vim" ?find-in-path ;
: actual-vim-path ( -- path ) : actual-vim-path ( -- path )
\ vim-path get [ find-vim-path ] unless* ; \ vim-path get [ find-vim-path ] unless* ;
M: vim editor-command ( file line -- command ) M: vim editor-command
[ [
actual-vim-path dup string? [ , ] [ % ] if actual-vim-path dup string? [ , ] [ % ] if
vim-ui? [ "-g" , ] when vim-ui? [ "-g" , ] when

2
basis/editors/visual-studio-code/visual-studio-code.factor
View File

@ -45,7 +45,7 @@ M: windows find-visual-studio-code-invocation
[ "code.cmd" ] [ "code.cmd" ]
} 0|| ; } 0|| ;
M: visual-studio-code editor-command ( file line -- command ) M: visual-studio-code editor-command
[ [
visual-studio-code-invocation visual-studio-code-invocation
[ , ] [ can't-find-visual-studio-code ] if* [ , ] [ can't-find-visual-studio-code ] if*

2
basis/editors/wordpad/wordpad.factor
View File

@ -9,5 +9,5 @@ wordpad editor-class set-global
{ "Windows NT\\Accessories" } "wordpad.exe" find-in-applications { "Windows NT\\Accessories" } "wordpad.exe" find-in-applications
] unless* ; ] unless* ;
M: wordpad editor-command ( file line -- command ) M: wordpad editor-command
drop [ wordpad-path ] dip 2array ; drop [ wordpad-path ] dip 2array ;

2
basis/editors/xcode/xcode.factor
View File

@ -5,6 +5,6 @@ IN: editors.xcode
SINGLETON: xcode SINGLETON: xcode
xcode editor-class set-global xcode editor-class set-global
M: xcode editor-command ( file line -- command ) M: xcode editor-command
drop drop
[ "open" , "-a" , "XCode" , , ] { } make ; [ "open" , "-a" , "XCode" , , ] { } make ;

14
basis/environment/unix/unix.factor
View File

@ -7,27 +7,27 @@ IN: environment.unix
HOOK: environ os ( -- void* ) 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 [ over [
swap 1 setenv io-error swap 1 setenv io-error
] [ ] [
nip unset-os-env nip unset-os-env
] if ; ] 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 ; environ void* deref native-string-encoding alien>strings ;
: set-void* ( value alien -- ) 0 set-alien-cell ; : 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 ; utf8 strings>alien malloc-byte-array set-os-envs-pointer ;
os macosx? [ "environment.unix.macosx" require ] when os macosx? [ "environment.unix.macosx" require ] when

8
basis/environment/windows/windows.factor
View File

@ -7,7 +7,7 @@ io.streams.memory io.encodings io specialized-arrays ;
SPECIALIZED-ARRAY: TCHAR SPECIALIZED-ARRAY: TCHAR
IN: environment.windows IN: environment.windows
M: windows os-env ( key -- value ) M: windows os-env
MAX_UNICODE_PATH TCHAR <c-array> MAX_UNICODE_PATH TCHAR <c-array>
[ dup length GetEnvironmentVariable ] keep over 0 = [ [ dup length GetEnvironmentVariable ] keep over 0 = [
2drop f 2drop f
@ -15,16 +15,16 @@ M: windows os-env ( key -- value )
nip alien>native-string nip alien>native-string
] if ; ] if ;
M: windows set-os-env ( value key -- ) M: windows set-os-env
swap SetEnvironmentVariable win32-error=0/f ; swap SetEnvironmentVariable win32-error=0/f ;
M: windows unset-os-env ( key -- ) M: windows unset-os-env
f SetEnvironmentVariable 0 = [ f SetEnvironmentVariable 0 = [
GetLastError ERROR_ENVVAR_NOT_FOUND = GetLastError ERROR_ENVVAR_NOT_FOUND =
[ win32-error ] unless [ win32-error ] unless
] when ; ] when ;
M: windows (os-envs) ( -- seq ) M: windows (os-envs)
GetEnvironmentStrings [ GetEnvironmentStrings [
[ [
utf16n decode-input utf16n decode-input

2
basis/fry/fry.factor
View File

@ -141,7 +141,7 @@ TUPLE: dredge-fry-state
PRIVATE> PRIVATE>
M: callable fry ( quot -- quot' ) M: callable fry
[ [ [ ] ] ] [ [ [ [ ] ] ] [
0 swap <dredge-fry> 0 swap <dredge-fry>
[ dredge-fry ] [ [ dredge-fry ] [

10
basis/ftp/server/server.factor
View File

@ -175,7 +175,7 @@ GENERIC: handle-passive-command ( stream obj -- )
: finish-directory ( -- ) : finish-directory ( -- )
"Directory send OK." 226 server-response ; "Directory send OK." 226 server-response ;
M: ftp-list handle-passive-command ( stream obj -- ) M: ftp-list handle-passive-command
drop drop
start-directory [ start-directory [
utf8 encode-output [ utf8 encode-output [
@ -184,7 +184,7 @@ M: ftp-list handle-passive-command ( stream obj -- )
harvest [ ftp-send ] each harvest [ ftp-send ] each
] with-output-stream finish-directory ; ] with-output-stream finish-directory ;
M: ftp-get handle-passive-command ( stream obj -- ) M: ftp-get handle-passive-command
[ [
path>> path>>
[ transfer-outgoing-file ] [ transfer-outgoing-file ]
@ -194,7 +194,7 @@ M: ftp-get handle-passive-command ( stream obj -- )
3drop "File transfer failed" ftp-error 3drop "File transfer failed" ftp-error
] recover ; ] recover ;
M: ftp-put handle-passive-command ( stream obj -- ) M: ftp-put handle-passive-command
[ [
path>> path>>
[ transfer-incoming-file ] [ transfer-incoming-file ]
@ -204,7 +204,7 @@ M: ftp-put handle-passive-command ( stream obj -- )
3drop "File transfer failed" ftp-error 3drop "File transfer failed" ftp-error
] recover ; ] recover ;
M: ftp-disconnect handle-passive-command ( stream obj -- ) M: ftp-disconnect handle-passive-command
drop dispose ; drop dispose ;
: fulfill-client ( obj -- ) : fulfill-client ( obj -- )
@ -344,7 +344,7 @@ M: ftp-disconnect handle-passive-command ( stream obj -- )
handle-client-loop handle-client-loop
] with-directory ; ] with-directory ;
M: ftp-server handle-client* ( server -- ) M: ftp-server handle-client*
[ [
"New client" \ handle-client* DEBUG log-message "New client" \ handle-client* DEBUG log-message
ftp-client new client set ftp-client new client set

2
basis/furnace/actions/actions.factor
View File

@ -100,7 +100,7 @@ CONSTANT: revalidate-url-key "__u"
begin-form begin-form
handle-rest ; handle-rest ;
M: action call-responder* ( path action -- response ) M: action call-responder*
[ init-action ] keep [ init-action ] keep
request get method>> { request get method>> {
{ "GET" [ handle-get ] } { "GET" [ handle-get ] }

6
basis/furnace/asides/asides.factor
View File

@ -87,7 +87,7 @@ ERROR: end-aside-in-get-error ;
: end-aside ( default -- response ) : end-aside ( default -- response )
aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ; aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
M: asides link-attr ( tag responder -- ) M: asides link-attr
drop drop
"aside" optional-attr { "aside" optional-attr {
{ "none" [ aside-id off ] } { "none" [ aside-id off ] }
@ -96,13 +96,13 @@ M: asides link-attr ( tag responder -- )
{ f [ ] } { f [ ] }
} case ; } case ;
M: asides modify-query ( query asides -- query' ) M: asides modify-query
drop drop
aside-id get [ aside-id get [
aside-id-key associate assoc-union aside-id-key associate assoc-union
] when* ; ] when* ;
M: asides modify-form ( asides -- xml/f ) M: asides modify-form
drop drop
aside-id get aside-id get
aside-id-key aside-id-key

4
basis/furnace/auth/auth.factor
View File

@ -97,7 +97,7 @@ M: user-saver dispose
\ init-user DEBUG add-input-logging \ init-user DEBUG add-input-logging
M: realm call-responder* ( path responder -- response ) M: realm call-responder*
dup realm namespaces:set dup realm namespaces:set
logged-in? [ logged-in? [
dup init-realm dup init-realm
@ -146,7 +146,7 @@ TUPLE: protected < filter-responder description capabilities ;
} cond } cond
] if ; ] if ;
M: protected call-responder* ( path responder -- response ) M: protected call-responder*
dup protected namespaces:set dup protected namespaces:set
dup capabilities>> have-capabilities? dup capabilities>> have-capabilities?
[ call-next-method ] [ [ call-next-method ] [

4
basis/furnace/auth/basic/basic.factor
View File

@ -20,10 +20,10 @@ TUPLE: basic-auth-realm < realm ;
401 "Invalid username or password" <trivial-response> 401 "Invalid username or password" <trivial-response>
[ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ; [ "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> ; 2nip name>> <401> ;
M: basic-auth-realm logged-in-username ( realm -- uid ) M: basic-auth-realm logged-in-username
drop drop
request get "authorization" header parse-basic-auth request get "authorization" header parse-basic-auth
dup [ over check-login swap and ] [ 2drop f ] if ; dup [ over check-login swap and ] [ 2drop f ] if ;

6
basis/furnace/auth/login/login.factor
View File

@ -29,7 +29,7 @@ M: login-realm init-realm
M: login-realm logged-in-username M: login-realm logged-in-username
drop permit-id get dup [ get-permit-uid ] when ; 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 ; drop permit-id get realm get name>> permit-id-key hidden-form-field ;
: <permit-cookie> ( -- cookie ) : <permit-cookie> ( -- cookie )
@ -95,7 +95,7 @@ CONSTANT: flashed-variables { description capabilities }
<action> <action>
[ logout ] >>submit ; [ logout ] >>submit ;
M: login-realm login-required* ( description capabilities login -- response ) M: login-realm login-required*
begin-conversation begin-conversation
[ description cset ] [ capabilities cset ] [ secure>> ] tri* [ description cset ] [ capabilities cset ] [ secure>> ] tri*
[ [
@ -106,7 +106,7 @@ M: login-realm login-required* ( description capabilities login -- response )
URL" $realm/login" <continue-conversation> URL" $realm/login" <continue-conversation>
] if ; ] if ;
M: login-realm user-registered ( user realm -- response ) M: login-realm user-registered
drop successful-login ; drop successful-login ;
: <login-realm> ( responder name -- realm ) : <login-realm> ( responder name -- realm )

7
basis/furnace/auth/providers/assoc/assoc.factor
View File

@ -8,11 +8,10 @@ TUPLE: users-in-memory assoc ;
: <users-in-memory> ( -- provider ) : <users-in-memory> ( -- provider )
H{ } clone users-in-memory boa ; H{ } clone users-in-memory boa ;
M: users-in-memory get-user ( username provider -- user/f ) M: users-in-memory get-user assoc>> at ;
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>> [ dup username>> ] dip assoc>>
2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ; 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;

6
basis/furnace/auth/providers/couchdb/couchdb.factor
View File

@ -194,19 +194,19 @@ PRIVATE>
: <couchdb-auth-provider> ( base-url username-view -- couchdb-auth-provider ) : <couchdb-auth-provider> ( base-url username-view -- couchdb-auth-provider )
couchdb-auth-provider new swap >>username-view swap >>base-url ; 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 [ couchdb-auth-provider [
(get-user) [ user-hash>user ] [ f ] if* (get-user) [ user-hash>user ] [ f ] if*
] with-variable ; ] with-variable ;
M: couchdb-auth-provider new-user ( user provider -- user/f ) M: couchdb-auth-provider new-user
couchdb-auth-provider [ couchdb-auth-provider [
dup (new-user) [ dup (new-user) [
username>> couchdb-auth-provider get get-user username>> couchdb-auth-provider get get-user
] [ drop f ] if ] [ drop f ] if
] with-variable ; ] with-variable ;
M: couchdb-auth-provider update-user ( user provider -- ) M: couchdb-auth-provider update-user
couchdb-auth-provider [ couchdb-auth-provider [
[ username>> (get-user)/throw-on-no-user dup ] [ username>> (get-user)/throw-on-no-user dup ]
[ drop "_id" of get-url ] [ drop "_id" of get-url ]

2
basis/furnace/conversations/conversations.factor
View File

@ -106,7 +106,7 @@ M: conversations call-responder*
bi bi
] [ drop ] if* ; ] [ drop ] if* ;
M: conversations modify-form ( conversations -- xml/f ) M: conversations modify-form
drop drop
conversation-id get conversation-id get
conversation-id-key conversation-id-key

4
basis/furnace/sessions/sessions.factor
View File

@ -98,10 +98,10 @@ CONSTANT: session-id-key "__s"
: put-session-cookie ( response -- response' ) : put-session-cookie ( response -- response' )
<session-cookie> put-cookie ; <session-cookie> put-cookie ;
M: sessions modify-form ( responder -- xml/f ) M: sessions modify-form
drop session get id>> session-id-key hidden-form-field ; drop session get id>> session-id-key hidden-form-field ;
M: sessions call-responder* ( path responder -- response ) M: sessions call-responder*
sessions set sessions set
request-session [ begin-session ] unless* request-session [ begin-session ] unless*
existing-session put-session-cookie ; existing-session put-session-cookie ;

16
basis/game/input/iokit/iokit.factor
View File

@ -334,28 +334,30 @@ M: iokit-game-input-backend (close-game-input)
f +controller-states+ set-global f +controller-states+ set-global
] when ; ] when ;
M: iokit-game-input-backend get-controllers ( -- sequence ) M: iokit-game-input-backend get-controllers
+controller-states+ get-global keys [ controller boa ] map ; +controller-states+ get-global keys [ controller boa ] map ;
: ?join ( pre post sep -- string ) : ?join ( pre post sep -- string )
2over subseq-start [ swap 2nip ] [ [ 2array ] dip join ] if ; 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>> handle>>
[ kIOHIDManufacturerKey device-property ] [ kIOHIDManufacturerKey device-property ]
[ kIOHIDProductKey device-property ] bi " " ?join ; [ kIOHIDProductKey device-property ] bi " " ?join ;
M: iokit-game-input-backend product-id ( controller -- integer )
M: iokit-game-input-backend product-id
handle>> handle>>
[ kIOHIDVendorIDKey device-property ] [ kIOHIDVendorIDKey device-property ]
[ kIOHIDProductIDKey device-property ] bi 2array ; [ 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 ; 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 ; 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 ; +keyboard-state+ get-global clone keyboard-state boa ;
M: iokit-game-input-backend calibrate-controller ( controller -- ) M: iokit-game-input-backend calibrate-controller
drop ; drop ;

8
basis/heaps/heaps.factor
View File

@ -35,11 +35,9 @@ TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ; : <max-heap> ( -- max-heap ) max-heap <heap> ;
M: heap heap-empty? ( heap -- ? ) M: heap heap-empty? data>> empty? ; inline
data>> empty? ; inline
M: heap heap-size ( heap -- n ) M: heap heap-size data>> length ; inline
data>> length ; inline
<PRIVATE <PRIVATE
@ -75,7 +73,7 @@ PRIVATE>
: >entry< ( entry -- value key ) : >entry< ( entry -- value key )
[ value>> ] [ key>> ] bi ; inline [ value>> ] [ key>> ] bi ; inline
M: heap heap-peek ( heap -- value key ) M: heap heap-peek
data>> first >entry< ; data>> first >entry< ;
<PRIVATE <PRIVATE

4
basis/html/templates/chloe/components/components.factor
View File

@ -15,7 +15,7 @@ IN: html.templates.chloe.components
GENERIC: component-tag ( tag class -- ) GENERIC: component-tag ( tag class -- )
M: singleton-class component-tag ( tag class -- ) M: singleton-class component-tag
[ "name" required-attr compile-attr ] [ "name" required-attr compile-attr ]
[ literalize render-quot [code-with] ] [ literalize render-quot [code-with] ]
bi* ; bi* ;
@ -26,7 +26,7 @@ M: singleton-class component-tag ( tag class -- )
[ [ boa ] [code-with] ] [ [ boa ] [code-with] ]
bi ; bi ;
M: tuple-class component-tag ( tag class -- ) M: tuple-class component-tag
[ drop "name" required-attr compile-attr ] [ drop "name" required-attr compile-attr ]
[ compile-component-attrs ] 2bi [ compile-component-attrs ] 2bi
render-quot [code] ; render-quot [code] ;

2
basis/html/templates/fhtml/fhtml.factor
View File

@ -71,7 +71,7 @@ TUPLE: fhtml path ;
C: <fhtml> fhtml C: <fhtml> fhtml
M: fhtml call-template* ( filename -- ) M: fhtml call-template*
path>> utf8 file-contents eval-template ; path>> utf8 file-contents eval-template ;
INSTANCE: fhtml template INSTANCE: fhtml template

4
basis/http/server/dispatchers/dispatchers.factor
View File

@ -23,7 +23,7 @@ TUPLE: dispatcher default responders ;
[ [ drop rest-slice ] dip ] [ drop default>> ] if [ [ drop rest-slice ] dip ] [ drop default>> ] if
] if ; ] if ;
M: dispatcher call-responder* ( path dispatcher -- response ) M: dispatcher call-responder*
find-responder call-responder ; find-responder call-responder ;
TUPLE: vhost-dispatcher default responders ; TUPLE: vhost-dispatcher default responders ;
@ -38,7 +38,7 @@ TUPLE: vhost-dispatcher default responders ;
url get host>> canonical-host over responders>> at* url get host>> canonical-host over responders>> at*
[ nip ] [ drop default>> ] if ; [ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response ) M: vhost-dispatcher call-responder*
find-vhost call-responder ; find-vhost call-responder ;
: add-responder ( dispatcher responder path -- dispatcher ) : add-responder ( dispatcher responder path -- dispatcher )

8
basis/http/server/server.factor
View File

@ -48,13 +48,13 @@ GENERIC: write-full-response ( request response -- )
: write-response-body ( response -- response ) : write-response-body ( response -- response )
dup body>> call-template ; dup body>> call-template ;
M: response write-response ( respose -- ) M: response write-response
write-response-line write-response-line
write-response-header write-response-header
flush flush
drop ; drop ;
M: response write-full-response ( request response -- ) M: response write-full-response
dup write-response dup write-response
swap method>> "HEAD" = [ swap method>> "HEAD" = [
[ content-encoding>> encode-output ] [ content-encoding>> encode-output ]
@ -62,12 +62,12 @@ M: response write-full-response ( request response -- )
bi bi
] unless drop ; ] unless drop ;
M: raw-response write-response ( respose -- ) M: raw-response write-response
write-response-line write-response-line
write-response-body write-response-body
drop ; drop ;
M: raw-response write-full-response ( request response -- ) M: raw-response write-full-response
nip write-response ; nip write-response ;
: post-request? ( -- ? ) request get method>> "POST" = ; : post-request? ( -- ? ) request get method>> "POST" = ;

2
basis/http/server/static/static.factor
View File

@ -178,7 +178,7 @@ TUPLE: file-responder root hook special index-names allow-listings ;
[ drop <404> ] [ drop <404> ]
if ; if ;
M: file-responder call-responder* ( path responder -- response ) M: file-responder call-responder*
file-responder set file-responder set
".." over member? ".." over member?
[ drop <400> ] [ "/" join serve-object ] if ; [ drop <400> ] [ "/" join serve-object ] if ;

2
basis/images/loader/gdiplus/gdiplus.factor
View File

@ -106,5 +106,5 @@ M: gdi+-image stream>image*
gdi+-bitmap>data gdi+-bitmap>data
data>image ; 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 ; drop startup-gdi+ output-stream get swap write-image-to-stream ;

2
basis/io/backend/unix/bsd/bsd.factor
View File

@ -5,5 +5,5 @@ unix io.backend io.backend.unix io.backend.unix.multiplexers
io.backend.unix.multiplexers.kqueue io.files.unix ; io.backend.unix.multiplexers.kqueue io.files.unix ;
IN: io.backend.unix.bsd IN: io.backend.unix.bsd
M: bsd init-io ( -- ) M: bsd init-io
<kqueue-mx> mx set-global ; <kqueue-mx> mx set-global ;

2
basis/io/backend/unix/freebsd/freebsd.factor
View File

@ -2,7 +2,7 @@ USING: io.backend io.backend.unix system namespaces kernel accessors assocs cont
<< "io.files.unix" require >> ! needed for deploy << "io.files.unix" require >> ! needed for deploy
M: freebsd init-io ( -- ) M: freebsd init-io
<kqueue-mx> mx set-global ; <kqueue-mx> mx set-global ;
freebsd set-io-backend freebsd set-io-backend

2
basis/io/backend/unix/linux/linux.factor
View File

@ -5,7 +5,7 @@ io.backend.unix io.backend.unix.multiplexers
io.backend.unix.multiplexers.epoll init ; io.backend.unix.multiplexers.epoll init ;
IN: io.backend.unix.linux IN: io.backend.unix.linux
M: linux init-io ( -- ) M: linux init-io
<epoll-mx> mx set-global ; <epoll-mx> mx set-global ;
linux set-io-backend linux set-io-backend

4
basis/io/backend/unix/macosx/macosx.factor
View File

@ -8,10 +8,10 @@ IN: io.backend.unix.macosx
SINGLETON: macosx-kqueue SINGLETON: macosx-kqueue
M: macosx-kqueue init-io ( -- ) M: macosx-kqueue init-io
<kqueue-mx> mx set-global ; <kqueue-mx> mx set-global ;
M: macosx init-io ( -- ) M: macosx init-io
<run-loop-mx> mx set-global ; <run-loop-mx> mx set-global ;
macosx set-io-backend macosx set-io-backend

10
basis/io/backend/unix/multiplexers/epoll/epoll.factor
View File

@ -34,18 +34,18 @@ M: epoll-mx dispose* fd>> close-file ;
: do-epoll-del ( fd mx events -- ) : do-epoll-del ( fd mx events -- )
EPOLL_CTL_DEL swap do-epoll-ctl ; 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 ; [ 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 ; [ 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? [ 2dup reads>> key? [
[ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
] [ 2drop f ] if ; ] [ 2drop f ] if ;
M: epoll-mx remove-output-callbacks ( fd mx -- seq ) M: epoll-mx remove-output-callbacks
2dup writes>> key? [ 2dup writes>> key? [
[ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi
] [ 2drop f ] if ; ] [ 2drop f ] if ;
@ -62,5 +62,5 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
: handle-events ( mx n -- ) : handle-events ( mx n -- )
[ dup events>> ] dip head-slice swap '[ _ handle-event ] each ; [ 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 ; swap 60000000 or dupd wait-event handle-events ;

10
basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
View File

@ -29,19 +29,19 @@ M: kqueue-mx dispose* fd>> close-file ;
: register-kevent ( kevent mx -- ) : register-kevent ( kevent mx -- )
fd>> swap 1 f 0 f kevent-func io-error ; 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 ] [ [ call-next-method ] [
[ EVFILT_READ flags{ EV_ADD EV_ONESHOT } make-kevent ] dip [ EVFILT_READ flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent register-kevent
] 2bi ; ] 2bi ;
M: kqueue-mx add-output-callback ( thread fd mx -- ) M: kqueue-mx add-output-callback
[ call-next-method ] [ [ call-next-method ] [
[ EVFILT_WRITE flags{ EV_ADD EV_ONESHOT } make-kevent ] dip [ EVFILT_WRITE flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent register-kevent
] 2bi ; ] 2bi ;
M: kqueue-mx remove-input-callbacks ( fd mx -- seq ) M: kqueue-mx remove-input-callbacks
2dup reads>> key? [ 2dup reads>> key? [
[ call-next-method ] [ [ call-next-method ] [
[ EVFILT_READ EV_DELETE make-kevent ] dip [ EVFILT_READ EV_DELETE make-kevent ] dip
@ -49,7 +49,7 @@ M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
] 2bi ] 2bi
] [ 2drop f ] if ; ] [ 2drop f ] if ;
M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) M: kqueue-mx remove-output-callbacks
2dup writes>> key? [ 2dup writes>> key? [
[ [
[ EVFILT_WRITE EV_DELETE make-kevent ] dip [ 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 [ dup events>> ] dip head-slice
[ handle-kevent ] with each ; [ handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( nanos mx -- ) M: kqueue-mx wait-for-events
swap dup [ make-timespec ] when swap dup [ make-timespec ] when
dupd wait-kevent handle-kevents ; dupd wait-kevent handle-kevents ;

2
basis/io/backend/unix/multiplexers/run-loop/run-loop.factor
View File

@ -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-input-callbacks kqueue-mx>> remove-input-callbacks ;
M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-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 ; swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ;

18
basis/io/backend/unix/unix.factor
View File

@ -37,7 +37,7 @@ M: fd dispose
M: fd handle-fd check-disposed fd>> ; M: fd handle-fd check-disposed fd>> ;
M: fd cancel-operation ( fd -- ) M: fd cancel-operation
[ [
fd>> fd>>
mx get-global mx get-global
@ -46,10 +46,10 @@ M: fd cancel-operation ( fd -- )
2bi 2bi
] unless-disposed ; ] unless-disposed ;
M: unix tell-handle ( handle -- n ) M: unix tell-handle
fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ; fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ;
M: unix seek-handle ( n seek-type handle -- ) M: unix seek-handle
swap { swap {
{ io:seek-absolute [ SEEK_SET ] } { io:seek-absolute [ SEEK_SET ] }
{ io:seek-relative [ SEEK_CUR ] } { io:seek-relative [ SEEK_CUR ] }
@ -58,10 +58,10 @@ M: unix seek-handle ( n seek-type handle -- )
} case } case
[ fd>> swap ] dip [ lseek ] unix-system-call drop ; [ 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 ; fd>> SEEK_CUR 0 lseek -1 = not ;
M: unix handle-length ( handle -- n/f ) M: unix handle-length
fd>> \ stat <struct> [ fstat -1 = not ] keep fd>> \ stat <struct> [ fstat -1 = not ] keep
swap [ st_size>> ] [ drop f ] if ; swap [ st_size>> ] [ drop f ] if ;
@ -69,7 +69,7 @@ ERROR: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ; 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 ] [ dup +retry+ eq? [ 2drop ] [
[ [ self ] dip handle-fd mx get-global ] dip { [ [ self ] dip handle-fd mx get-global ] dip {
{ +input+ [ add-input-callback ] } { +input+ [ add-input-callback ] }
@ -96,7 +96,7 @@ M: fd refill
} case } case
] if ; ] if ;
M: unix (wait-to-read) ( port -- ) M: unix (wait-to-read)
dup dup
dup handle>> check-disposed refill dup dup handle>> check-disposed refill dup
[ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ; [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
@ -116,12 +116,12 @@ M: fd drain
} case } case
] if ; ] if ;
M: unix (wait-to-write) ( port -- ) M: unix (wait-to-write)
dup dup
dup handle>> check-disposed drain dup handle>> check-disposed drain
[ wait-for-port ] [ drop ] if* ; [ wait-for-port ] [ drop ] if* ;
M: unix io-multiplex ( nanos -- ) M: unix io-multiplex
mx get-global wait-for-events ; mx get-global wait-for-events ;
! On Unix, you're not supposed to set stdin to non-blocking ! On Unix, you're not supposed to set stdin to non-blocking

2
basis/io/directories/unix/linux/linux.factor
View File

@ -10,7 +10,7 @@ IN: io.directories.unix.linux
readdir64_r [ (throw-errno) ] unless-zero readdir64_r [ (throw-errno) ] unless-zero
] 2keep void* deref ; inline ] 2keep void* deref ; inline
M: linux (directory-entries) ( path -- seq ) M: linux (directory-entries)
[ [
dirent <struct> dirent <struct>
'[ _ _ next-dirent ] [ >directory-entry ] produce nip '[ _ _ next-dirent ] [ >directory-entry ] produce nip

16
basis/io/directories/unix/unix.factor
View File

@ -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 CONSTANT: mkdir-mode flags{ USER-ALL GROUP-ALL OTHER-ALL } ! 0o777
M: unix touch-file ( path -- ) M: unix touch-file
normalize-path normalize-path
dup exists? [ touch ] [ dup exists? [ touch ] [
touch-mode file-mode open-file close-file touch-mode file-mode open-file close-file
] if ; ] if ;
M: unix move-file-atomically ( from to -- ) M: unix move-file-atomically
[ normalize-path ] bi@ [ rename ] unix-system-call drop ; [ normalize-path ] bi@ [ rename ] unix-system-call drop ;
M: unix move-file ( from to -- ) M: unix move-file
[ move-file-atomically ] [ [ move-file-atomically ] [
dup errno>> EXDEV = [ dup errno>> EXDEV = [
drop [ copy-file ] [ drop delete-file ] 2bi drop [ copy-file ] [ drop delete-file ] 2bi
] [ rethrow ] if ] [ rethrow ] if
] recover ; ] 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 ; 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 ; normalize-path [ rmdir ] unix-system-call drop ;
M: unix copy-file ( from to -- ) M: unix copy-file
[ call-next-method ] [ call-next-method ]
[ [ file-permissions ] dip swap set-file-permissions ] 2bi ; [ [ 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 dup +unknown+ = [ drop dup file-info type>> ] when
<directory-entry> ; inline <directory-entry> ; inline
M: unix (directory-entries) ( path -- seq ) M: unix (directory-entries)
[ [
dirent <struct> dirent <struct>
'[ _ _ next-dirent ] [ >directory-entry ] produce nip '[ _ _ next-dirent ] [ >directory-entry ] produce nip

14
basis/io/directories/windows/windows.factor
View File

@ -7,17 +7,17 @@ windows.kernel32 alien.c-types sequences splitting
fry continuations classes.struct windows.time ; fry continuations classes.struct windows.time ;
IN: io.directories.windows IN: io.directories.windows
M: windows touch-file ( path -- ) M: windows touch-file
[ [
normalize-path normalize-path
maybe-create-file [ &dispose ] dip maybe-create-file [ &dispose ] dip
[ drop ] [ handle>> f now dup (set-file-times) ] if [ drop ] [ handle>> f now dup (set-file-times) ] if
] with-destructors ; ] with-destructors ;
M: windows move-file ( from to -- ) M: windows move-file
[ normalize-path ] bi@ MoveFile win32-error=0/f ; [ 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 ; [ normalize-path ] bi@ 0 MoveFileEx win32-error=0/f ;
ERROR: file-delete-failed path error ; ERROR: file-delete-failed path error ;
@ -34,16 +34,16 @@ ERROR: file-delete-failed path error ;
[ delete-read-only-file ] [ drop win32-error ] if [ delete-read-only-file ] [ drop win32-error ] if
] [ drop ] if ; ] [ drop ] if ;
M: windows delete-file ( path -- ) M: windows delete-file
absolute-path absolute-path
[ (delete-file) ] [ (delete-file) ]
[ file-delete-failed boa rethrow ] recover ; [ file-delete-failed boa rethrow ] recover ;
M: windows make-directory ( path -- ) M: windows make-directory
normalize-path normalize-path
f CreateDirectory win32-error=0/f ; f CreateDirectory win32-error=0/f ;
M: windows delete-directory ( path -- ) M: windows delete-directory
normalize-path normalize-path
RemoveDirectory win32-error=0/f ; RemoveDirectory win32-error=0/f ;
@ -71,7 +71,7 @@ C: <windows-directory-entry> windows-directory-entry
[ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ] tri [ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ] tri
<windows-directory-entry> ; inline <windows-directory-entry> ; inline
M: windows (directory-entries) ( path -- seq ) M: windows (directory-entries)
"\\" ?tail drop "\\*" append "\\" ?tail drop "\\*" append
WIN32_FIND_DATA <struct> WIN32_FIND_DATA <struct>
find-first-file over find-first-file over

2
basis/io/encodings/euc/euc.factor
View File

@ -12,7 +12,7 @@ TUPLE: euc { table biassoc read-only } ;
: byte? ( ch -- ? ) : byte? ( ch -- ? )
0x0 0xff between? ; 0x0 0xff between? ;
M: euc encode-char ( char stream encoding -- ) M: euc encode-char
swapd table>> value-at [ swapd table>> value-at [
dup byte? dup byte?
[ swap stream-write1 ] [ [ swap stream-write1 ] [

4
basis/io/encodings/gb18030/gb18030.factor
View File

@ -92,7 +92,7 @@ ascii <file-reader> xml>gb-data
[ ufirst>> - ] [ bfirst>> ] bi + unlinear [ ufirst>> - ] [ bfirst>> ] bi + unlinear
] [ encode-error ] if* ; ] [ encode-error ] if* ;
M: gb18030 encode-char ( char stream encoding -- ) M: gb18030 encode-char
drop [ drop [
dup mapping get-global at dup mapping get-global at
[ ] [ lookup-range ] ?if [ ] [ lookup-range ] ?if
@ -128,7 +128,7 @@ M: gb18030 encode-char ( char stream encoding -- )
[ 3drop replacement-char ] [ 3drop replacement-char ]
} cond ; } cond ;
M: gb18030 decode-char ( stream encoding -- char ) M: gb18030 decode-char
drop dup stream-read1 { drop dup stream-read1 {
{ [ dup not ] [ 2drop f ] } { [ dup not ] [ 2drop f ] }
{ [ dup ascii? ] [ nip 1byte-array mapping get-global value-at ] } { [ dup ascii? ] [ nip 1byte-array mapping get-global value-at ] }

Some files were not shown because too many files have changed in this diff Show More