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 )
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
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 ;
[
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
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
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 ;
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
: 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
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
] [
C: <gray> gray
-M: gray >rgba ( gray -- rgba )
+M: gray >rgba
[ gray>> dup dup ] [ alpha>> ] bi <rgba> ; inline
M: gray red>> gray>> ;
PRIVATE>
-M: hsva >rgba ( hsva -- rgba )
+M: hsva >rgba
[
dup Hi
{
PRIVATE>
-M: ryba >rgba ( ryba -- rgba )
+M: ryba >rgba
[
[ red>> ] [ yellow>> ] [ blue>> ] tri
[ ryb>rgb ] normalized
[ 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 ]
]
[ caller-return ] bi ;
-M: #alien-indirect emit-node ( block node -- block' )
+M: #alien-indirect emit-node
params>>
[
[ ds-pop ^^unbox-any-c-ptr ] dip
]
[ caller-return ] bi ;
-M: #alien-assembly emit-node ( block node -- block' )
+M: #alien-assembly emit-node
params>>
[
[ params>alien-insn-params ]
: 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?<<
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 )
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 ;
##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
! 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
[ 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* ;
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
: 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
: 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 ;
: 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 ( -- )
[ { 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
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* ;
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 ] }
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 {
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 }
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 {
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 } } ] }
[ 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 } } ] }
! 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 ;
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
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
: 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 -- )
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* ;
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.
} 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 ;
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 ] }
{ 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 ;
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 ;
} ;
! 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
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
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.
{ c:ulonglong [ ] }
} case ;
-M: ppc.32 %load-memory-imm ( dst base offset rep c-type -- )
+M: ppc.32 %load-memory-imm
[
pick %trap-null
{
} case
] ?if ;
-M: ppc.64 %load-memory-imm ( dst base offset rep c-type -- )
+M: ppc.64 %load-memory-imm
[
pick %trap-null
{
] ?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
} 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
] ?if ;
-M: ppc.32 %store-memory-imm ( src base offset rep c-type -- )
+M: ppc.32 %store-memory-imm
[
{
{ c:char [ STB ] }
} case
] ?if ;
-M: ppc.64 %store-memory-imm ( src base offset rep c-type -- )
+M: ppc.64 %store-memory-imm
[
{
{ c:char [ STB ] }
} case
] ?if ;
-M: ppc.32 %store-memory ( src base displacement scale offset rep c-type -- )
+M: ppc.32 %store-memory
[ [ 0 assert= ] bi@ ] 2dip
[
{
} case
] ?if ;
-M: ppc.64 %store-memory ( src base displacement scale offset rep c-type -- )
+M: ppc.64 %store-memory
[ [ 0 assert= ] bi@ ] 2dip
[
{
{ 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 -- )
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 ] }
{ 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 ] }
{ 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
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
: 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
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 ] }
} 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* ] }
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 ] }
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 ] }
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 ;
! 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
[ 0 ]
} cond ;
-M: x86.32 %cleanup ( n -- )
+M: x86.32 %cleanup
[ ESP swap SUB ] unless-zero ;
M: x86.32 %safepoint
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
: 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
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 -- )
[ 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 ;
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
] [ 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 ;
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 ;
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? ;
M: x86.64 dummy-fp-params? t ;
-M: x86.64 %prepare-var-args ( reg-inputs -- )
- drop ;
+M: x86.64 %prepare-var-args drop ;
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 ;
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 ;
: 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 ;
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
{ 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
{ 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 ] }
{ 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 ;
{ sse2? { int-4-rep } }
} available-reps ;
-M: x86 %float>integer-vector ( dst src rep -- )
+M: x86 %float>integer-vector
{
{ float-4-rep [ CVTTPS2DQ ] }
} case ;
{ 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 ]
[ 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
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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
{ 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
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
{ 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 ] }
] }
} 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 ] }
: 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 +
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
[ [ 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
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
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 ;
: ?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
{ 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 -- )
: %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 ] }
} 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 -- )
} 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? ;
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
[ (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 -- )
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
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 ;
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 -- )
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
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) ;
: 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
GENERIC: execute-statement* ( statement type -- )
-M: object execute-statement* ( statement type -- )
+M: object execute-statement*
'[
_ _ drop query-results dispose
] [
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 ;
: 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 -- )
ERROR: postgresql-result-null ;
-M: postgresql-result-null summary ( obj -- str )
+M: postgresql-result-null summary
drop "PQexec returned f." ;
: postgresql-result-ok? ( res -- ? )
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 )
TUPLE: postgresql-result-set < result-set ;
-M: postgresql-db db-open ( db -- db-connection )
+M: postgresql-db db-open
{
[ host>> ]
[ port>> ]
[ 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
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
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, ;
"_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
"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%
");" 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%
");" 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 } }
} ;
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 ] }
] if
] 2map >>bind-params ;
-M: retryable execute-statement* ( statement type -- )
+M: retryable execute-statement*
drop [ retries>> <iota> ] [
[
nip
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%
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
: 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' )
[
: 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
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
[ 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* ;
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 )
>>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 ;
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> ;
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 ;
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%
");" 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 } }
");" 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 ] }
unix.signals ;
IN: debugger.unix
-M: unix signal-error. ( obj -- )
+M: unix signal-error.
"Unix signal #" write
third [ pprint ] [ signal-name. ] bi nl ;
f
] if* ;
-M: atom-editor editor-command ( file line -- command )
+M: atom-editor editor-command
[
atom-path get [ find-atom ] unless* ,
number>string ":" glue ,
SINGLETON: bbedit
bbedit editor-class set-global
-M: bbedit editor-command ( file line -- command )
+M: bbedit editor-command
drop
[ "open" , "-a" , "BBEdit" , , ] { } make ;
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
f
] if* ;
-M: coteditor editor-command ( file line -- command )
+M: coteditor editor-command
[ find-cot-bundle-path , "-l" , number>string , , ] { } make ;
} 0||
] unless* ;
-M: editpadpro editor-command ( file line -- command )
+M: editpadpro editor-command
[
editpadpro-path , number>string "/l" prepend , ,
] { } make ;
[ "editplus.exe" ] unless*
] unless* ;
-M: editplus editor-command ( file line -- command )
+M: editplus editor-command
[
editplus-path , "-cursor" , number>string , ,
] { } make ;
HOOK: find-emacsclient os ( -- path )
-M: object find-emacsclient ( -- path )
+M: object find-emacsclient
"emacsclient" ?find-in-path ;
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* %
[ "EmEditor.exe" ] unless*
] unless* ;
-M: emeditor editor-command ( file line -- command )
+M: emeditor editor-command
[
emeditor-path , "/l" , number>string , ,
] { } make ;
[ "e.exe" ] unless*
] unless* ;
-M: etexteditor editor-command ( file line -- command )
+M: etexteditor editor-command
[
etexteditor-path ,
[ , ] [ "--line" , number>string , ] bi*
"gedit" ?find-in-path
] unless* ;
-M: gedit editor-command ( file line -- command )
+M: gedit editor-command
[
gedit-path , number>string "+" prepend , ,
] { } make ;
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" ,
[ "notepad++.exe" ] unless*
] unless* ;
-M: notepad++ editor-command ( file line -- command )
+M: notepad++ editor-command
[
notepad++-path ,
number>string "-n" prepend , ,
[ "notepad.exe" tail? ] find-file
] unless* ;
-M: notepad editor-command ( file line -- command )
+M: notepad editor-command
drop [ notepad-path ] dip 2array ;
[ "notepad.exe" ] unless*
] unless* ;
-M: notepad2 editor-command ( file line -- command )
+M: notepad2 editor-command
[
notepad2-path ,
"/g" , number>string , ,
} "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* ,
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 ;
[ "TedNPad.exe" ] unless*
] unless* ;
-M: ted-notepad editor-command ( file line -- command )
+M: ted-notepad editor-command
[
ted-notepad-path ,
number>string "/l" prepend , ,
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 ,
SINGLETON: textedit
textedit editor-class set-global
-M: textedit editor-command ( file line -- command )
+M: textedit editor-command
drop
[ "open" , "-a" , "TextEdit" , , ] { } make ;
SINGLETON: textmate
textmate editor-class set-global
-M: textmate editor-command ( file line -- command )
+M: textmate editor-command
[ "mate" , "-a" , "-l" , number>string , , ] { } make ;
[ "TextPad.exe" ] unless*
] unless* ;
-M: textpad editor-command ( file line -- command )
+M: textpad editor-command
[
textpad-path ,
[ , ] [ number>string "(" ",0)" surround , ] bi*
[ "uedit32.exe" ] unless*
] unless* ;
-M: ultraedit editor-command ( file line -- command )
+M: ultraedit editor-command
[
ultraedit-path , [ swap % "/" % # "/1" % ] "" make ,
] { } make ;
: 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
[ "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*
{ "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 ;
SINGLETON: xcode
xcode editor-class set-global
-M: xcode editor-command ( file line -- command )
+M: xcode editor-command
drop
[ "open" , "-a" , "XCode" , , ] { } make ;
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
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
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
PRIVATE>
-M: callable fry ( quot -- quot' )
+M: callable fry
[ [ [ ] ] ] [
0 swap <dredge-fry>
[ dredge-fry ] [
: 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 [
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 ]
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 ]
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 -- )
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
begin-form
handle-rest ;
-M: action call-responder* ( path action -- response )
+M: action call-responder*
[ init-action ] keep
request get method>> {
{ "GET" [ handle-get ] }
: 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 ] }
{ 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
\ 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
} cond
] if ;
-M: protected call-responder* ( path responder -- response )
+M: protected call-responder*
dup protected namespaces:set
dup capabilities>> have-capabilities?
[ call-next-method ] [
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 ;
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 )
<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*
[
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 )
: <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 ;
: <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 ]
bi
] [ drop ] if* ;
-M: conversations modify-form ( conversations -- xml/f )
+M: conversations modify-form
drop
conversation-id get
conversation-id-key
: 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 ;
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 ;
: <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
: >entry< ( entry -- value key )
[ value>> ] [ key>> ] bi ; inline
-M: heap heap-peek ( heap -- value key )
+M: heap heap-peek
data>> first >entry< ;
<PRIVATE
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* ;
[ [ 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] ;
C: <fhtml> fhtml
-M: fhtml call-template* ( filename -- )
+M: fhtml call-template*
path>> utf8 file-contents eval-template ;
INSTANCE: fhtml template
[ [ 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 ;
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 )
: 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 ]
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" = ;
[ 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 ;
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 ;
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 ;
<< "io.files.unix" require >> ! needed for deploy
-M: freebsd init-io ( -- )
+M: freebsd init-io
<kqueue-mx> mx set-global ;
-
+
freebsd set-io-backend
[ start-signal-pipe-thread ]
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
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
: 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 ;
: 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 ;
: 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
] 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
[ 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 ;
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 ;
M: fd handle-fd check-disposed fd>> ;
-M: fd cancel-operation ( fd -- )
+M: fd cancel-operation
[
fd>>
mx get-global
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 ] }
} 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 ;
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 ] }
} 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 ;
} 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
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
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 ;
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
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 ;
[ 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 ;
[ [ 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
: 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 ] [
[ 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
[ 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 ] }
bom-be sequence= [ utf32be ] [ missing-bom ] if
] if ;
-M: utf32 <decoder> ( stream utf32 -- decoder )
+M: utf32 <decoder>
drop 4 over stream-read bom>le/be <decoder> ;
-M: utf32 <encoder> ( stream utf32 -- encoder )
+M: utf32 <encoder>
drop bom-le over stream-write utf32le <encoder> ;
PRIVATE>
] until
] B{ } make 3nip ;
-M: utf7codec encode-string ( str stream codec -- )
+M: utf7codec encode-string
swapd encode-utf7-string swap stream-write ;
DEFER: emit-char
: replace-all! ( src dst -- )
[ delete-all ] keep push-all ;
-M: utf7codec decode-char ( stream codec -- char/f )
+M: utf7codec decode-char
swap [
[ dialect>> ] [ buffer>> ] bi [ emit-char ] keep replace-all!
] with-input-stream ;
TUPLE: bsd-file-info < unix-file-info birth-time flags gen ;
-M: bsd new-file-info ( -- class ) bsd-file-info new ;
+M: bsd new-file-info bsd-file-info new ;
-M: bsd stat>file-info ( stat -- file-info )
+M: bsd stat>file-info
[ call-next-method ] keep
{
[ st_flags>> >>flags ]
TUPLE: freebsd-file-info < unix-file-info birth-time flags gen ;
-M: freebsd new-file-info ( -- class ) freebsd-file-info new ;
+M: freebsd new-file-info freebsd-file-info new ;
-M: freebsd stat>file-info ( stat -- file-info )
+M: freebsd stat>file-info
[ call-next-method ] keep
{
[ st_flags>> >>flags ]
TUPLE: freebsd-file-system-info < unix-file-system-info
io-size owner type-id filesystem-subtype ;
-M: freebsd file-systems ( -- array )
+M: freebsd file-systems
f void* <ref> dup 0 getmntinfo dup io-error
[ void* deref ] dip \ statfs <c-direct-array>
[ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
M: freebsd new-file-system-info freebsd-file-system-info new ;
-M: freebsd file-system-statfs ( normalized-path -- statfs )
+M: freebsd file-system-statfs
\ statfs <struct> [ statfs-func io-error ] keep ;
-M: freebsd file-system-statvfs ( normalized-path -- statvfs )
+M: freebsd file-system-statvfs
\ statvfs <struct> [ statvfs-func io-error ] keep ;
-M: freebsd statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
+M: freebsd statfs>file-system-info
{
[ f_bsize>> >>block-size ]
[ f_iosize>> >>io-size ]
[ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
-M: freebsd statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
+M: freebsd statvfs>file-system-info
{
[ f_frsize>> >>preferred-block-size ]
[ f_favail>> >>files-available ]
M: linux new-file-system-info linux-file-system-info new ;
-M: linux file-system-statfs ( path -- statfs )
+M: linux file-system-statfs
\ statfs64 <struct> [ statfs64 io-error ] keep ;
-M: linux statfs>file-system-info ( file-system-info statfs -- file-system-info' )
+M: linux statfs>file-system-info
{
[ f_type>> >>type ]
[ f_bsize>> >>block-size ]
! [ statfs64-f_spare >>spare ]
} cleave ;
-M: linux file-system-statvfs ( path -- statvfs )
+M: linux file-system-statvfs
\ statvfs64 <struct> [ statvfs64 io-error ] keep ;
-M: linux statvfs>file-system-info ( file-system-info statfs -- file-system-info' )
+M: linux statvfs>file-system-info
{
[ f_flag>> >>flags ]
[ f_namemax>> >>name-max ]
M: linux file-systems
parse-mtab [ mtab-entry>file-system-info ] map sift ;
-M: linux file-system-info ( path -- file-system-info )
+M: linux file-system-info
normalize-path [ (file-system-info) ] [ ] bi
find-mount-point
{
TUPLE: macosx-file-info < unix-file-info birth-time flags gen ;
-M: macosx new-file-info ( -- class ) macosx-file-info new ;
+M: macosx new-file-info macosx-file-info new ;
-M: macosx stat>file-info ( stat -- file-info )
+M: macosx stat>file-info
[ call-next-method ] keep
{
[ st_flags>> >>flags ]
TUPLE: macosx-file-system-info < unix-file-system-info
io-size owner type-id filesystem-subtype ;
-M: macosx file-systems ( -- array )
+M: macosx file-systems
f void* <ref> dup 0 getmntinfo64 dup io-error
[ void* deref ] dip \ statfs64 <c-direct-array>
[ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
M: macosx new-file-system-info macosx-file-system-info new ;
-M: macosx file-system-statfs ( normalized-path -- statfs )
+M: macosx file-system-statfs
\ statfs64 <struct> [ statfs64-func io-error ] keep ;
-M: macosx file-system-statvfs ( normalized-path -- statvfs )
+M: macosx file-system-statvfs
\ statvfs <struct> [ statvfs-func io-error ] keep ;
-M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
+M: macosx statfs>file-system-info
{
[ f_bsize>> >>block-size ]
[ f_iosize>> >>io-size ]
[ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
-M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
+M: macosx statvfs>file-system-info
{
[ f_frsize>> >>preferred-block-size ]
[ f_favail>> >>files-available ]
HOOK: stat>type os ( stat -- file-info )
-M: unix file-info ( path -- info )
+M: unix file-info
normalize-path file-status stat>file-info ;
-M: unix link-info ( path -- info )
+M: unix link-info
normalize-path link-status stat>file-info ;
-M: unix new-file-info ( -- class ) unix-file-info new ;
+M: unix new-file-info unix-file-info new ;
CONSTANT: standard-unix-block-size 512
-M: unix stat>file-info ( stat -- file-info )
+M: unix stat>file-info
[ new-file-info ] dip
{
[ stat>type >>type ]
[ drop +unknown+ ]
} case ;
-M: unix stat>type ( stat -- type )
+M: unix stat>type
st_mode>> n>file-type ;
<PRIVATE
GENERIC: set-file-group ( path string/id -- )
-M: integer set-file-user ( path uid -- )
+M: integer set-file-user
f set-file-ids ;
-M: string set-file-user ( path string -- )
+M: string set-file-user
user-id f set-file-ids ;
-M: integer set-file-group ( path gid -- )
+M: integer set-file-group
f swap set-file-ids ;
-M: string set-file-group ( path string -- )
+M: string set-file-group
group-id
f swap set-file-ids ;
drop find-first-file-stat WIN32_FIND_DATA>file-info
] if ;
-M: windows file-info ( path -- info )
+M: windows file-info
normalize-path
[ get-file-information-stat ]
[ set-windows-size-on-disk ] bi ;
-M: windows link-info ( path -- info )
+M: windows link-info
file-info ;
: file-executable-type ( path -- executable/f )
PRIVATE>
-M: windows file-system-info ( path -- file-system-info )
+M: windows file-system-info
normalize-path root-directory (file-system-info) ;
CONSTANT: names-buf-length 16384
! Can error with T{ windows-error f 21 "The device is not ready." }
! if there is a D: that is not ready, for instance. Ignore these drives.
-M: windows file-systems ( -- array )
+M: windows file-systems
find-volumes [ volume>paths ] map concat [
[ (file-system-info) ] [ 2drop f ] recover
] map sift ;
sequences system unix unix.ffi ;
IN: io.files.links.unix
-M: unix make-link ( path1 path2 -- )
+M: unix make-link
normalize-path [ symlink ] unix-system-call drop ;
-M: unix make-hard-link ( path1 path2 -- )
+M: unix make-hard-link
normalize-path [ link ] unix-system-call drop ;
-M: unix read-link ( path -- path' )
+M: unix read-link
normalize-path read-symbolic-link ;
-M: unix resolve-symlinks ( path -- path' )
+M: unix resolve-symlinks
path-components "/"
[ append-path dup exists? [ follow-links ] when ] reduce ;
CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL }
-M: unix (touch-unique-file) ( path -- )
+M: unix (touch-unique-file)
open-unique-flags file-mode open-file close-file ;
io.files.windows system windows.kernel32 ;
IN: io.files.unique.windows
-M: windows (touch-unique-file) ( path -- )
+M: windows (touch-unique-file)
GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
] [ rethrow ] if
] recover ;
-M: unix cwd ( -- path )
+M: unix cwd
4096 (cwd) ;
-M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
+M: unix cd [ chdir ] unix-system-call drop ;
CONSTANT: read-flags flags{ O_RDONLY }
: open-read ( path -- fd ) read-flags file-mode open-file ;
-M: unix (file-reader) ( path -- stream )
+M: unix (file-reader)
open-read <fd> init-fd <input-port> ;
CONSTANT: write-flags flags{ O_WRONLY O_CREAT O_TRUNC }
: open-write ( path -- fd )
write-flags file-mode open-file ;
-M: unix (file-writer) ( path -- stream )
+M: unix (file-writer)
open-write <fd> init-fd <output-port> ;
CONSTANT: append-flags flags{ O_WRONLY O_APPEND O_CREAT }
dup 0 SEEK_END [ lseek ] unix-system-call drop
] with-destructors ;
-M: unix (file-appender) ( path -- stream )
+M: unix (file-appender)
open-append <fd> init-fd <output-port> ;
M: unix home "HOME" os-env ;
M: win32-handle cancel-operation
[ handle>> CancelIo win32-error=0/f ] unless-disposed ;
-M: windows io-multiplex ( nanos -- )
+M: windows io-multiplex
handle-overlapped [ 0 io-multiplex ] when ;
-M: windows init-io ( -- )
+M: windows init-io
<master-completion-port> master-completion-port set-global
H{ } clone pending-overlapped set-global ;
: set-seek-ptr ( n handle -- )
[ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
-M: windows tell-handle ( handle -- n ) ptr>> ;
+M: windows tell-handle ptr>> ;
-M: windows seek-handle ( n seek-type handle -- )
+M: windows seek-handle
swap {
{ seek-absolute [ set-seek-ptr ] }
{ seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
[ bad-seek-type ]
} case ;
-M: windows can-seek-handle? ( handle -- ? )
+M: windows can-seek-handle?
handle>> handle>file-size >boolean ;
-M: windows handle-length ( handle -- n/f )
+M: windows handle-length
handle>> handle>file-size
dup { 0 f } member? [ drop f ] when ;
: finish-write ( n port -- )
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
-M: object drain ( port handle -- event/f )
+M: object drain
[ make-FileArgs dup setup-write WriteFile ]
[ drop [ wait-for-file ] [ finish-write ] bi ] 2bi f ;
: finish-read ( n port -- )
[ update-file-ptr ] [ buffer>> buffer+ ] 2bi ;
-M: object refill ( port handle -- event/f )
+M: object refill
[ make-FileArgs dup setup-read ReadFile ]
[ drop [ wait-for-file ] [ finish-read ] bi ] 2bi f ;
-M: windows (wait-to-write) ( port -- )
+M: windows (wait-to-write)
[ dup handle>> drain ] with-destructors drop ;
-M: windows (wait-to-read) ( port -- )
+M: windows (wait-to-read)
[ dup handle>> refill ] with-destructors drop ;
: make-fd-set ( socket -- fd_set )
CONSTANT: select-timeval S{ timeval { sec 0 } { usec 1000 } }
-M: windows wait-for-fd ( handle event -- )
+M: windows wait-for-fd
[ file>> handle>> 1 swap ] dip select-sets select-timeval
select drop yield ;
[ [ handle>> ] dip d>w/w LONG <ref> ] dip SetFilePointer
INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
-M: windows (file-reader) ( path -- stream )
+M: windows (file-reader)
open-read <input-port> ;
-M: windows (file-writer) ( path -- stream )
+M: windows (file-writer)
open-write <output-port> ;
-M: windows (file-appender) ( path -- stream )
+M: windows (file-appender)
open-append <output-port> ;
SYMBOLS: +read-only+ +hidden+ +system+
CONSTANT: unicode-prefix "\\\\?\\"
-M: windows root-directory? ( path -- ? )
+M: windows root-directory?
{
{ [ dup empty? ] [ drop f ] }
{ [ dup [ path-separator? ] all? ] [ drop t ] }
M: windows relative-path remove-unicode-prefix relative-path* ;
-M: windows normalize-path ( string -- string' )
+M: windows normalize-path
dup unc-path? [
normalize-separators
] [
[ setup-environment ] [ 2drop 253 _exit ] recover
[ get-arguments posix-spawn ] [ drop ] recover ;
-M: unix (current-process) ( -- handle ) getpid ;
+M: unix (current-process) getpid ;
-M: unix (run-process) ( process -- pid )
+M: unix (run-process)
'[ _ fork-process ] [ ] with-fork ;
-M: unix (kill-process) ( process -- )
+M: unix (kill-process)
[ handle>> SIGTERM ] [ group>> ] bi {
{ +same-group+ [ kill ] }
{ +new-group+ [ killpg ] }
: code>status ( code -- obj )
dup WIFSIGNALED [ WTERMSIG sig:signal boa ] [ WEXITSTATUS ] if ;
-M: unix (wait-for-processes) ( -- ? )
+M: unix (wait-for-processes)
{ int } [ -1 swap WNOHANG waitpid ] with-out-parameters
swap dup 0 <= [
2drop t
fill-startup-info
nip ;
-M: windows (current-process) ( -- handle )
+M: windows (current-process)
GetCurrentProcessId ;
ERROR: launch-error process error ;
"Launch descriptor:" print nl
process>> . ;
-M: windows (kill-process) ( process -- )
+M: windows (kill-process)
handle>> hProcess>> 255 TerminateProcess win32-error=0/f ;
: dispose-process ( process-information -- )
over handle>> dispose-process
notify-exit ;
-M: windows (wait-for-processes) ( -- ? )
+M: windows (wait-for-processes)
processes get keys dup
[ handle>> hProcess>> ] void*-array{ } map-as
[ length ] keep 0 0
[ [ redirect-stderr ] dip hStdError<< ]
[ [ redirect-stdin ] dip hStdInput<< ] 3tri ;
-M: windows (run-process) ( process -- handle )
+M: windows (run-process)
[
[
dup make-CreateProcess-args
HOOK: close-mapped-file io-backend ( mmap -- )
-M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
+M: mapped-file dispose* close-mapped-file ;
: with-mapped-file ( path quot -- )
[ <mapped-file> ] dip with-disposal ; inline
flags{ MAP_FILE MAP_SHARED }
O_RDONLY mmap-open ;
-M: unix close-mapped-file ( mmap -- )
+M: unix close-mapped-file
[ [ address>> ] [ length>> ] bi munmap io-error ]
[ handle>> close-file ] bi ;
-rot <win32-mapped-file>
] with-destructors ;
-M: windows close-mapped-file ( mapped-file -- )
+M: windows close-mapped-file
[
[ handle>> &dispose drop ]
[ address>> UnmapViewOfFile win32-error=0/f ] bi
"Calling <monitor> outside with-monitors" throw
] unless ;
-M: linux (monitor) ( path recursive? mailbox -- monitor )
+M: linux (monitor)
swap [
<recursive-monitor>
] [
IN_CHANGE_EVENTS swap add-watch
] if ;
-M: linux-monitor dispose* ( monitor -- )
+M: linux-monitor dispose*
[ [ wd>> ] [ watches>> ] bi delete-at ]
[
dup inotify>> disposed>> [ drop ] [
TUPLE: pipe in out ;
-M: pipe dispose ( pipe -- )
+M: pipe dispose
[
[ in>> &dispose drop ]
[ out>> &dispose drop ] bi
GENERIC: <pipes> ( obj -- pipes )
-M: integer <pipes> ( n -- pipes )
+M: integer <pipes>
[
[ (pipe) |dispose ] replicate
T{ pipe } [ prefix ] [ suffix ] bi
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.data system kernel unix math sequences
-io.backend.unix io.ports libc specialized-arrays accessors unix.ffi ;
-QUALIFIED: io.pipes
+USING: alien.c-types alien.data io.backend.unix io.pipes kernel
+libc sequences specialized-arrays system unix.ffi ;
SPECIALIZED-ARRAY: int
IN: io.pipes.unix
-M: unix io.pipes:(pipe) ( -- pair )
+M: unix (pipe)
2 int <c-array>
- [ pipe io-error ]
+ [ unix.ffi:pipe io-error ]
[ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
nano-count #
] "" make ;
-M: windows (pipe) ( -- pipe )
+M: windows (pipe)
[
unique-pipe-name
[ create-named-pipe ] [ open-other-end ] bi
USING: accessors io.sockets.secure kernel ;
IN: io.sockets.secure.debug
-
GENERIC: <test-secure-config>* ( obj -- config )
-
-M: TLSv1 <test-secure-config>* ( obj -- config )
+M: TLSv1 <test-secure-config>*
drop <secure-config>
"vocab:openssl/test-1.0/server.pem" >>key-file
"vocab:openssl/test-1.0/dh1024.pem" >>dh-file
"password" >>password ;
-M: object <test-secure-config>* ( obj -- config )
+M: object <test-secure-config>*
drop <secure-config>
"vocab:openssl/test-1.2/server.pem" >>key-file
"vocab:openssl/test-1.2/dh1024.pem" >>dh-file
V{ } clone >>aliens
H{ } clone >>sessions ;
-M: openssl <secure-context> ( config -- context )
+M: openssl <secure-context>
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
{ { SSL_ERROR_ZERO_RETURN [ drop f ] } } check-ssl-error
] keep swap [ 2nip ] [ swap buffer+ f ] if* ;
-M: ssl-handle refill ( port handle -- event/f )
+M: ssl-handle refill
dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-read ;
! Output ports
2dup swap [ buffer@ ] [ buffer-length ] bi SSL_write
[ f check-ssl-error ] keep swap [ 2nip ] [ swap buffer-consume f ] if* ;
-M: ssl-handle drain ( port handle -- event/f )
+M: ssl-handle drain
dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-write ;
! Connect
[ 2drop ] [ subject-name-verify-error ] if
] [ certificate-missing-error ] if* ;
-M: openssl check-certificate ( host ssl -- )
+M: openssl check-certificate
current-secure-context config>> verify>> [
handle>>
[ nip check-verify-result ]
host>> swap handle>> check-certificate
] [ 2drop ] if ;
-M: openssl accept-secure-handshake ( -- )
+M: openssl accept-secure-handshake
input/output-ports
make-input/output-secure ;
CONSULT: inet secure addrspec>> ;
-M: secure resolve-host ( secure -- seq )
+M: secure resolve-host
[ addrspec>> resolve-host ] [ hostname>> ] bi
[ <secure> ] curry map ;
M: unix socket-handle fd>> ;
-M: secure remote>handle ( secure -- handle )
+M: secure remote>handle
[ addrspec>> remote>handle ] [ hostname>> ] bi <ssl-socket> ;
M: secure parse-sockaddr addrspec>> parse-sockaddr f <secure> ;
M: secure (get-local-address) addrspec>> (get-local-address) ;
-M: secure establish-connection ( client-out remote -- )
+M: secure establish-connection
addrspec>> [ establish-connection ] [ secure-connection ] 2bi ;
M: secure (accept)
f >>connected [ (shutdown) ] with-timeout
] [ drop ] if ;
-M: unix non-ssl-socket? ( obj -- ? ) fd? ;
+M: unix non-ssl-socket? fd? ;
M: windows socket-handle handle>> alien-address ;
-M: secure remote>handle ( addrspec -- handle )
+M: secure remote>handle
[ addrspec>> remote>handle ] [ hostname>> ] bi <ssl-socket> ;
GENERIC: windows-socket-handle ( obj -- handle )
M: ssl-handle windows-socket-handle file>> ;
M: win32-socket windows-socket-handle ;
-M: secure (get-local-address) ( handle remote -- sockaddr )
+M: secure (get-local-address)
[ windows-socket-handle ] [ addrspec>> ] bi* (get-local-address) ;
M: secure parse-sockaddr addrspec>> parse-sockaddr f <secure> ;
: <ipv4> ( host -- ipv4 ) dup check-ipv4 ipv4 boa ;
-M: ipv4 inet-ntop ( data addrspec -- str )
+M: ipv4 inet-ntop
drop 4 memory>byte-array join-ipv4 ;
-M: ipv4 inet-pton ( str addrspec -- data )
+M: ipv4 inet-pton
drop [ ?parse-ipv4 ] [ invalid-ipv4 ] recover ;
M: ipv4 address-size drop 4 ;
swap
port>> 0 or htons >>port ; inline
-M: ipv4 make-sockaddr ( inet -- sockaddr )
+M: ipv4 make-sockaddr
[ make-sockaddr-part ]
[ host>> "0.0.0.0" or ]
[ inet-pton uint deref >>addr ] tri ;
-M: ipv4 make-sockaddr-outgoing ( inet -- sockaddr )
+M: ipv4 make-sockaddr-outgoing
[ make-sockaddr-part ]
[ host>> dup { f "0.0.0.0" } member? [ drop "127.0.0.1" ] when ]
[ inet-pton uint deref >>addr ] tri ;
-M: ipv4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
+M: ipv4 parse-sockaddr
[ addr>> uint <ref> ] dip inet-ntop <ipv4> ;
TUPLE: inet4 < ipv4 { port maybe{ integer } read-only } ;
M: ipv4 with-port [ host>> ] dip <inet4> ;
-M: inet4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
+M: inet4 parse-sockaddr
[ call-next-method ] [ drop port>> ntohs ] 2bi with-port ;
M: inet4 present
: <ipv6> ( host -- ipv6 ) dup check-ipv6 0 ipv6 boa ;
-M: ipv6 inet-ntop ( data addrspec -- str )
+M: ipv6 inet-ntop
drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
<PRIVATE
PRIVATE>
-M: ipv6 inet-pton ( str addrspec -- data )
+M: ipv6 inet-pton
drop [ parse-ipv6 ipv6-bytes ] [ invalid-ipv6 ] recover ;
M: ipv6 address-size drop 16 ;
swap
port>> 0 or htons >>port ; inline
-M: ipv6 make-sockaddr ( inet -- sockaddr )
+M: ipv6 make-sockaddr
[ make-sockaddr-in6-part ]
[ [ host>> "::" or ] keep inet-pton >>addr ]
[ scope-id>> >>scopeid ]
tri ;
-M: ipv6 make-sockaddr-outgoing ( inet -- sockaddr )
+M: ipv6 make-sockaddr-outgoing
[ make-sockaddr-in6-part ]
[ [ host>> dup { f "::" } member? [ drop "::1" ] when ] keep inet-pton >>addr ]
[ scope-id>> >>scopeid ]
M: array (client) [ (client) 3array ] attempt-all first3 ;
-M: object (client) ( remote -- client-in client-out local )
+M: object (client)
[
[ remote>handle ] keep
[
: set-ioctl-socket ( handle cmd arg -- )
[ handle>> ] 2dip ulong <ref> ioctlsocket socket-error ;
-M: windows addrinfo-error-string ( n -- string )
+M: windows addrinfo-error-string
n>win32-error-string ;
-M: windows sockaddr-of-family ( alien af -- addrspec )
+M: windows sockaddr-of-family
{
{ AF_INET [ sockaddr-in memory>struct ] }
{ AF_INET6 [ sockaddr-in6 memory>struct ] }
[ 2drop f ]
} case ;
-M: windows addrspec-of-family ( af -- addrspec )
+M: windows addrspec-of-family
{
{ AF_INET [ T{ ipv4 } ] }
{ AF_INET6 [ T{ ipv6 } ] }
: <win32-socket> ( handle -- win32-socket )
win32-socket new-win32-handle ;
-M: win32-socket dispose* ( stream -- )
+M: win32-socket dispose*
handle>> closesocket socket-error* ;
: unspecific-sockaddr/size ( addrspec -- sockaddr len )
dup socket-error
opened-socket ;
-M: object (get-local-address) ( socket addrspec -- sockaddr )
+M: object (get-local-address)
[ handle>> ] dip empty-sockaddr/size int <ref>
[ getsockname socket-error ] keepd ;
-M: object (get-remote-address) ( socket addrspec -- sockaddr )
+M: object (get-remote-address)
[ handle>> ] dip empty-sockaddr/size int <ref>
[ getpeername socket-error ] keepd ;
: bind-socket ( win32-socket sockaddr len -- )
[ handle>> ] 2dip bind socket-error ;
-M: object remote>handle ( addrspec -- handle )
+M: object remote>handle
[ SOCK_STREAM open-socket ] keep
[
bind-local-address get
! NOTE: Possibly tweak this because of SYN flood attacks
: listen-backlog ( -- n ) 0x7fffffff ; inline
-M: object (server) ( addrspec -- handle )
+M: object (server)
[
SOCK_STREAM server-socket
dup handle>> listen-backlog listen winsock-return-check
] with-destructors ;
-M: windows (datagram) ( addrspec -- handle )
+M: windows (datagram)
[ SOCK_DGRAM server-socket ] with-destructors ;
-M: windows (raw) ( addrspec -- handle )
+M: windows (raw)
[ SOCK_RAW server-socket ] with-destructors ;
-M: windows (broadcast) ( datagram -- datagram )
+M: windows (broadcast)
dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ;
: malloc-int ( n -- alien )
stdcall alien-indirect drop
winsock-error ; inline
-M: object establish-connection ( client-out remote -- )
+M: object establish-connection
make-sockaddr/size-outgoing <ConnectEx-args>
swap >>port
dup port>> handle>> handle>> >>s
] [ port>> addr>> protocol-family ] bi
sockaddr-of-family ; inline
-M: object (accept) ( server addr -- handle sockaddr )
+M: object (accept)
[
<AcceptEx-args>
{
[ lpFromLen>> int deref ]
tri memcpy ; inline
-M: windows (receive-unsafe) ( n buf datagram -- count addrspec )
+M: windows (receive-unsafe)
[
<WSARecvFrom-args>
[ call-WSARecvFrom ]
[ lpCompletionRoutine>> ]
} cleave WSASendTo socket-error* ; inline
-M: windows (send) ( packet addrspec datagram -- )
+M: windows (send)
[
<WSASendTo-args>
[ call-WSASendTo ]
GENERIC#: limit-stream 1 ( stream limit -- stream' )
-M: decoder limit-stream ( stream limit -- stream' )
+M: decoder limit-stream
'[ stream>> _ limit-stream ] [ code>> ] [ cr>> ] tri
decoder boa ; inline
-M: object limit-stream ( stream limit -- stream' )
+M: object limit-stream
<limited-stream> ;
: limited-input ( limit -- )
GENERIC: unlimit-stream ( stream -- stream' )
-M: decoder unlimit-stream ( stream -- stream' )
+M: decoder unlimit-stream
[ stream>> stream>> ] [ code>> ] [ cr>> ] tri decoder boa ;
-M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ;
+M: limited-stream unlimit-stream stream>> ;
: unlimited-input ( -- )
input-stream [ unlimit-stream ] change ;
FUNCTION: int strerror_r ( int errno, char* buf, size_t buflen )
-M: freebsd strerror ( errno -- str )
+M: freebsd strerror
[
1024 [ malloc &free ] keep [ strerror_r ] keepd nip
alien>native-string
FUNCTION: c-string strerror_r ( int errno, char* buf, size_t buflen )
-M: linux strerror ( errno -- str )
+M: linux strerror
[
1024 [ malloc &free ] keep strerror_r
] with-destructors ;
FUNCTION: int strerror_r ( int errno, char* buf, size_t buflen )
-M: macosx strerror ( errno -- str )
+M: macosx strerror
[
1024 [ malloc &free ] keep [ strerror_r ] keepd nip
alien>native-string
FUNCTION: int strerror_s ( char *buffer, size_t numberOfElements, int errnum )
-M: windows strerror ( errno -- str )
+M: windows strerror
[
[ 1024 [ malloc &free ] keep ] dip
[ strerror_s drop ] keepdd
C: cons cons-state
-M: cons-state car ( cons -- car ) car>> ;
+M: cons-state car car>> ;
-M: cons-state cdr ( cons -- cdr ) cdr>> ;
+M: cons-state cdr cdr>> ;
SINGLETON: +nil+
M: +nil+ nil? drop t ;
: parse-def ( name/paren -- def )
dup "(" = [ drop parse-multi-def ] [ parse-single-def ] if update-locals ;
-M: lambda-parser parse-quotation ( -- quotation )
+M: lambda-parser parse-quotation
H{ } clone (parse-lambda) ;
: parse-let ( -- form )
M: callable expand-macros*
expand-macros literal ;
-M: callable expand-macros ( quot -- quot' )
+M: callable expand-macros
[ begin [ expand-macros* ] each end ] [ ] make ;
GENERIC: (bitfield-quot) ( spec -- quot )
-M: integer (bitfield-quot) ( spec -- quot )
+M: integer (bitfield-quot)
'[ _ shift ] ;
-M: pair (bitfield-quot) ( spec -- quot )
+M: pair (bitfield-quot)
first2-unsafe over word? [
'[ _ execute _ shift ]
] [
CONSTANT: ppc-denormal-mode-bits 0x4
-M: ppc-fpu-env (get-exception-flags) ( register -- exceptions )
+M: ppc-fpu-env (get-exception-flags)
fpscr>> ppc-exception-flag>bit mask> ; inline
-M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
+M: ppc-fpu-env (set-exception-flags)
[ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpscr ; inline
-M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
+M: ppc-fpu-env (get-fp-traps)
fpscr>> ppc-fp-traps>bit mask> ; inline
-M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
+M: ppc-fpu-env (set-fp-traps)
[ ppc-fp-traps>bit >mask ppc-fp-traps-bits remask ] curry change-fpscr ; inline
-M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
+M: ppc-fpu-env (get-rounding-mode)
fpscr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline
-M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' )
+M: ppc-fpu-env (set-rounding-mode)
[ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpscr ; inline
-M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
+M: ppc-fpu-env (get-denormal-mode)
fpscr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
-M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
+M: ppc-fpu-env (set-denormal-mode)
[
{
{ +denormal-keep+ [ ppc-denormal-mode-bits unmask ] }
CONSTANT: vmx-denormal-mode-bits 0x10000
-M: ppc-vmx-env (get-exception-flags) ( register -- exceptions )
+M: ppc-vmx-env (get-exception-flags)
drop { } ; inline
-M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' )
+M: ppc-vmx-env (set-exception-flags)
drop ;
-M: ppc-vmx-env (get-fp-traps) ( register -- exceptions )
+M: ppc-vmx-env (get-fp-traps)
drop { } ; inline
-M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' )
+M: ppc-vmx-env (set-fp-traps)
drop ;
-M: ppc-vmx-env (get-rounding-mode) ( register -- mode )
+M: ppc-vmx-env (get-rounding-mode)
drop +round-nearest+ ;
-M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' )
+M: ppc-vmx-env (set-rounding-mode)
drop ;
-M: ppc-vmx-env (get-denormal-mode) ( register -- mode )
+M: ppc-vmx-env (get-denormal-mode)
vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
-M: ppc-vmx-env (set-denormal-mode) ( register mode -- register )
+M: ppc-vmx-env (set-denormal-mode)
[
{
{ +denormal-keep+ [ vmx-denormal-mode-bits unmask ] }
CONSTANT: sse-denormal-mode-bits 0x8040
-M: sse-env (get-exception-flags) ( register -- exceptions )
+M: sse-env (get-exception-flags)
mxcsr>> sse-exception-flag>bit mask> ; inline
-M: sse-env (set-exception-flags) ( register exceptions -- register' )
+M: sse-env (set-exception-flags)
[ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
-M: sse-env (get-fp-traps) ( register -- exceptions )
+M: sse-env (get-fp-traps)
mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
-M: sse-env (set-fp-traps) ( register exceptions -- register' )
+M: sse-env (set-fp-traps)
[ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
-M: sse-env (get-rounding-mode) ( register -- mode )
+M: sse-env (get-rounding-mode)
mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
-M: sse-env (set-rounding-mode) ( register mode -- register' )
+M: sse-env (set-rounding-mode)
[ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
-M: sse-env (get-denormal-mode) ( register -- mode )
+M: sse-env (get-denormal-mode)
mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
-M: sse-env (set-denormal-mode) ( register mode -- register' )
+M: sse-env (set-denormal-mode)
[
{
{ +denormal-keep+ [ sse-denormal-mode-bits unmask ] }
{ +round-zero+ 0x0c00 }
} >biassoc ]
-M: x87-env (get-exception-flags) ( register -- exceptions )
+M: x87-env (get-exception-flags)
status>> x87-exception>bit mask> ; inline
-M: x87-env (set-exception-flags) ( register exceptions -- register' )
+M: x87-env (set-exception-flags)
drop ;
-M: x87-env (get-fp-traps) ( register -- exceptions )
+M: x87-env (get-fp-traps)
control>> bitnot x87-exception>bit mask> ; inline
-M: x87-env (set-fp-traps) ( register exceptions -- register' )
+M: x87-env (set-fp-traps)
[ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
-M: x87-env (get-rounding-mode) ( register -- mode )
+M: x87-env (get-rounding-mode)
control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
-M: x87-env (set-rounding-mode) ( register mode -- register' )
+M: x87-env (set-rounding-mode)
[ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
-M: x87-env (get-denormal-mode) ( register -- mode )
+M: x87-env (get-denormal-mode)
drop +denormal-keep+ ; inline
-M: x87-env (set-denormal-mode) ( register mode -- register' )
+M: x87-env (set-denormal-mode)
drop ;
cpu {
GENERIC: (integer-log2) ( x -- n ) foldable
-M: integer (integer-log2) ( x -- n ) (log2) ; inline
+M: integer (integer-log2) (log2) ; inline
: ((ratio-integer-log)) ( ratio quot -- log )
[ >integer ] dip call ; inline
[ 1 + ] unless neg
] if ; inline
-M: ratio (integer-log2) ( r -- n ) [ (integer-log2) ] 2 (ratio-integer-log) ;
+M: ratio (integer-log2) [ (integer-log2) ] 2 (ratio-integer-log) ;
-M: ratio (integer-log10) ( r -- n ) [ (integer-log10) ] 10 (ratio-integer-log) ;
+M: ratio (integer-log10) [ (integer-log10) ] 10 (ratio-integer-log) ;
: (integer-log) ( x quot -- n )
[ dup 0 > ] dip [ log-expects-positive ] if ; inline
M: ratio number-hashcode >fraction hash-fraction ;
-M: float number-hashcode ( x -- h )
+M: float number-hashcode
{
{ [ dup fp-nan? ] [ drop 0 ] }
{ [ dup fp-infinity? ] [ 0 > 314159 -314159 ? ] }
[ double>ratio number-hashcode ]
} cond ;
-M: complex number-hashcode ( x -- h )
+M: complex number-hashcode
>rect [ number-hashcode ] bi@ 1000003 * +
cell-bits on-bits bitand dup -1 = [ drop -2 ] when ;
} 2cleave (q*sign) ; inline
GENERIC: qconjugate ( u -- u' )
-M: object qconjugate ( u -- u' )
+M: object qconjugate
{ 1 -1 -1 -1 } v* ; inline
: qrecip ( u -- 1/u )
[ sign/mod 0 < [ 1 + ] unless 0 max ] keep
range boa ; inline
-M: range length ( seq -- n ) length>> ; inline
+M: range length length>> ; inline
-M: range nth-unsafe ( n range -- obj )
+M: range nth-unsafe
[ step>> * ] keep from>> + ; inline
! We want M\ tuple hashcode, not M\ sequence hashcode here!
! misc
-M: simd-128 vshuffle ( u perm -- v )
+M: simd-128 vshuffle
vshuffle-bytes ; inline
M: uchar-16 v*hs+
GENERIC#: vshuffle-bytes 1 ( v perm -- w )
GENERIC: vshuffle ( v perm -- w )
-M: array vshuffle ( v perm -- w )
+M: array vshuffle
vshuffle-elements ; inline
GENERIC#: vlshift 1 ( v n -- w )
[ offset>> ]
} cond ; inline
-M: mirror set-at ( val key mirror -- )
+M: mirror set-at
[ object-slots slot-named check-set-slot ] [ object>> ] bi
swap set-slot ;
ERROR: mirror-slot-removal slots mirror method ;
-M: mirror delete-at ( key mirror -- )
+M: mirror delete-at
\ delete-at mirror-slot-removal ;
-M: mirror clear-assoc ( mirror -- )
+M: mirror clear-assoc
[ object-slots ] keep \ clear-assoc mirror-slot-removal ;
M: mirror-slot-removal summary
drop "Slots cannot be removed from a tuple or a mirror of it" ;
-M: mirror >alist ( mirror -- alist )
+M: mirror >alist
[ object-slots ] [ object>> ] bi '[
[ name>> ] [ offset>> _ swap slot ] bi
] { } map>assoc ;
-M: mirror keys ( mirror -- keys )
+M: mirror keys
object-slots [ name>> ] map ;
-M: mirror values ( mirror -- values )
+M: mirror values
[ object-slots ] [ object>> ] bi
'[ offset>> _ swap slot ] map ;
GENERIC: >n-byte-array ( obj n -- byte-array )
-M: integer >n-byte-array ( m n -- byte-array ) >endian ;
+M: integer >n-byte-array >endian ;
! for doing native, platform-dependent sized values
-M: object >n-byte-array ( n string -- byte-array ) heap-size >n-byte-array ;
+M: object >n-byte-array heap-size >n-byte-array ;
: s8>byte-array ( n -- byte-array ) 1 >n-byte-array ;
: u8>byte-array ( n -- byte-array ) 1 >n-byte-array ;
main set
] with-variables ;
-M: ebnf (transform) ( ast -- parser )
+M: ebnf (transform)
rules>> [ (transform) ] map last ;
-M: ebnf-tokenizer (transform) ( ast -- parser )
+M: ebnf-tokenizer (transform)
elements>> dup "default" = [
drop default-tokenizer \ tokenizer set-global any-char
] [
M: redefined-rule summary
name>> "Rule '" "' defined more than once" surround ;
-M: ebnf-rule (transform) ( ast -- parser )
+M: ebnf-rule (transform)
dup elements>>
(transform) [
swap symbol>> dup get parser? [ redefined-rule ] [ set ] if
] keep ;
-M: ebnf-sequence (transform) ( ast -- parser )
+M: ebnf-sequence (transform)
! If ignore-ws is set then each element of the sequence
! ignores leading whitespace. This is not inherited by
! subelements of the sequence.
ignore-ws get [ sp ] when
] map seq [ dup length 1 = [ first ] when ] action ;
-M: ebnf-choice (transform) ( ast -- parser )
+M: ebnf-choice (transform)
options>> [ (transform) ] map choice ;
-M: ebnf-any-character (transform) ( ast -- parser )
+M: ebnf-any-character (transform)
drop tokenizer any>> call( -- parser ) ;
-M: ebnf-range (transform) ( ast -- parser )
+M: ebnf-range (transform)
pattern>> range-pattern ;
: transform-group ( ast -- parser )
! convert a ast node with groups to a parser for that group
group>> (transform) ;
-M: ebnf-ensure (transform) ( ast -- parser )
+M: ebnf-ensure (transform)
transform-group ensure ;
-M: ebnf-ensure-not (transform) ( ast -- parser )
+M: ebnf-ensure-not (transform)
transform-group ensure-not ;
-M: ebnf-ignore (transform) ( ast -- parser )
+M: ebnf-ignore (transform)
transform-group [ drop ignore ] action ;
-M: ebnf-repeat0 (transform) ( ast -- parser )
+M: ebnf-repeat0 (transform)
transform-group repeat0 ;
-M: ebnf-repeat1 (transform) ( ast -- parser )
+M: ebnf-repeat1 (transform)
transform-group repeat1 ;
-M: ebnf-optional (transform) ( ast -- parser )
+M: ebnf-optional (transform)
transform-group optional ;
-M: ebnf-whitespace (transform) ( ast -- parser )
+M: ebnf-whitespace (transform)
t ignore-ws [ transform-group ] with-variable ;
GENERIC: build-locals ( code ast -- code )
-M: ebnf-sequence build-locals ( code ast -- code )
+M: ebnf-sequence build-locals
! Note the need to filter out this ebnf items that
! leave nothing in the AST
elements>> filter-hidden dup length 1 = [
] if
] if ;
-M: ebnf-var build-locals ( code ast -- code )
+M: ebnf-var build-locals
[
"[let dup :> " % name>> %
" " %
" nip ]" %
] "" make ;
-M: object build-locals ( code ast -- code )
+M: object build-locals
drop ;
ERROR: bad-effect quot effect ;
[ string-lines parse-lines ] dip
dup 3 + qualified-vocabs delete-slice ;
-M: ebnf-action (transform) ( ast -- parser )
+M: ebnf-action (transform)
ebnf-transform check-action-effect action ;
-M: ebnf-semantic (transform) ( ast -- parser )
+M: ebnf-semantic (transform)
ebnf-transform semantic ;
-M: ebnf-var (transform) ( ast -- parser )
+M: ebnf-var (transform)
parser>> (transform) ;
-M: ebnf-terminal (transform) ( ast -- parser )
+M: ebnf-terminal (transform)
symbol>> tokenizer one>> call( symbol -- parser ) ;
ERROR: ebnf-foreign-not-found name ;
M: ebnf-foreign-not-found summary
name>> "Foreign word '" "' not found" surround ;
-M: ebnf-foreign (transform) ( ast -- parser )
+M: ebnf-foreign (transform)
dup word>> search [ word>> ebnf-foreign-not-found ] unless*
swap rule>> [ main ] unless* over rule [
nip
ERROR: parser-not-found name ;
-M: ebnf-non-terminal (transform) ( ast -- parser )
+M: ebnf-non-terminal (transform)
symbol>> [
, \ dup , parser get , \ at ,
[ parser-not-found ] , \ unless* , \ nip ,
] when
]
-M: just-parser (compile) ( parser -- quot )
+M: just-parser (compile)
p1>> compile-parser-quot just-pattern compose ;
: just ( parser -- parser )
[ seq>> pos get swap ] dip "'" "'" surround 1vector add-error f
] if ;
-M: token-parser (compile) ( peg -- quot )
+M: token-parser (compile)
symbol>> '[ input-slice _ parse-token ] ;
TUPLE: satisfy-parser quot ;
] if
] if ;
-M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ;
+M: bitmap-node >alist% nodes>> >alist-each% ;
(ppush-new-tail) do-expansion
swap 0 1node >>tail ;
-M: persistent-vector ppush ( val pvec -- pvec' )
+M: persistent-vector ppush
clone
dup tail>> full?
[ ppush-new-tail ] [ ppush-tail ] if
[ (new-nth) ] node-change-nth
] if ;
-M: persistent-vector new-nth ( obj i pvec -- pvec' )
+M: persistent-vector new-nth
2dup count>> = [ nip ppush ] [
clone
2dup tail-offset >= [
PRIVATE>
-M: persistent-vector ppop ( pvec -- pvec' )
+M: persistent-vector ppop
dup count>> {
{ 0 [ empty-error ] }
{ 1 [ drop T{ persistent-vector } ] }
M: real present number>string ;
-M: complex present ( c -- str )
+M: complex present
[ real>> number>string ]
[
imaginary>>
M: anonymous-intersection word-name*
class-name "intersection{ " " }" surround ;
-M: word word-name* ( word -- str )
+M: word word-name*
[ name>> "( no name )" or ] [ record-vocab ] bi ;
: pprint-word ( word -- )
M: hashtable pprint-narrow? drop t ;
M: tuple pprint-narrow? drop t ;
-M: object pprint-object ( obj -- )
+M: object pprint-object
[
<flow
dup pprint-delims [
] change
0 >>overhang ; inline
-M: section section-fits? ( section -- ? )
+M: section section-fits?
[ end>> 1 - pprinter get last-newline>> - ]
[ overhang>> ] bi + text-fits? ;
: add-line-break ( type -- ) [ <line-break> add-section ] when* ;
-M: block section-fits? ( section -- ? )
+M: block section-fits?
line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
] dip
[ [ pprint-section ] bi ] curry each ; inline
-M: block short-section ( block -- )
+M: block short-section
[ advance ] pprint-sections ;
: do-break ( break -- )
: <flow> ( -- block )
flow new-block ;
-M: flow short-section? ( section -- ? )
+M: flow short-section?
! If we can make room for this entire block by inserting
! a newline, do it; otherwise, don't bother, print it as
! a short section
: ?break-group ( seq -- )
dup break-group? [ first <fresh-line ] [ drop ] if ;
-M: block long-section ( block -- )
+M: block long-section
[
sections>> chop-break group-flow [
dup ?break-group [
M: no-random-number-generator summary
drop "Random number generator is not defined." ;
-M: f random-bytes* ( n obj -- * ) no-random-number-generator ;
+M: f random-bytes* no-random-number-generator ;
-M: f random-32* ( obj -- * ) no-random-number-generator ;
+M: f random-32* no-random-number-generator ;
: random-32 ( -- n )
random-generator get random-32* ;
] while drop [ m * ] [ neg shift ] bi* ; inline
GENERIC#: (random-integer) 1 ( m obj -- n )
-M: fixnum (random-integer) ( m obj -- n ) random-integer-loop ;
-M: bignum (random-integer) ( m obj -- n ) random-integer-loop ;
+M: fixnum (random-integer) random-integer-loop ;
+M: bignum (random-integer) random-integer-loop ;
: random-integer ( m -- n )
random-generator get (random-integer) ;
PRIVATE>
-M: sfmt random-32* ( sfmt -- n )
+M: sfmt random-32*
dup refill-sfmt? [ dup generate ] when next ; inline
-M: sfmt seed-random ( sfmt seed -- sfmt )
+M: sfmt seed-random
[ [ state>> ] dip >>seed drop ]
[ drop init-sfmt ] 2bi ;
M: unix-random dispose reader>> dispose ;
-M: unix-random random-bytes* ( n tuple -- byte-array )
+M: unix-random random-bytes*
reader>> stream-read ;
+
HINTS: M\ unix-random random-bytes* { fixnum unix-random } ;
[
TUPLE: windows-crypto-context < win32-handle provider type ;
-M: windows-crypto-context dispose* ( tuple -- )
+M: windows-crypto-context dispose*
[ handle>> 0 CryptReleaseContext win32-error=0/f ]
[ f >>handle drop ] bi ;
swap >>provider
initialize-crypto-context ; inline
-M: windows-crypto-context random-bytes* ( n windows-crypto-context -- bytes )
+M: windows-crypto-context random-bytes*
handle>> swap dup <byte-array>
[ CryptGenRandom win32-error=0/f ] keep ;
TUPLE: assoc-ref assoc key ;
: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
-M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ;
+M: assoc-ref delete-ref >assoc-ref< delete-at ;
TUPLE: key-ref < assoc-ref ;
C: <key-ref> key-ref
GENERIC: class-member? ( obj class -- ? )
-M: t class-member? ( obj class -- ? ) 2drop t ; inline
+M: t class-member? 2drop t ; inline
-M: integer class-member? ( obj class -- ? ) = ; inline
+M: integer class-member? = ; inline
-M: range-class class-member? ( obj class -- ? )
+M: range-class class-member?
[ from>> ] [ to>> ] bi between? ; inline
-M: letter-class class-member? ( obj class -- ? )
+M: letter-class class-member?
drop letter? ; inline
-M: LETTER-class class-member? ( obj class -- ? )
+M: LETTER-class class-member?
drop LETTER? ; inline
-M: Letter-class class-member? ( obj class -- ? )
+M: Letter-class class-member?
drop Letter? ; inline
-M: ascii-class class-member? ( obj class -- ? )
+M: ascii-class class-member?
drop ascii? ; inline
-M: digit-class class-member? ( obj class -- ? )
+M: digit-class class-member?
drop digit? ; inline
: c-identifier-char? ( ch -- ? )
{ [ alpha? ] [ CHAR: _ = ] } 1|| ;
-M: c-identifier-class class-member? ( obj class -- ? )
+M: c-identifier-class class-member?
drop c-identifier-char? ; inline
-M: alpha-class class-member? ( obj class -- ? )
+M: alpha-class class-member?
drop alpha? ; inline
: punct? ( ch -- ? )
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
-M: punctuation-class class-member? ( obj class -- ? )
+M: punctuation-class class-member?
drop punct? ; inline
: java-printable? ( ch -- ? )
{ [ alpha? ] [ punct? ] } 1|| ;
-M: java-printable-class class-member? ( obj class -- ? )
+M: java-printable-class class-member?
drop java-printable? ; inline
-M: non-newline-blank-class class-member? ( obj class -- ? )
+M: non-newline-blank-class class-member?
drop { [ blank? ] [ CHAR: \n = not ] } 1&& ; inline
-M: control-character-class class-member? ( obj class -- ? )
+M: control-character-class class-member?
drop control? ; inline
: hex-digit? ( ch -- ? )
[ CHAR: 0 CHAR: 9 between? ]
} 1|| ;
-M: hex-digit-class class-member? ( obj class -- ? )
+M: hex-digit-class class-member?
drop hex-digit? ; inline
: java-blank? ( ch -- ? )
CHAR: \v CHAR: \a CHAR: \r
} member? ;
-M: java-blank-class class-member? ( obj class -- ? )
+M: java-blank-class class-member?
drop java-blank? ; inline
-M: unmatchable-class class-member? ( obj class -- ? )
+M: unmatchable-class class-member?
2drop f ; inline
-M: terminator-class class-member? ( obj class -- ? )
+M: terminator-class class-member?
drop "\r\n\u000085\u002029\u002028" member? ; inline
M: f class-member? 2drop f ; inline
: ast>dfa ( parse-tree -- minimal-dfa )
ast>nfa construct-dfa minimize ;
-M: negation nfa-node ( node -- start end )
+M: negation nfa-node
term>> ast>dfa negate-table adjoin-dfa ;
M: tagged-epsilon nfa-node
clone [ modify-epsilon ] change-tag add-simple-entry ;
-M: concatenation nfa-node ( node -- start end )
+M: concatenation nfa-node
[ first>> ] [ second>> ] bi
reversed-regexp option? [ swap ] when
[ nfa-node ] bi@
s3 s5 epsilon-transition
s4 s5 ;
-M: alternation nfa-node ( node -- start end )
+M: alternation nfa-node
[ first>> ] [ second>> ] bi
[ nfa-node ] bi@
alternate-nodes ;
] when
] when ;
-M: integer nfa-node ( node -- start end )
+M: integer nfa-node
modify-class add-simple-entry ;
M: primitive-class modify-class
M: object nfa-node
modify-class add-simple-entry ;
-M: with-options nfa-node ( node -- start end )
+M: with-options nfa-node
dup options>> [ tree>> nfa-node ] using-options ;
: construct-nfa ( ast -- nfa-table )
<PRIVATE
-M: lookahead question>quot ! Returns ( index string -- ? )
+M: lookahead question>quot
+ ! Returns ( index string -- ? )
term>> ast>dfa dfa>shortest-word '[ f _ execute ] ;
: <reversed-option> ( ast -- reversed )
"r" string>options <with-options> ;
-M: lookbehind question>quot ! Returns ( index string -- ? )
+M: lookbehind question>quot
+ ! Returns ( index string -- ? )
term>> <reversed-option>
ast>dfa dfa>reverse-shortest-word
'[ [ 1 - ] dip f _ execute ] ;
: regexp-initial-word ( i string regexp -- i/f )
[ compile-regexp ] with-compilation-unit match-index-from ;
-M: regexp compile-regexp ( regexp -- regexp )
+M: regexp compile-regexp
dup '[
dup \ regexp-initial-word =
[ drop _ get-ast ast>dfa dfa>word ] when
] change-dfa ;
-M: reverse-regexp compile-regexp ( regexp -- regexp )
+M: reverse-regexp compile-regexp
t backwards? [ call-next-method ] with-variable ;
DEFER: compile-next-match
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
-M: singleton-class see-class* ( class -- )
+M: singleton-class see-class*
\ SINGLETON: pprint-word pprint-word ;
GENERIC: pprint-slot-name ( object -- )
M: merged length
seqs>> [ [ length ] [ min ] map-reduce ] [ length ] bi * ; inline
-M: merged virtual@ ( n seq -- n' seq' )
+M: merged virtual@
seqs>> [ length /mod ] [ nth-unsafe ] bi ; inline
-M: merged virtual-exemplar ( merged -- seq )
+M: merged virtual-exemplar
seqs>> ?first ; inline
INSTANCE: merged virtual-sequence
[ CHAR: o write1 serialize-cell drop ]
] dip if* ; inline
-M: f (serialize) ( obj -- )
+M: f (serialize)
drop CHAR: n write1 ;
-M: integer (serialize) ( obj -- )
+M: integer (serialize)
[
CHAR: z write1
] [
serialize-cell
] if-zero ;
-M: float (serialize) ( obj -- )
+M: float (serialize)
CHAR: F write1
double>bits serialize-cell ;
[ [ (serialize) ] each ] tri
] curry serialize-shared ;
-M: tuple (serialize) ( obj -- )
+M: tuple (serialize)
[
CHAR: T write1
[ class-of (serialize) ]
tri
] serialize-shared ;
-M: array (serialize) ( obj -- )
+M: array (serialize)
CHAR: a serialize-seq ;
-M: quotation (serialize) ( obj -- )
+M: quotation (serialize)
[
CHAR: q write1
[ >array (serialize) ] [ add-object ] bi
] serialize-shared ;
-M: hashtable (serialize) ( obj -- )
+M: hashtable (serialize)
[
CHAR: h write1
[ add-object ] [ >alist (serialize) ] bi
] serialize-shared ;
-M: byte-array (serialize) ( obj -- )
+M: byte-array (serialize)
[
CHAR: A write1
[ add-object ]
[ write ] tri
] serialize-shared ;
-M: string (serialize) ( obj -- )
+M: string (serialize)
[
CHAR: s write1
[ add-object ]
[ vocabulary>> (serialize) ]
bi ;
-M: word (serialize) ( obj -- )
+M: word (serialize)
{
{ [ dup t eq? ] [ serialize-true ] }
{ [ dup vocabulary>> not ] [ serialize-gensym ] }
[ serialize-word ]
} cond ;
-M: wrapper (serialize) ( obj -- )
+M: wrapper (serialize)
CHAR: W write1
wrapped>> (serialize) ;
: machine ( -- str ) { 6 1 } sysctl-query-string ;
: model ( -- str ) { 6 2 } sysctl-query-string ;
-M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
+M: macosx cpus { 6 3 } sysctl-query-uint ;
: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
! Only an int, not large enough. Deprecated.
-! M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-int ;
+! M: macosx physical-mem { 6 5 } sysctl-query-int ;
! : user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
-M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
+M: macosx cpu-mhz { 6 15 } sysctl-query-uint ;
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
-M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ;
+M: macosx physical-mem { 6 24 } sysctl-query-ulonglong ;
: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
M: macosx computer-name { 1 10 } sysctl-query-string "." split1 drop ;
: windows-minor ( -- n )
os-version-struct dwMinorVersion>> ;
-M: windows os-version ( -- obj )
+M: windows os-version
os-version-struct [ dwMajorVersion>> ] [ dwMinorVersion>> ] bi 2array ;
: windows-build# ( -- n )
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
-M: windows cpus ( -- n )
+M: windows cpus
system-info dwNumberOfProcessors>> ;
: memory-status ( -- MEMORYSTATUSEX )
MEMORYSTATUSEX heap-size >>dwLength
dup GlobalMemoryStatusEx win32-error=0/f ;
-M: windows memory-load ( -- n )
+M: windows memory-load
memory-status dwMemoryLoad>> ;
-M: windows physical-mem ( -- n )
+M: windows physical-mem
memory-status ullTotalPhys>> ;
-M: windows available-mem ( -- n )
+M: windows available-mem
memory-status ullAvailPhys>> ;
-M: windows total-page-file ( -- n )
+M: windows total-page-file
memory-status ullTotalPageFile>> ;
-M: windows available-page-file ( -- n )
+M: windows available-page-file
memory-status ullAvailPageFile>> ;
-M: windows total-virtual-mem ( -- n )
+M: windows total-virtual-mem
memory-status ullTotalVirtual>> ;
-M: windows available-virtual-mem ( -- n )
+M: windows available-virtual-mem
memory-status ullAvailVirtual>> ;
-M: windows computer-name ( -- string )
+M: windows computer-name
MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep uint <ref>
GetComputerName win32-error=0/f alien>native-string ;
M: string coverage
[ dup coverage 2array ] map-words ;
-M: word coverage ( word -- seq )
+M: word coverage
"coverage" word-prop
[ drop executed?>> ] assoc-reject values ;
M: wrapper quot-uses [ wrapped>> ] dip quot-uses ;
-M: callable uses ( quot -- seq )
+M: callable uses
IHS{ } clone visited [
HS{ } clone [ quot-uses ] keep members
] with-variable ;
] loop
] { } make ;
-M: udis-disassembler disassemble* ( from to -- buffer )
+M: udis-disassembler disassemble*
'[
_ _
[ drop ud_set_pc ]
HOOK: file-spec>string os ( file-listing spec -- string )
-M: object file-spec>string ( file-listing spec -- string )
+M: object file-spec>string
{
{ +file-name+ [ directory-entry>> name>> ] }
{ +directory-or-size+ [ file-info>> dir-or-size ] }
[ drop "" ]
} cond ;
-M: unix (directory.) ( path -- lines )
+M: unix (directory.)
<listing-tool>
{
+permissions+ +nlinks+ +user+ +group+
{ { directory-entry>> name>> <=> } } >>sort
[ [ list-files ] with-group-cache ] with-user-cache ;
-M: unix file-spec>string ( file-listing spec -- string )
+M: unix file-spec>string
{
{ +file-name/type+ [
directory-entry>> [ name>> ] [ file-type>trailing ] bi append
<PRIVATE
-M: windows (directory.) ( entries -- lines )
+M: windows (directory.)
<listing-tool>
{ +file-datetime+ +directory-or-size+ +file-name+ } >>specs
{ { directory-entry>> name>> <=> } } >>sort
: safe-ps-cmdline ( path -- string/f )
[ ps-cmdline ] [ 2drop f ] recover ;
-M: linux ps ( -- assoc )
+M: linux ps
"/proc" [
"." directory-files [ string>number ] filter
[ dup safe-ps-cmdline 2array ] map sift-values
PRIVATE>
-M: macosx ps ( -- assoc )
+M: macosx ps
procs [ kp_proc>> p_pid>> 0 > ] filter
[ kp_proc>> [ p_pid>> ] [ ps-arg ] bi ] { } map>assoc ;
] map sift
] with-destructors ;
-M: windows ps ( -- assoc ) process-list ;
+M: windows ps process-list ;
M: string add-using drop ;
-M: object add-using ( object -- )
+M: object add-using
vocabulary>> using get [ adjoin ] [ drop ] if* ;
: ($values.) ( array -- )
HOOK: scaffold-emacs os ( -- )
-M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
+M: unix scaffold-emacs ".emacs" scaffold-rc ;
] if
] [ first2 <CGPoint> -> setFrameTopLeftPoint: ] if ;
-M: cocoa-ui-backend set-title ( string world -- )
+M: cocoa-ui-backend set-title
handle>> window>> swap <NSString> -> setTitle: ;
: enter-fullscreen ( world -- )
[ view>> f -> exitFullScreenModeWithOptions: ]
[ [ window>> ] [ view>> ] bi -> makeFirstResponder: drop ] bi ;
-M: cocoa-ui-backend (set-fullscreen) ( world ? -- )
+M: cocoa-ui-backend (set-fullscreen)
[ enter-fullscreen ] [ exit-fullscreen ] if ;
-M: cocoa-ui-backend (fullscreen?) ( world -- ? )
+M: cocoa-ui-backend (fullscreen?)
handle>> view>> -> isInFullScreenMode zero? not ;
! XXX: Until someone tests OSX with a tiling window manager,
window f -> makeKeyAndOrderFront:
t world active?<< ;
-M: cocoa-ui-backend (close-window) ( handle -- )
+M: cocoa-ui-backend (close-window)
[
view>> dup -> isInFullScreenMode zero?
[ drop ]
[ f -> exitFullScreenModeWithOptions: ] if
] [ window>> -> release ] bi ;
-M: cocoa-ui-backend (grab-input) ( handle -- )
+M: cocoa-ui-backend (grab-input)
0 CGAssociateMouseAndMouseCursorPosition drop
CGMainDisplayID CGDisplayHideCursor drop
window>> -> frame CGRect>rect rect-center
[ GetCurrentButtonState zero? not ] [ yield ] while
CGWarpMouseCursorPosition drop ;
-M: cocoa-ui-backend (ungrab-input) ( handle -- )
+M: cocoa-ui-backend (ungrab-input)
drop
CGMainDisplayID CGDisplayShowCursor drop
1 CGAssociateMouseAndMouseCursorPosition drop ;
-M: cocoa-ui-backend close-window ( gadget -- )
+M: cocoa-ui-backend close-window
find-world [
handle>> [
window>> -> close
] when*
] when* ;
-M: cocoa-ui-backend raise-window* ( world -- )
+M: cocoa-ui-backend raise-window*
handle>> [
window>> dup f -> orderFront: -> makeKeyWindow
NSApp 1 -> activateIgnoringOtherApps:
] when* ;
-M: window-handle select-gl-context ( handle -- )
+M: window-handle select-gl-context
view>> -> openGLContext -> makeCurrentContext ;
-M: window-handle flush-gl-context ( handle -- )
+M: window-handle flush-gl-context
view>> -> openGLContext -> flushBuffer ;
-M: cocoa-ui-backend beep ( -- )
+M: cocoa-ui-backend beep
NSBeep ;
M: cocoa-ui-backend resize-window
M: gtk-ui-backend (free-pixel-format)
handle>> g_object_unref ;
-M: window-handle select-gl-context ( handle -- )
+M: window-handle select-gl-context
drawable>>
[ gtk_widget_get_gl_window ] [ gtk_widget_get_gl_context ] bi
gdk_gl_drawable_make_current drop ;
-M: window-handle flush-gl-context ( handle -- )
+M: window-handle flush-gl-context
drawable>> gtk_widget_get_gl_window
gdk_gl_drawable_swap_buffers ;
win world window-controls>> configure-window-controls
win gtk_widget_show_all ;
-M: gtk-ui-backend (close-window) ( handle -- )
+M: gtk-ui-backend (close-window)
window>> [ gtk_widget_destroy ] [ unregister-window ] bi
event-loop? [ gtk_main_quit ] unless ;
[ drop send-notify-failure ]
} cond ;
-M: x11-ui-backend (close-window) ( handle -- )
+M: x11-ui-backend (close-window)
[ xic>> XDestroyIC ]
[ glx>> destroy-glx ]
[ window>> [ unregister-window ] [ destroy-window ] bi ]
XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor"
utf8 encode dup length XChangeProperty drop ;
-M: x11-ui-backend set-title ( string world -- )
+M: x11-ui-backend set-title
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
flags{ SubstructureNotifyMask SubstructureRedirectMask }
] dip XSendEvent drop ;
-M: x11-ui-backend (set-fullscreen) ( world ? -- )
+M: x11-ui-backend (set-fullscreen)
[ handle>> window>> ] dip make-fullscreen-msg send-event ;
-M: x11-ui-backend (fullscreen?) ( world -- ? )
+M: x11-ui-backend (fullscreen?)
handle>> window>> XA_NET_WM_STATE get-atom-properties
XA_NET_WM_STATE_FULLSCREEN swap member? ;
-M: x11-ui-backend (open-window) ( world -- )
+M: x11-ui-backend (open-window)
dup gadget-window handle>> window>>
[ set-closable ]
[ [ dpy get ] dip set-class ]
[ XRaiseWindow drop ]
2bi ;
-M: x11-ui-backend raise-window* ( world -- )
+M: x11-ui-backend raise-window*
handle>> [
window>>
XA_NET_ACTIVE_WINDOW net-wm-hint-supported?
[ raise-window-new ] [ raise-window-old ] if
] when* ;
-M: x11-handle select-gl-context ( handle -- )
+M: x11-handle select-gl-context
dpy get swap
[ window>> ] [ glx>> ] bi glXMakeCurrent
[ "Failed to set current GLX context" throw ] unless ;
-M: x11-handle flush-gl-context ( handle -- )
+M: x11-handle flush-gl-context
dpy get swap window>> glXSwapBuffers ;
-M: x11-ui-backend (with-ui) ( quot -- )
+M: x11-ui-backend (with-ui)
f [
[
init-clipboard
] with-xim
] with-x ;
-M: x11-ui-backend beep ( -- )
+M: x11-ui-backend beep
dpy get 100 XBell drop ;
<PRIVATE
swap pick commands set-at
update-gestures ;
-M: word command-name ( word -- str )
+M: word command-name
name>>
"com-" ?head drop "." ?tail drop
dup first Letter? [ rest ] unless
(command-name) ;
-M: word command-description ( word -- str )
+M: word command-description
+description+ word-prop ;
: default-flags ( -- assoc )
[ 1quotation ] [ +nullary+ word-prop ] bi
[ nip ] [ curry ] if ;
-M: word invoke-command ( target command -- )
+M: word invoke-command
command-quot call( -- ) ;
M: word command-word ;
-M: f invoke-command ( target command -- ) 2drop ;
+M: f invoke-command 2drop ;
: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
-M: book model-changed ( model book -- )
+M: book model-changed
nip
dup hide-all
dup current-page show-gadget
: <empty-book> ( model -- book )
book new-book ;
-M: book pref-dim* ( book -- dim ) children>> pref-dims max-dims ;
+M: book pref-dim* children>> pref-dims max-dims ;
-M: book layout* ( book -- )
+M: book layout*
[ children>> ] [ dim>> ] bi '[ _ >>dim drop ] each ;
-M: book focusable-child* ( book -- child/t ) current-page ;
+M: book focusable-child* current-page ;
PRIVATE>
-M: editor draw-line ( line index editor -- )
+M: editor draw-line
[ selected-lines get at ] dip over
[ draw-selected-line ] [ nip draw-unselected-line ] if ;
rect rect-bounds v+ axis children quot (fast-children-on) ?1+
children <slice> ; inline
-M: gadget contains-rect? ( bounds gadget -- ? )
+M: gadget contains-rect?
dup visible?>> [ call-next-method ] [ 2drop f ] if ;
-M: gadget contains-point? ( loc gadget -- ? )
+M: gadget contains-point?
dup visible?>> [ call-next-method ] [ 2drop f ] if ;
: pick-up ( point gadget -- child/f )
PRIVATE>
-M: gadget dim<< ( dim gadget -- )
+M: gadget dim<<
2dup dim>> =
[ 2drop ]
[ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
M: grid layout* [ grid>> ] [ <grid-layout> ] bi layout-grid ;
-M: grid children-on ( rect gadget -- seq )
+M: grid children-on
dup children>> empty? [ 2drop f ] [
[ { 0 1 } ] dip
[ grid>> ] [ dim>> ] bi
SLOT: string
-M: label string>> ( label -- string )
+M: label string>>
text>> dup string? [ "\n" join ] unless ; inline
<PRIVATE
: ?string-lines ( string -- string/array )
CHAR: \n over member-eq? [ string-lines ] when ;
-M: label string<< ( string label -- )
+M: label string<<
[
dup string-array? [
string check-instance ?string-lines
M: pack layout*
dup children>> pref-dims pack-layout ;
-M: pack children-on ( rect gadget -- seq )
+M: pack children-on
[ orientation>> ] [ children>> ] bi [ loc>> ] fast-children-on ;
TUPLE: pane-control < pane quot ;
-M: pane-control model-changed ( model pane-control -- )
+M: pane-control model-changed
[ value>> ] [ dup quot>> ] bi*
'[ _ call( value -- ) ] with-pane ;
GENERIC: sloppy-pick-up* ( loc gadget -- n )
-M: pack sloppy-pick-up* ( loc gadget -- n )
+M: pack sloppy-pick-up*
[ orientation>> ] [ children>> ] bi
[ loc>> ] (fast-children-on) ;
] with-variable
] if ;
-M: table line-height* ( table -- y )
+M: table line-height*
[ font>> ] [ renderer>> prototype-row ] bi
[ cell-dim + nip ] with [ max ] map-reduce ;
} cleave
'[ [ _ n*v _ set-axis ] when* ] 2map ;
-M: track layout* ( track -- ) dup track-layout pack-layout ;
+M: track layout* dup track-layout pack-layout ;
: track-pref-dims-1 ( track -- dim )
[ children>> pref-dims max-dims ]
max-dims
] [ gap-dim ] bi v+ ;
-M: track pref-dim* ( gadget -- dim )
+M: track pref-dim*
[ track-pref-dims-1 ]
[ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
[ orientation>> ]
[ (request-focus) ] keep
] unless focus-child ;
-M: world request-focus-on ( child gadget -- )
+M: world request-focus-on
2dup eq?
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
: generalize-gesture ( gesture -- )
clone f >># button-gesture ;
-M: world handle-gesture ( gesture gadget -- ? )
+M: world handle-gesture
2dup call-next-method [
{
{ [ over specific-button-up? ] [ drop generalize-gesture f ] }
GENERIC: handles-gesture? ( gesture gadget -- ? )
-M: object handles-gesture? ( gesture gadget -- ? )
+M: object handles-gesture?
get-gesture-handler >boolean ;
: parents-handle-gesture? ( gesture gadget -- ? )
: operation-quot ( target operation -- quot )
[ translator>> ] [ command>> ] bi '[ _ @ _ execute ] ;
-M: operation invoke-command ( target command -- )
+M: operation invoke-command
operation-quot call( -- ) ;
[ >rgba-components 4array dup 2array ] map concat concat
float >c-array ;
-M: gradient recompute-pen ( gadget gradient -- )
+M: gradient recompute-pen
[ nip ] [ [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi* ] 2bi
[ gradient-vertices >>last-vertices ]
[ gradient-colors >>last-colors ]
swap draw-scaled-image
] with-translation ;
-M: tile-pen draw-interior ( gadget pen -- )
+M: tile-pen draw-interior
{
[ nip >tile-pen< ]
[ compute-tile-xs ]
M: core-text-renderer flush-layout-cache
cached-lines get-global purge-cache ;
-M: core-text-renderer string>image ( font string -- image loc )
+M: core-text-renderer string>image
cached-line [ line>image ] [ loc>> scale-dim ] bi ;
M:: core-text-renderer x>offset ( x font string -- n )
f
CTLineGetOffsetForStringIndex unscale ;
-M: core-text-renderer font-metrics ( font -- metrics )
+M: core-text-renderer font-metrics
cache-font-metrics ;
-M: core-text-renderer line-metrics ( font string -- metrics )
+M: core-text-renderer line-metrics
[ " " line-metrics clone 0 >>width ]
[ cached-line metrics>> scale-metrics ]
if-empty ;
M: pango-renderer flush-layout-cache
cached-layouts get-global purge-cache ;
-M: pango-renderer string>image ( font string -- image loc )
+M: pango-renderer string>image
cached-layout [ layout>image ] [ text-position vneg ] bi ;
-M: pango-renderer x>offset ( x font string -- n )
+M: pango-renderer x>offset
cached-layout swap x>line-offset ;
-M: pango-renderer offset>x ( n font string -- x )
+M: pango-renderer offset>x
cached-layout swap line-offset>x ;
-M: pango-renderer font-metrics ( font -- metrics )
+M: pango-renderer font-metrics
" " cached-layout metrics>> clone f >>width ;
-M: pango-renderer line-metrics ( font string -- metrics )
+M: pango-renderer line-metrics
[ " " line-metrics clone 0 >>width ]
[ cached-layout metrics>> ]
if-empty ;
M: uniscribe-renderer flush-layout-cache
cached-script-strings get-global purge-cache ;
-M: uniscribe-renderer string>image ( font string -- image loc )
+M: uniscribe-renderer string>image
cached-script-string script-string>image { 0 0 } ;
-M: uniscribe-renderer x>offset ( x font string -- n )
+M: uniscribe-renderer x>offset
[ 2drop 0 ] [
cached-script-string x>line-offset 0 = [ 1 + ] unless
] if-empty ;
-M: uniscribe-renderer offset>x ( n font string -- x )
+M: uniscribe-renderer offset>x
[ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;
-M: uniscribe-renderer font-metrics ( font -- metrics )
+M: uniscribe-renderer font-metrics
" " cached-script-string metrics>> clone f >>width ;
-M: uniscribe-renderer line-metrics ( font string -- metrics )
+M: uniscribe-renderer line-metrics
[ " " line-metrics clone 0 >>width ]
[ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]
if-empty ;
[ [ dup vocab-link? [ lookup-vocab ] when ] dip in? ]
} 2|| ;
-M: browser-gadget definitions-changed ( set browser -- )
+M: browser-gadget definitions-changed
[ control-value swap showing-definition? ] keep
'[ _ [ history-value ] keep set-history-value ] when ;
[ nip first first ]
} cond ;
-M: interactor stream-read-until ( seps stream -- seq sep/f )
+M: interactor stream-read-until
swap '[
_ interactor-read [
"\n" join CHAR: \n suffix
[ (call-listener) ] with-ctrl-break
] "Listener call" spawn drop ;
-M: listener-command invoke-command ( target command -- )
+M: listener-command invoke-command
[ command-quot ] [ nip ] 2bi call-listener ;
-M: listener-operation invoke-command ( target command -- )
+M: listener-operation invoke-command
[ operation-quot ] [ nip command>> ] 2bi call-listener ;
: eval-listener ( string -- )
: try-parse ( lines -- quot/f )
[ parse-lines-interactive ] [ nip '[ _ rethrow ] ] recover ;
-M: interactor stream-read-quot ( stream -- quot/f )
+M: interactor stream-read-quot
dup interactor-yield dup array? [
over interactor-finish try-parse
[ ] [ stream-read-quot ] ?if
: check-group-struct ( group-struct ptr -- group-struct/f )
void* deref [ drop f ] unless ;
-M: integer group-struct ( id -- group/f )
+M: integer group-struct
(group-struct)
[ [ unix.ffi:getgrgid_r ] unix-system-call drop ] keep
check-group-struct ;
-M: string group-struct ( string -- group/f )
+M: string group-struct
(group-struct)
[ [ unix.ffi:getgrnam_r ] unix-system-call drop ] keep
check-group-struct ;
GENERIC: user-groups ( string/id -- seq )
-M: string user-groups ( string -- seq )
+M: string user-groups
(user-groups) ;
-M: integer user-groups ( id -- seq )
+M: integer user-groups
user-name (user-groups) ;
: all-groups ( -- seq )
PRIVATE>
-M: integer set-real-group ( id -- )
+M: integer set-real-group
(set-real-group) ;
-M: string set-real-group ( string -- )
+M: string set-real-group
?group-id (set-real-group) ;
-M: integer set-effective-group ( id -- )
+M: integer set-effective-group
(set-effective-group) ;
-M: string set-effective-group ( string -- )
+M: string set-effective-group
?group-id (set-effective-group) ;
GENERIC#: proc-pid-path 1 ( object string -- path )
-M: integer proc-pid-path ( pid string -- path )
+M: integer proc-pid-path
[ "/proc/" ] 2dip
[ number>string "/" append ] dip
3append ;
-M: string proc-pid-path ( pid-string string -- path )
+M: string proc-pid-path
[ "/proc/" ] 2dip [ append-path ] dip append-path ;
: proc-file-lines ( path -- strings ) utf8 file-lines ;
M: signal signal-name n>> signal-name ;
-M: integer signal-name ( n -- str/f ) 1 - signal-names ?nth ;
+M: integer signal-name 1 - signal-names ?nth ;
: signal-name. ( n -- )
signal-name [ " (" ")" surround write ] when* ;
TUPLE: macosx-passwd < passwd change class expire fields ;
-M: macosx new-passwd ( -- macosx-passwd ) macosx-passwd new ;
+M: macosx new-passwd macosx-passwd new ;
-M: macosx passwd>new-passwd ( passwd -- macosx-passwd )
+M: macosx passwd>new-passwd
[ call-next-method ] keep
{
[ pw_change>> >>change ]
<PRIVATE
-M: unix new-passwd ( -- passwd )
+M: unix new-passwd
passwd new ;
-M: unix passwd>new-passwd ( passwd -- seq )
+M: unix passwd>new-passwd
[ new-passwd ] dip
{
[ pw_name>> >>user-name ]
GENERIC: user-passwd ( obj -- passwd/f )
-M: integer user-passwd ( id -- passwd/f )
+M: integer user-passwd
user-cache get
[ at ] [ unix.ffi:getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
-M: string user-passwd ( string -- passwd/f )
+M: string user-passwd
unix.ffi:getpwnam dup [ passwd>new-passwd ] when ;
: user-name ( id -- string )
PRIVATE>
-M: integer set-real-user ( id -- )
+M: integer set-real-user
(set-real-user) ;
-M: string set-real-user ( string -- )
+M: string set-real-user
?user-id (set-real-user) ;
-M: integer set-effective-user ( id -- )
+M: integer set-effective-user
(set-effective-user) ;
-M: string set-effective-user ( string -- )
+M: string set-effective-user
?user-id (set-effective-user) ;
ERROR: no-such-user obj ;
unix.ffi unix.utmpx ;
IN: unix.utmpx.linux
-M: linux utmpx>utmpx-record ( utmpx -- utmpx-record )
+M: linux utmpx>utmpx-record
[ new-utmpx-record ] dip {
[ ut_user>> __UT_NAMESIZE memory>string >>user ]
[ ut_id>> 4 memory>string >>id ]
unix.ffi unix.utmpx ;
IN: unix.utmpx.macosx
-M: macosx utmpx>utmpx-record ( utmpx -- utmpx-record )
+M: macosx utmpx>utmpx-record
[ new-utmpx-record ] dip {
[ ut_user>> _UTX_USERSIZE memory>string >>user ]
[ ut_id>> _UTX_IDSIZE memory>string >>id ]
GENERIC: pprint-qualified ( qualified -- )
-M: qualified pprint-qualified ( qualified -- )
+M: qualified pprint-qualified
[
dup [ vocab>> vocab-name ] [ prefix>> ] bi = [
\ QUALIFIED: pprint-word
] if
] with-pprint ;
-M: from pprint-qualified ( from -- )
+M: from pprint-qualified
[
\ FROM: pprint-word
[ vocab>> pprint-vocab "=>" text ]
\ ; pprint-word
] with-pprint ;
-M: exclude pprint-qualified ( exclude -- )
+M: exclude pprint-qualified
[
\ EXCLUDE: pprint-word
[ vocab>> pprint-vocab "=>" text ]
\ ; pprint-word
] with-pprint ;
-M: rename pprint-qualified ( rename -- )
+M: rename pprint-qualified
[
\ RENAME: pprint-word
[ word>> text ]
IN: webbrowser.freebsd
-M: freebsd open-item ( item -- )
+M: freebsd open-item
present "open" swap 2array run-detached drop ;
IN: webbrowser.linux
-M: linux open-item ( item -- )
+M: linux open-item
present "xdg-open" swap 2array run-detached drop ;
IN: webbrowser.macosx
-M: macosx open-item ( item -- )
+M: macosx open-item
present "open" swap 2array run-detached drop ;
USING: kernel present system webbrowser windows.shell32 windows.user32 ;
IN: webbrowser.windows
-M: windows open-item ( item -- )
+M: windows open-item
[ f "open" ] dip present f f
SW_SHOWNORMAL ShellExecute drop ;
: <win32-handle> ( handle -- win32-handle )
win32-handle new-win32-handle ;
-M: win32-handle dispose* ( handle -- )
+M: win32-handle dispose*
handle>> CloseHandle win32-error=0/f ;
GENERIC: sockaddr>ip ( sockaddr -- string )
-M: sockaddr-in sockaddr>ip ( sockaddr -- string )
+M: sockaddr-in sockaddr>ip
addr>> uint <ref> [ number>string ] { } map-as "." join ;
-M: sockaddr-in6 sockaddr>ip ( uchar-array -- string )
+M: sockaddr-in6 sockaddr>ip
addr>> [ >hex ] { } map-as 2 group [ concat ] map ":" join ;
STRUCT: fd_set
projects / factor.git / commitdiff