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 )
n bs subseq-endian execute( bignum n bs -- bits ) ;
M: lsb0-bit-reader peek ( n bs -- bits )
M: lsb0-bit-reader peek
\ le> \ subseq>bits-le (peek) ;
M: msb0-bit-reader peek ( n bs -- bits )
M: msb0-bit-reader peek
\ be> \ subseq>bits-be (peek) ;
:: bit-writer-bytes ( writer -- bytes )

4
basis/channels/channels.factor
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -61,7 +61,7 @@ C: <ryba> ryba
PRIVATE>
M: ryba >rgba ( ryba -- rgba )
M: ryba >rgba
[
[ red>> ] [ yellow>> ] [ blue>> ] tri
[ 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 ]
} cleave ;
M: #alien-invoke emit-node ( block node -- block' )
M: #alien-invoke emit-node
params>>
[
[ params>alien-insn-params ]
@ -104,7 +104,7 @@ M: #alien-invoke emit-node ( block node -- block' )
]
[ caller-return ] bi ;
M: #alien-indirect emit-node ( block node -- block' )
M: #alien-indirect emit-node
params>>
[
[ ds-pop ^^unbox-any-c-ptr ] dip
@ -113,7 +113,7 @@ M: #alien-indirect emit-node ( block node -- block' )
]
[ caller-return ] bi ;
M: #alien-assembly emit-node ( block node -- block' )
M: #alien-assembly emit-node
params>>
[
[ params>alien-insn-params ]
@ -167,7 +167,7 @@ M: #alien-assembly emit-node ( block node -- block' )
: emit-callback-outputs ( block params -- )
[ emit-callback-return ] keep callback-stack-cleanup ;
M: #alien-callback emit-node ( block node -- block' )
M: #alien-callback emit-node
dup params>> xt>> dup
[
t cfg get frame-pointer?<<

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? f 3array 2array record-reg-reps ;
M: struct-c-type unbox ( src c-type -- vregs reps )
M: struct-c-type unbox
[ ^^unbox-any-c-ptr ] dip explode-struct ;
: frob-struct ( c-type -- c-type )

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

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

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

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

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

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

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

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

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

@ -13,7 +13,7 @@ M: thread mailbox-of
[ { mailbox } declare ]
[ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
M: thread send ( message thread -- )
M: thread send
mailbox-of mailbox-put ;
: 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 } ;
C: <couchdb-error> couchdb-error
M: couchdb-error error. ( error -- )
M: couchdb-error error.
"CouchDB Error: " write data>>
"error" over at [ 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-store? cpu ( n -- ? )
M: object immediate-comparand? ( n -- ? )
M: object immediate-comparand?
{
{ [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
{ [ 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 ;
IN: cpu.ppc.32.linux
M: linux lr-save ( -- n ) 1 cells ;
M: linux lr-save 1 cells ;
M: linux has-toc ( -- ? ) f ;
M: linux has-toc f ;
M: linux reserved-area-size ( -- n ) 2 cells ;
M: linux reserved-area-size 2 cells ;
M: linux allows-null-dereference ( -- ? ) f ;
M: linux allows-null-dereference f ;
M: ppc param-regs
drop {
@ -35,7 +35,7 @@ M: ppc long-long-odd-register? t ;
M: ppc float-right-align-on-stack? f ;
M: ppc flatten-struct-type ( type -- seq )
M: ppc flatten-struct-type
{
{ [ dup lookup-c-type complex-double lookup-c-type = ]
[ drop { { int-rep f f } { int-rep f f }

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 has-toc ( -- ? ) t ;
M: linux has-toc t ;
M: linux reserved-area-size ( -- n ) 6 cells ;
M: linux reserved-area-size 6 cells ;
M: linux allows-null-dereference ( -- ? ) f ;
M: linux allows-null-dereference f ;
M: ppc param-regs
drop {
@ -33,7 +33,7 @@ M: ppc long-long-odd-register? f ;
M: ppc float-right-align-on-stack? t ;
M: ppc flatten-struct-type ( type -- seq )
M: ppc flatten-struct-type
{
{ [ dup lookup-c-type complex-double lookup-c-type = ]
[ drop { { double-rep f f } { double-rep f f } } ] }
@ -42,7 +42,7 @@ M: ppc flatten-struct-type ( type -- seq )
[ heap-size cell align cell /i { int-rep f f } <repetition> ]
} cond ;
M: ppc flatten-struct-type-return ( type -- seq )
M: ppc flatten-struct-type-return
{
{ [ dup lookup-c-type complex-double lookup-c-type = ]
[ drop { { double-rep f f } { double-rep f f } } ] }

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

@ -115,16 +115,16 @@ IN: cpu.ppc.assembler
! 2.4 Branch Instructions
GENERIC: B ( target_addr/label -- )
M: integer B ( target_addr -- ) -2 shift 0 0 18 i-insn ;
M: integer B -2 shift 0 0 18 i-insn ;
GENERIC: BL ( target_addr/label -- )
M: integer BL ( target_addr -- ) -2 shift 0 1 18 i-insn ;
M: integer BL -2 shift 0 1 18 i-insn ;
: BA ( target_addr -- ) -2 shift 1 0 18 i-insn ;
: BLA ( target_addr -- ) -2 shift 1 1 18 i-insn ;
GENERIC: BC ( bo bi target_addr/label -- )
M: integer BC ( bo bi target_addr -- ) -2 shift 0 0 16 b-insn ;
M: integer BC -2 shift 0 0 16 b-insn ;
: BCA ( bo bi target_addr -- ) -2 shift 1 0 16 b-insn ;
: BCL ( bo bi target_addr -- ) -2 shift 0 1 16 b-insn ;

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

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

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

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

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

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 ;
M: x86.64 flatten-struct-type ( c-type -- seq )
M: x86.64 flatten-struct-type
dup heap-size 16 <=
[ flatten-small-struct record-reg-reps ] [
call-next-method unrecord-reg-reps
[ first t f 3array ] map
] if ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
M: x86.64 return-struct-in-registers?
heap-size 2 cells <= ;
M: x86.64 dummy-stack-params? f ;
@ -54,6 +54,6 @@ M: x86.64 dummy-int-params? f ;
M: x86.64 dummy-fp-params? f ;
M: x86.64 %prepare-var-args ( reg-inputs -- )
M: x86.64 %prepare-var-args
[ second reg-class-of float-regs? ] count 8 min
[ EAX EAX XOR ] [ <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 return-struct-in-registers? ( c-type -- ? )
M: x86.64 return-struct-in-registers?
heap-size { 1 2 4 8 } member? ;
M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;
@ -24,5 +24,4 @@ M: x86.64 dummy-int-params? t ;
M: x86.64 dummy-fp-params? t ;
M: x86.64 %prepare-var-args ( reg-inputs -- )
drop ;
M: x86.64 %prepare-var-args drop ;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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*
] unless* ;
M: jedit editor-command ( file line -- command/f )
M: jedit editor-command
[
find-jedit-path ,
"-reuseview" ,

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

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

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

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

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

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

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

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

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*
] unless* ;
M: sublime editor-command ( file line -- command )
M: sublime editor-command
[
sublime-path , "-a" , number>string ":" glue ,
] { } make ;

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

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

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*
] unless* ;
M: textadept editor-command ( file line -- command )
M: textadept editor-command
swap [
textadept-path , "-f" , , "-e" ,
1 - number>string "goto_line(" ")" surround ,

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

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

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

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

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

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

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

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

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 )
\ vim-path get [ find-vim-path ] unless* ;
M: vim editor-command ( file line -- command )
M: vim editor-command
[
actual-vim-path dup string? [ , ] [ % ] if
vim-ui? [ "-g" , ] when

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" ]
} 0|| ;
M: visual-studio-code editor-command ( file line -- command )
M: visual-studio-code editor-command
[
visual-studio-code-invocation
[ , ] [ can't-find-visual-studio-code ] if*

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
] unless* ;
M: wordpad editor-command ( file line -- command )
M: wordpad editor-command
drop [ wordpad-path ] dip 2array ;

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

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

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

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

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

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

2
basis/fry/fry.factor
View File

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

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

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

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

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

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

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

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

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

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>
[ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
M: basic-auth-realm login-required* ( description capabilities realm -- response )
M: basic-auth-realm login-required*
2nip name>> <401> ;
M: basic-auth-realm logged-in-username ( realm -- uid )
M: basic-auth-realm logged-in-username
drop
request get "authorization" header parse-basic-auth
dup [ over check-login swap and ] [ 2drop f ] if ;

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

@ -29,7 +29,7 @@ M: login-realm init-realm
M: login-realm logged-in-username
drop permit-id get dup [ get-permit-uid ] when ;
M: login-realm modify-form ( responder -- xml/f )
M: login-realm modify-form
drop permit-id get realm get name>> permit-id-key hidden-form-field ;
: <permit-cookie> ( -- cookie )
@ -95,7 +95,7 @@ CONSTANT: flashed-variables { description capabilities }
<action>
[ logout ] >>submit ;
M: login-realm login-required* ( description capabilities login -- response )
M: login-realm login-required*
begin-conversation
[ description cset ] [ capabilities cset ] [ secure>> ] tri*
[
@ -106,7 +106,7 @@ M: login-realm login-required* ( description capabilities login -- response )
URL" $realm/login" <continue-conversation>
] if ;
M: login-realm user-registered ( user realm -- response )
M: login-realm user-registered
drop successful-login ;
: <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 )
H{ } clone users-in-memory boa ;
M: users-in-memory get-user ( username provider -- user/f )
assoc>> at ;
M: users-in-memory get-user assoc>> at ;
M: users-in-memory update-user ( user provider -- ) 2drop ;
M: users-in-memory update-user 2drop ;
M: users-in-memory new-user ( user provider -- user/f )
M: users-in-memory new-user
[ dup username>> ] dip assoc>>
2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;

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

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

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

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

@ -98,10 +98,10 @@ CONSTANT: session-id-key "__s"
: put-session-cookie ( response -- response' )
<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 ;
M: sessions call-responder* ( path responder -- response )
M: sessions call-responder*
sessions set
request-session [ begin-session ] unless*
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
] when ;
M: iokit-game-input-backend get-controllers ( -- sequence )
M: iokit-game-input-backend get-controllers
+controller-states+ get-global keys [ controller boa ] map ;
: ?join ( pre post sep -- string )
2over subseq-start [ swap 2nip ] [ [ 2array ] dip join ] if ;
M: iokit-game-input-backend product-string ( controller -- string )
M: iokit-game-input-backend product-string
handle>>
[ kIOHIDManufacturerKey device-property ]
[ kIOHIDProductKey device-property ] bi " " ?join ;
M: iokit-game-input-backend product-id ( controller -- integer )
M: iokit-game-input-backend product-id
handle>>
[ kIOHIDVendorIDKey device-property ]
[ kIOHIDProductIDKey device-property ] bi 2array ;
M: iokit-game-input-backend instance-id ( controller -- integer )
M: iokit-game-input-backend instance-id
handle>> kIOHIDLocationIDKey device-property ;
M: iokit-game-input-backend read-controller ( controller -- controller-state )
M: iokit-game-input-backend read-controller
handle>> +controller-states+ get-global at clone ;
M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
M: iokit-game-input-backend read-keyboard
+keyboard-state+ get-global clone keyboard-state boa ;
M: iokit-game-input-backend calibrate-controller ( controller -- )
M: iokit-game-input-backend calibrate-controller
drop ;

8
basis/heaps/heaps.factor
View File

@ -35,11 +35,9 @@ TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
M: heap heap-empty? ( heap -- ? )
data>> empty? ; inline
M: heap heap-empty? data>> empty? ; inline
M: heap heap-size ( heap -- n )
data>> length ; inline
M: heap heap-size data>> length ; inline
<PRIVATE
@ -75,7 +73,7 @@ PRIVATE>
: >entry< ( entry -- value key )
[ value>> ] [ key>> ] bi ; inline
M: heap heap-peek ( heap -- value key )
M: heap heap-peek
data>> first >entry< ;
<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 -- )
M: singleton-class component-tag ( tag class -- )
M: singleton-class component-tag
[ "name" required-attr compile-attr ]
[ literalize render-quot [code-with] ]
bi* ;
@ -26,7 +26,7 @@ M: singleton-class component-tag ( tag class -- )
[ [ boa ] [code-with] ]
bi ;
M: tuple-class component-tag ( tag class -- )
M: tuple-class component-tag
[ drop "name" required-attr compile-attr ]
[ compile-component-attrs ] 2bi
render-quot [code] ;

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

@ -71,7 +71,7 @@ TUPLE: fhtml path ;
C: <fhtml> fhtml
M: fhtml call-template* ( filename -- )
M: fhtml call-template*
path>> utf8 file-contents eval-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
] if ;
M: dispatcher call-responder* ( path dispatcher -- response )
M: dispatcher call-responder*
find-responder call-responder ;
TUPLE: vhost-dispatcher default responders ;
@ -38,7 +38,7 @@ TUPLE: vhost-dispatcher default responders ;
url get host>> canonical-host over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
M: vhost-dispatcher call-responder*
find-vhost call-responder ;
: add-responder ( dispatcher responder path -- dispatcher )

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

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

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> ]
if ;
M: file-responder call-responder* ( path responder -- response )
M: file-responder call-responder*
file-responder set
".." over member?
[ drop <400> ] [ "/" join serve-object ] if ;

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

@ -106,5 +106,5 @@ M: gdi+-image stream>image*
gdi+-bitmap>data
data>image ;
M: gdi+-image image>stream ( image extension class -- )
M: gdi+-image image>stream
drop startup-gdi+ output-stream get swap write-image-to-stream ;

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 ;
IN: io.backend.unix.bsd
M: bsd init-io ( -- )
M: bsd init-io
<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
M: freebsd init-io ( -- )
M: freebsd init-io
<kqueue-mx> mx set-global ;
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 ;
IN: io.backend.unix.linux
M: linux init-io ( -- )
M: linux init-io
<epoll-mx> mx set-global ;
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
M: macosx-kqueue init-io ( -- )
M: macosx-kqueue init-io
<kqueue-mx> mx set-global ;
M: macosx init-io ( -- )
M: macosx init-io
<run-loop-mx> mx set-global ;
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 -- )
EPOLL_CTL_DEL swap do-epoll-ctl ;
M: epoll-mx add-input-callback ( thread fd mx -- )
M: epoll-mx add-input-callback
[ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ;
M: epoll-mx add-output-callback ( thread fd mx -- )
M: epoll-mx add-output-callback
[ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ;
M: epoll-mx remove-input-callbacks ( fd mx -- seq )
M: epoll-mx remove-input-callbacks
2dup reads>> key? [
[ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
] [ 2drop f ] if ;
M: epoll-mx remove-output-callbacks ( fd mx -- seq )
M: epoll-mx remove-output-callbacks
2dup writes>> key? [
[ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi
] [ 2drop f ] if ;
@ -62,5 +62,5 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
: handle-events ( mx n -- )
[ dup events>> ] dip head-slice swap '[ _ handle-event ] each ;
M: epoll-mx wait-for-events ( nanos mx -- )
M: epoll-mx wait-for-events
swap 60000000 or dupd wait-event handle-events ;

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

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

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

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
] 2keep void* deref ; inline
M: linux (directory-entries) ( path -- seq )
M: linux (directory-entries)
[
dirent <struct>
'[ _ _ 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
M: unix touch-file ( path -- )
M: unix touch-file
normalize-path
dup exists? [ touch ] [
touch-mode file-mode open-file close-file
] if ;
M: unix move-file-atomically ( from to -- )
M: unix move-file-atomically
[ normalize-path ] bi@ [ rename ] unix-system-call drop ;
M: unix move-file ( from to -- )
M: unix move-file
[ move-file-atomically ] [
dup errno>> EXDEV = [
drop [ copy-file ] [ drop delete-file ] 2bi
] [ rethrow ] if
] recover ;
M: unix delete-file ( path -- ) normalize-path unlink-file ;
M: unix delete-file normalize-path unlink-file ;
M: unix make-directory ( path -- )
M: unix make-directory
normalize-path mkdir-mode [ mkdir ] unix-system-call drop ;
M: unix delete-directory ( path -- )
M: unix delete-directory
normalize-path [ rmdir ] unix-system-call drop ;
M: unix copy-file ( from to -- )
M: unix copy-file
[ call-next-method ]
[ [ file-permissions ] dip swap set-file-permissions ] 2bi ;
@ -71,7 +71,7 @@ M: unix copy-file ( from to -- )
dup +unknown+ = [ drop dup file-info type>> ] when
<directory-entry> ; inline
M: unix (directory-entries) ( path -- seq )
M: unix (directory-entries)
[
dirent <struct>
'[ _ _ 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 ;
IN: io.directories.windows
M: windows touch-file ( path -- )
M: windows touch-file
[
normalize-path
maybe-create-file [ &dispose ] dip
[ drop ] [ handle>> f now dup (set-file-times) ] if
] with-destructors ;
M: windows move-file ( from to -- )
M: windows move-file
[ normalize-path ] bi@ MoveFile win32-error=0/f ;
M: windows move-file-atomically ( from to -- )
M: windows move-file-atomically
[ normalize-path ] bi@ 0 MoveFileEx win32-error=0/f ;
ERROR: file-delete-failed path error ;
@ -34,16 +34,16 @@ ERROR: file-delete-failed path error ;
[ delete-read-only-file ] [ drop win32-error ] if
] [ drop ] if ;
M: windows delete-file ( path -- )
M: windows delete-file
absolute-path
[ (delete-file) ]
[ file-delete-failed boa rethrow ] recover ;
M: windows make-directory ( path -- )
M: windows make-directory
normalize-path
f CreateDirectory win32-error=0/f ;
M: windows delete-directory ( path -- )
M: windows delete-directory
normalize-path
RemoveDirectory win32-error=0/f ;
@ -71,7 +71,7 @@ C: <windows-directory-entry> windows-directory-entry
[ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ] tri
<windows-directory-entry> ; inline
M: windows (directory-entries) ( path -- seq )
M: windows (directory-entries)
"\\" ?tail drop "\\*" append
WIN32_FIND_DATA <struct>
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 -- ? )
0x0 0xff between? ;
M: euc encode-char ( char stream encoding -- )
M: euc encode-char
swapd table>> value-at [
dup byte?
[ 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
] [ encode-error ] if* ;
M: gb18030 encode-char ( char stream encoding -- )
M: gb18030 encode-char
drop [
dup mapping get-global at
[ ] [ lookup-range ] ?if
@ -128,7 +128,7 @@ M: gb18030 encode-char ( char stream encoding -- )
[ 3drop replacement-char ]
} cond ;
M: gb18030 decode-char ( stream encoding -- char )
M: gb18030 decode-char
drop dup stream-read1 {
{ [ dup not ] [ 2drop f ] }
{ [ dup ascii? ] [ nip 1byte-array mapping get-global value-at ] }

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