+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words help.markup help.syntax ;
-IN: alias
-
-HELP: ALIAS:
-{ $syntax "ALIAS: new-word existing-word" }
-{ $values { "new-word" word } { "existing-word" word } }
-{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." }
-{ $examples
- { $example "USING: alias prettyprint sequences ;"
- "IN: alias.test"
- "ALIAS: sequence-nth nth"
- "0 { 10 20 30 } sequence-nth ."
- "10"
- }
-} ;
-
-ARTICLE: "alias" "Word aliasing"
-"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl
-"Make a new word that aliases another word:"
-{ $subsection define-alias }
-"Make an alias at parse-time:"
-{ $subsection POSTPONE: ALIAS: } ;
-
-ABOUT: "alias"
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors words quotations kernel effects sequences parser ;\r
-IN: alias\r
-\r
-PREDICATE: alias < word "alias" word-prop ;\r
-\r
-M: alias reset-word\r
- [ call-next-method ] [ f "alias" set-word-prop ] bi ;\r
-\r
-M: alias stack-effect\r
- def>> first stack-effect ;\r
-\r
-: define-alias ( new old -- )\r
- [ 1quotation define-inline ]\r
- [ drop t "alias" set-word-prop ] 2bi ;\r
-\r
-: ALIAS: CREATE-WORD scan-word define-alias ; parsing\r
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Defining multiple words with the same name
f swap box-parameter ;
: define-deref ( name -- )
- [ CHAR: * prefix "alien.c-types" create ]
- [ c-getter 0 prefix ] bi
- define-inline ;
+ [ CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
+ (( c-ptr -- value )) define-inline ;
: define-out ( name -- )
[ "alien.c-types" constructor-word ]
- [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ]
- bi define-inline ;
+ [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
+ (( value -- c-ptr )) define-inline ;
: c-bool> ( int -- ? )
- zero? not ;
+ 0 = not ; inline
: define-primitive-type ( type name -- )
[ typedef ]
--- /dev/null
+unportable
[ (>>offset) ] [ type>> heap-size + ] 2bi
] reduce ;
-: define-struct-slot-word ( word quot spec -- )
- offset>> prefix define-inline ;
+: define-struct-slot-word ( word quot spec effect -- )
+ [ offset>> prefix ] dip define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
type>>
[ c-getter ] [ c-type-boxer-quot ] bi append
]
- [ ] tri define-struct-slot-word ;
+ [ ] tri
+ (( c-ptr -- value )) define-struct-slot-word ;
: define-setter ( type spec -- )
[ set-writer-props ] keep
- [ writer>> ] [ type>> c-setter ] [ ] tri define-struct-slot-word ;
+ [ writer>> ] [ type>> c-setter ] [ ] tri
+ (( value c-ptr -- )) define-struct-slot-word ;
: define-field ( type spec -- )
[ define-getter ] [ define-setter ] 2bi ;
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
-fry ;
+fry vocabs.parser ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
<PRIVATE
-: n>byte -3 shift ; inline
+: n>byte ( m -- n ) -3 shift ; inline
: byte/bit ( n alien -- byte bit )
over n>byte alien-unsigned-1 swap 7 bitand ; inline
: set-bit ( ? byte bit -- byte )
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
-: bits>cells 31 + -5 shift ; inline
+: bits>cells ( m -- n ) 31 + -5 shift ; inline
-: bits>bytes 7 + n>byte ; inline
+: bits>bytes ( m -- n ) 7 + n>byte ; inline
: (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip swap underlying>>
-USING: help.markup help.syntax io io.files ;
+USING: help.markup help.syntax io io.files io.pathnames ;
IN: bootstrap.image
ARTICLE: "bootstrap.image" "Bootstrapping new images"
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic assocs hashtables assocs
-hashtables.private io kernel kernel.private math namespaces make
-parser prettyprint sequences sequences.private strings sbufs
+hashtables.private io io.binary io.files io.encodings.binary
+io.pathnames kernel kernel.private math namespaces make parser
+prettyprint sequences sequences.private strings sbufs
vectors words quotations assocs system layouts splitting
grouping growable classes classes.builtin classes.tuple
-classes.tuple.private words.private io.binary io.files vocabs
+classes.tuple.private words.private vocabs
vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
-io.encodings.binary math.order math.private accessors
+math.order math.private accessors
slots.private compiler.units ;
IN: bootstrap.image
SYMBOL: objects
-: (objects) <id> objects get ; inline
+: (objects) ( obj -- id assoc ) <id> objects get ; inline
: lookup-object ( obj -- n/f ) (objects) at ;
! See http://factorcode.org/license.txt for BSD license.
USING: checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io namespaces make
-io.launcher math io.encodings.ascii ;
+io.launcher math io.encodings.ascii io.files.temp io.pathnames
+io.directories ;
IN: bootstrap.image.upload
SYMBOL: upload-images-destination
USING: system vocabs vocabs.loader kernel combinators
-namespaces sequences io.backend ;
+namespaces sequences io.backend accessors ;
IN: bootstrap.io
"bootstrap.compiler" vocab [
- "io." {
+ "io.backend." {
{ [ "io-backend" get ] [ "io-backend" get ] }
- { [ os unix? ] [ "unix" ] }
+ { [ os unix? ] [ "unix." os name>> append ] }
{ [ os winnt? ] [ "windows.nt" ] }
- { [ os wince? ] [ "windows.ce" ] }
} cond append require
] when
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors init namespaces words io
+USING: accessors init namespaces words words.symbol io
kernel.private math memory continuations kernel io.files
-io.backend system parser vocabs sequences
+io.pathnames io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings
-definitions assocs compiler.errors compiler.units
-math.parser generic sets command-line ;
+definitions assocs compiler.errors compiler.units math.parser
+generic sets command-line ;
IN: bootstrap.stage2
SYMBOL: core-bootstrap-time
M: number +second ( timestamp n -- timestamp )
[ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
-: (time+)
+: (time+) ( timestamp duration -- timestamp' duration )
[ second>> +second ] keep
[ minute>> +minute ] keep
[ hour>> +hour ] keep
[ month>> +month ] keep
[ year>> +year ] keep ; inline
-: +slots [ bi@ + ] curry 2keep ; inline
+: +slots ( obj1 obj2 quot -- n obj1 obj2 )
+ [ bi@ + ] curry 2keep ; inline
PRIVATE>
HELP: <remote-channel>
{ $values { "node" "a node object" }
{ "id" "the id of the published channel on the node" }
+ { "remote-channel" remote-channel }
}
{ $description "Create a remote channel that acts as a proxy for a "
"channel on another node. The remote node's channel must have been "
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences byte-arrays locals sequences.private
-io.encodings.binary symbols math.bitwise checksums
+io.encodings.binary math.bitwise checksums
checksums.common checksums.stream ;
IN: checksums.md5
HELP: openssl-checksum
{ $class-description "The class of checksum algorithms implemented by OpenSSL. The exact set of algorithms supported depends on how the OpenSSL library was compiled; " { $snippet "md5" } " and " { $snippet "sha1" } " should be universally available." } ;
-HELP: <openssl-checksum> ( name -- checksum )
-{ $values { "name" "an EVP message digest name" } { "checksum" openssl-checksum } }
+HELP: <openssl-checksum>
+{ $values { "name" "an EVP message digest name" } { "openssl-checksum" openssl-checksum } }
{ $description "Creates a new OpenSSL checksum object." } ;
HELP: openssl-md5
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
make math parser sequences assocs grouping vectors io.binary
-hashtables symbols math.bitwise checksums checksums.common
+hashtables math.bitwise checksums checksums.common
checksums.stream ;
IN: checksums.sha1
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces make
-io.binary symbols math.bitwise checksums checksums.common
+io.binary math.bitwise checksums checksums.common
sbufs strings ;
IN: checksums.sha2
{ $values { "quot" quotation } }
{ $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
-HELP: do-event
-{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
-{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
-
HELP: add-observer
{ $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }
{ $description "Registers an observer with the " { $snippet "NSNotificationCenter" } " singleton." } ;
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
"Utilities:"
{ $subsection NSApp }
-{ $subsection do-event }
{ $subsection add-observer }
{ $subsection remove-observer }
{ $subsection install-delegate }
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
- core-foundation.arrays
-core-foundation.data core-foundation.strings cocoa.messages
-cocoa cocoa.classes cocoa.runtime sequences threads init summary
-kernel.private assocs ;
+core-foundation.arrays core-foundation.data
+core-foundation.strings cocoa.messages cocoa cocoa.classes
+cocoa.runtime sequences threads init summary kernel.private
+assocs ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
IN: cocoa.views
HELP: <PixelFormat>
-{ $values { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
+{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ;
HELP: <GLView>
: NSBackingStoreNonretained 1 ; inline
: NSBackingStoreBuffered 2 ; inline
-: standard-window-type
+: standard-window-type ( -- n )
{
NSTitledWindowMask
NSClosableWindowMask
HELP: column
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
-HELP: <column> ( seq n -- column )
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
+HELP: <column>
+{ $values { "seq" sequence } { "col" "a non-negative integer" } { "column" column } }
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of " { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
{ $examples
{ $example
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations hashtables io io.encodings.utf8
-io.files kernel kernel.private namespaces parser sequences
-strings system splitting vocabs.loader ;
+io.files io.pathnames kernel kernel.private namespaces parser
+sequences strings system splitting vocabs.loader ;
IN: command-line
SYMBOL: script
! Map vregs -> alias classes
SYMBOL: vregs>acs
-: check [ "BUG: static type error detected" throw ] unless* ; inline
+: check ( obj -- obj )
+ [ "BUG: static type error detected" throw ] unless* ; inline
: vreg>ac ( vreg -- ac )
#! Only vregs produced by ##allot, ##peek and ##slot can
compiler.cfg.instructions ;
IN: compiler.cfg.hats
-: i int-regs next-vreg ; inline
-: ^^i i dup ; inline
-: ^^i1 [ ^^i ] dip ; inline
-: ^^i2 [ ^^i ] 2dip ; inline
-: ^^i3 [ ^^i ] 3dip ; inline
+: i ( -- vreg ) int-regs next-vreg ; inline
+: ^^i ( -- vreg vreg ) i dup ; inline
+: ^^i1 ( obj -- vreg vreg obj ) [ ^^i ] dip ; inline
+: ^^i2 ( obj obj -- vreg vreg obj obj ) [ ^^i ] 2dip ; inline
+: ^^i3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^i ] 3dip ; inline
-: d double-float-regs next-vreg ; inline
-: ^^d d dup ; inline
-: ^^d1 [ ^^d ] dip ; inline
-: ^^d2 [ ^^d ] 2dip ; inline
-: ^^d3 [ ^^d ] 3dip ; inline
+: d ( -- vreg ) double-float-regs next-vreg ; inline
+: ^^d ( -- vreg vreg ) d dup ; inline
+: ^^d1 ( obj -- vreg vreg obj ) [ ^^d ] dip ; inline
+: ^^d2 ( obj obj -- vreg vreg obj obj ) [ ^^d ] 2dip ; inline
+: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
-make fry sequences parser ;
+make fry sequences parser accessors ;
IN: compiler.cfg.instructions.syntax
: insn-word ( -- word )
#! this one.
"insn" "compiler.cfg.instructions" lookup ;
+: insn-effect ( word -- effect )
+ boa-effect [ but-last ] change-in { } >>out ;
+
: INSN:
parse-tuple-definition "regs" suffix
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
- [ 2drop dup '[ f _ boa , ] define-inline ]
+ [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ; parsing
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: qualified words sequences kernel combinators
-cpu.architecture
+USING: words sequences kernel combinators cpu.architecture
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.intrinsics.alien
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
-: (binary-conditional)
+: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
[ dup successors>> first2 ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
M: ##dispatch generate-insn
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
-: >slot<
+: >slot< ( insn -- dst obj slot tag )
{
[ dst>> register ]
[ obj>> register ]
M: ##slot-imm generate-insn
>slot< %slot-imm ;
-: >set-slot<
+: >set-slot< ( insn -- src obj slot tag )
{
[ src>> register ]
[ obj>> register ]
M: ##alien-float generate-insn dst/src %alien-float ;
M: ##alien-double generate-insn dst/src %alien-double ;
-: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
+: >alien-setter< ( insn -- src value )
+ [ src>> register ] [ value>> register ] bi ; inline
M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.custom
prettyprint.sections math words combinators
-combinators.short-circuit io sorting hints qualified
+combinators.short-circuit io sorting hints
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
arrays assocs classes classes.algebra combinators generic.math
splitting fry locals classes.tuple alien.accessors
classes.tuple.private slots.private definitions strings.private
-vectors hashtables
+vectors hashtables generic
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
bi
] [ 2drop object-info ] if
] "outputs" set-word-prop
+
+\ equal? [
+ ! If first input has a known type and second input is an
+ ! object, we convert this to [ swap equal? ].
+ in-d>> first2 value-info class>> object class= [
+ value-info class>> \ equal? specific-method
+ [ swap equal? ] f ?
+ ] [ drop f ] if
+] "custom-inlining" set-word-prop
[ { fixnum } declare log2 0 >= ] final-classes
] unit-test
+[ V{ POSTPONE: f } ] [
+ [ { word object } declare equal? ] final-classes
+] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
\r
: [future] ( quot -- quot' ) '[ _ curry future ] ; inline\r
\r
-: future-values dup [ ?future ] change-each ; inline\r
+: future-values ( futures -- futures )\r
+ dup [ ?future ] change-each ; inline\r
\r
PRIVATE>\r
\r
IN: concurrency.distributed.tests
USING: tools.test concurrency.distributed kernel io.files
-arrays io.sockets system combinators threads math sequences
-concurrency.messaging continuations accessors prettyprint ;
+io.files.temp io.directories arrays io.sockets system
+combinators threads math sequences concurrency.messaging
+continuations accessors prettyprint ;
: test-node ( -- addrspec )
{
! See http://factorcode.org/license.txt for BSD license.
USING: serialize sequences concurrency.messaging threads io
io.servers.connection io.encodings.binary
-qualified arrays namespaces kernel accessors ;
+arrays namespaces kernel accessors ;
FROM: io.sockets => host-name <inet> with-client ;
IN: concurrency.distributed
TYPEDEF: uint UInt32
TYPEDEF: ulong CFTypeID
TYPEDEF: UInt32 CFOptionFlags
+TYPEDEF: void* CFUUIDRef
FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
TYPEDEF: void* CFMutableDictionaryRef
TYPEDEF: void* CFNumberRef
TYPEDEF: void* CFSetRef
-TYPEDEF: void* CFUUIDRef
TYPEDEF: int CFNumberType
: kCFNumberSInt8Type 1 ; inline
MTSPR: CTR 9
! Pseudo-instructions
-: LI 0 rot ADDI ; inline
-: SUBI neg ADDI ; inline
-: LIS 0 rot ADDIS ; inline
-: SUBIC neg ADDIC ; inline
-: SUBIC. neg ADDIC. ; inline
-: NOT dup NOR ; inline
-: NOT. dup NOR. ; inline
-: MR dup OR ; inline
-: MR. dup OR. ; inline
-: (SLWI) 0 31 pick - ; inline
+: LI ( value dst -- ) 0 rot ADDI ; inline
+: SUBI ( dst src1 src2 -- ) neg ADDI ; inline
+: LIS ( value dst -- ) 0 rot ADDIS ; inline
+: SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline
+: SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline
+: NOT ( dst src -- ) dup NOR ; inline
+: NOT. ( dst src -- ) dup NOR. ; inline
+: MR ( dst src -- ) dup OR ; inline
+: MR. ( dst src -- ) dup OR. ; inline
+: (SLWI) ( d a b -- d a b x y ) 0 31 pick - ; inline
: SLWI ( d a b -- ) (SLWI) RLWINM ;
: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
-: (SRWI) 32 over - swap 31 ; inline
+: (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline
: SRWI ( d a b -- ) (SRWI) RLWINM ;
: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
-: LOAD32 ( n r -- ) >r w>h/h r> tuck LIS dup rot ORI ;
+: LOAD32 ( n r -- ) [ w>h/h ] dip tuck LIS dup rot ORI ;
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ;
-M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
-M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
+M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
+M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
: CREATE-B ( -- word ) scan "B" prepend create-in ;
M: ppc %prologue ( n -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
0 MFLR
- 1 1 pick neg ADDI
- 11 1 pick xt-save STW
- dup 11 LI
- 11 1 pick next-save STW
- 0 1 rot lr-save + STW ;
+ {
+ [ [ 1 1 ] dip neg ADDI ]
+ [ [ 11 1 ] dip xt-save STW ]
+ [ 11 LI ]
+ [ [ 11 1 ] dip next-save STW ]
+ [ [ 0 1 ] dip lr-save + STW ]
+ } cleave ;
M: ppc %epilogue ( n -- )
#! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0,
#! and jump to the link register.
- 0 1 pick lr-save + LWZ
- 1 1 rot ADDI
+ [ [ 0 1 ] dip lr-save + LWZ ]
+ [ [ 1 1 ] dip ADDI ] bi
0 MTLR ;
:: (%boolean) ( dst temp word -- )
M: single-float-regs STF drop STFS ;
M: double-float-regs STF drop STFD ;
-M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
+M: float-regs %save-param-reg [ 1 rot local@ ] dip STF ;
GENERIC: LF ( dst src off reg-class -- )
M: single-float-regs LF drop LFS ;
M: double-float-regs LF drop LFD ;
-M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
+M: float-regs %load-param-reg [ 1 rot local@ ] dip LF ;
M: stack-params %load-param-reg ( stack reg reg-class -- )
- drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
+ drop [ 0 1 rot local@ LWZ 0 1 ] dip param@ STW ;
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
- 0 1 rot next-param@ LWZ
- 0 1 rot local@ STW ;
+ [ 0 1 ] dip next-param@ LWZ
+ [ 0 1 ] dip local@ STW ;
M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
f %alien-invoke
! Store the return value on the C stack
[
- 3 1 pick local@ STW
- 4 1 rot cell + local@ STW
+ [ [ 3 1 ] dip local@ STW ]
+ [ [ 4 1 ] dip cell + local@ STW ] bi
] when* ;
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
! Compute destination address and load struct size
- [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
+ [ [ 4 1 ] dip local@ ADDI ] [ heap-size 5 LI ] bi*
! Call the function
"to_value_struct" f %alien-invoke ;
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
- >r
- over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
- r> f %alien-invoke ;
+ [ over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if ] dip
+ f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
- >r [
- 3 1 pick local@ LWZ
- 4 1 rot cell + local@ LWZ
- ] when* r> f %alien-invoke ;
+ [
+ [
+ [ [ 3 1 ] dip local@ LWZ ]
+ [ [ 4 1 ] dip cell + local@ LWZ ] bi
+ ] when*
+ ] dip f %alien-invoke ;
: struct-return@ ( n -- n )
[ stack-frame get params>> ] unless* local@ ;
M: ppc %box-large-struct ( n c-type -- )
! If n = f, then we're boxing a returned struct
! Compute destination address and load struct size
- [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
+ [ [ 3 1 ] dip struct-return@ ADDI ] [ heap-size 4 LI ] bi*
! Call the function
"box_value_struct" f %alien-invoke ;
M: x86.64 param-reg-1 int-regs param-regs first ;
M: x86.64 param-reg-2 int-regs param-regs second ;
-: param-reg-3 int-regs param-regs third ; inline
+: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences lexer parser fry ;
+USING: kernel words words.symbol sequences lexer parser fry ;
IN: cpu.x86.assembler.syntax
: define-register ( name num size -- )
! compute quotation location
temp0 temp1 ADD
! load quotation
- temp0 temp0 array-start-offset [+] MOV
- ! execute branch
- temp0 quot-xt-offset [+] JMP
+ arg temp0 array-start-offset [+] MOV
+ ! execute branch. the quot must be in arg, since it might
+ ! not be compiled yet
+ arg quot-xt-offset [+] JMP
] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
: jit->r ( -- )
CHAR: , delimiter set-global
-: delimiter> delimiter get ; inline
+: delimiter> ( -- delimiter ) delimiter get ; inline
DEFER: quoted-field ( -- endchar )
IN: db.pools.tests
-USING: db.pools tools.test continuations io.files namespaces
-accessors kernel math destructors ;
+USING: db.pools tools.test continuations io.files io.files.temp
+io.directories namespaces accessors kernel math destructors ;
\ <db-pool> must-infer
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
-: sqlite-step-has-more-rows? ( prepared -- bool )
+: sqlite-step-has-more-rows? ( prepared -- ? )
{
{ SQLITE_ROW [ t ] }
{ SQLITE_DONE [ f ] }
-USING: io io.files io.launcher kernel namespaces
-prettyprint tools.test db.sqlite db sequences
+USING: io io.files io.files.temp io.directories io.launcher
+kernel namespaces prettyprint tools.test db.sqlite db sequences
continuations db.types db.tuples unicode.case ;
IN: db.sqlite.tests
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel tools.test db db.tuples classes
+USING: io.files io.files.temp kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise system
{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
HELP: <generator-bind>
+{ $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } }
{ $description "" } ;
HELP: <literal-bind>
+{ $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } }
{ $description "" } ;
HELP: <low-level-binding>
+{ $values { "value" object } { "low-level-binding" low-level-binding } }
{ $description "" } ;
HELP: BIG-INTEGER
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io
kernel math namespaces make prettyprint prettyprint.config
-sequences assocs sequences.private strings io.styles io.files
-vectors words system splitting math.parser classes.mixin
-classes.tuple continuations continuations.private combinators
-generic.math classes.builtin classes compiler.units
+sequences assocs sequences.private strings io.styles
+io.pathnames vectors words system splitting math.parser
+classes.mixin classes.tuple continuations continuations.private
+combinators generic.math classes.builtin classes compiler.units
generic.standard vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer compiler.errors
-generic.parser strings.parser ;
+generic.parser strings.parser vocabs.parser ;
IN: debugger
GENERIC: error. ( error -- )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
-math hashtables sets generalizations namespaces make ;
+math hashtables sets generalizations namespaces make
+words.symbol ;
IN: delegate
: protocol-words ( protocol -- words )
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer kernel namespaces sequences definitions
-io.files summary continuations tools.crossref tools.vocabs io
-prettyprint source-files assocs vocabs vocabs.loader io.backend
-splitting accessors ;
+io.files io.backend io.pathnames io summary continuations
+tools.crossref tools.vocabs prettyprint source-files assocs
+vocabs vocabs.loader splitting accessors ;
IN: editors
TUPLE: no-edit-hook ;
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher windows.shell32 io.files
-io.paths.windows strings unicode.case make ;
+io.directories.search.windows strings unicode.case make ;
IN: editors.editpadlite
: editpadlite-path ( -- path )
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher windows.shell32 io.files
-io.paths.windows strings unicode.case make ;
+io.directories.search.windows strings unicode.case make ;
IN: editors.editpadpro
: editpadpro-path ( -- path )
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make io.paths.windows ;
+namespaces sequences windows.shell32 make
+io.directories.search.windows ;
IN: editors.editplus
: editplus-path ( -- path )
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make io.paths.windows ;
+namespaces sequences windows.shell32 make
+io.directories.search.windows ;
IN: editors.emeditor
: emeditor-path ( -- path )
! Copyright (C) 2008 Kibleur Christophe.
! See http://factorcode.org/license.txt for BSD license.
-USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 io.paths.windows make ;
+USING: editors io.files io.launcher kernel math.parser make
+namespaces sequences windows.shell32 io.directories.search.windows ;
IN: editors.etexteditor
: etexteditor-path ( -- str )
-USING: io.unix.backend kernel namespaces editors.gvim
-system ;
+USING: kernel namespaces editors.gvim system ;
IN: editors.gvim.unix
M: unix gvim-path
-USING: editors.gvim io.files io.windows kernel namespaces
-sequences windows.shell32 io.paths.windows system ;
+USING: editors.gvim io.files kernel namespaces sequences
+windows.shell32 io.directories.search.windows system
+io.pathnames ;
IN: editors.gvim.windows
M: windows gvim-path
namespaces parser prettyprint sequences strings words
editors io.files io.sockets io.streams.byte-array io.binary
math.parser io.encodings.ascii io.encodings.binary
-io.encodings.utf8 io.files.private ;
+io.encodings.utf8 io.files.private io.pathnames ;
IN: editors.jedit
: jedit-server-info ( -- port auth )
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences windows.shell32 make io.pathnames ;
IN: editors.notepad2
: notepad2-path ( -- path )
\ notepad2-path get-global [
- "C:\\Windows\\system32\\notepad.exe"
+ windows-directory "system32\\notepad.exe" append-path
] unless* ;
: notepad2 ( file line -- )
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences io.paths.windows make ;
+namespaces sequences io.directories.search.windows make ;
IN: editors.notepadpp
: notepadpp-path ( -- path )
! Copyright (C) 2007 Clemens F. Hofreither.
! See http://factorcode.org/license.txt for BSD license.
! clemens.hofreither@gmx.net
-USING: io.files io.launcher kernel namespaces io.paths.windows
+USING: io.files io.launcher kernel namespaces io.directories.search.windows
math math.parser editors sequences make unicode.case ;
IN: editors.scite
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences io.paths.windows make ;
+namespaces sequences io.directories.search.windows make ;
IN: editors.ted-notepad
: ted-notepad-path ( -- path )
--- /dev/null
+Doug Coleman
--- /dev/null
+TextPad editor integration
--- /dev/null
+unportable
--- /dev/null
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences make io.directories.search
+io.directories.search.windows ;
+IN: editors.textpad
+
+: textpad-path ( -- path )
+ \ textpad-path get-global [
+ "TextPad 5" t [ "TextPad.exe" tail? ] find-in-program-files
+ ] unless* ;
+
+: textpad ( file line -- )
+ [
+ textpad-path , [ , ] [ number>string "(" ",0)" surround , ] bi*
+ ] { } make run-detached drop ;
+
+[ textpad ] edit-hook set-global
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences io.paths.windows make ;
+namespaces sequences io.directories.search.windows make ;
IN: editors.ultraedit
: ultraedit-path ( -- path )
-USING: definitions help help.markup help.syntax io io.files editors words ;
+USING: definitions editors help help.markup help.syntax io io.files
+ io.pathnames words ;
IN: editors.vim
ARTICLE: { "vim" "vim" } "Vim support"
-USING: editors io.launcher kernel io.paths.windows
+USING: editors io.launcher kernel io.directories.search.windows
math.parser namespaces sequences io.files arrays ;
IN: editors.wordpad
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.utf8
-io.files io.sockets kernel io.streams.duplex math
+io.files io.pathnames io.sockets kernel io.streams.duplex math
math.parser sequences splitting namespaces strings fry ftp
ftp.client.listing-parser urls ;
IN: ftp.client
[ nip parent-directory ftp-cwd drop ]
[ file-name (ftp-get) ] 2bi
] with-ftp-client ;
-
-
-
-
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io.files kernel math.parser
+USING: accessors combinators io.files.types kernel math.parser
sequences splitting ;
IN: ftp.client.listing-parser
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit accessors combinators io
io.encodings.8-bit io.encodings io.encodings.binary
-io.encodings.utf8 io.files io.sockets kernel math.parser
-namespaces make sequences ftp io.unix.launcher.parser
-unicode.case splitting assocs classes io.servers.connection
-destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays
-io.backend tools.hexdump tools.files io.streams.string ;
+io.encodings.utf8 io.files io.files.info io.directories
+io.pathnames io.sockets kernel math.parser namespaces make
+sequences ftp io.launcher.unix.parser unicode.case splitting
+assocs classes io.servers.connection destructors calendar
+io.timeouts io.streams.duplex threads continuations math
+concurrency.promises byte-arrays io.backend tools.hexdump
+tools.files io.streams.string math.bitwise ;
IN: ftp.server
TUPLE: ftp-client url mode state command-promise user password ;
[ >>raw ] [ tokenize-command >>tokenized ] bi ;
: (send-response) ( n string separator -- )
- rot number>string write write ftp-send ;
+ [ number>string write ] 2dip write ftp-send ;
: send-response ( ftp-response -- )
[ n>> ] [ strings>> ] bi
: handle-TYPE ( obj -- )
[
tokenized>> second parse-type
- 200 "Switching to " rot " mode" 3append server-response
+ [ 200 ] dip "Switching to " " mode" surround server-response
] [
2drop "TYPE is binary only" ftp-error
] recover ;
remote-address get class new 0 >>port binary <server> ;
: port>bytes ( port -- hi lo )
- [ -8 shift ] keep [ HEX: ff bitand ] bi@ ;
+ [ -8 shift ] keep [ 8 bits ] bi@ ;
: handle-PWD ( obj -- )
drop
- 257 current-directory get "\"" "\"" surround server-response ;
+ 257 current-directory get "\"" dup surround server-response ;
: handle-SYST ( obj -- )
drop
finish-directory ;
: transfer-outgoing-file ( path -- )
- 150 "Opening BINARY mode data connection for "
- rot
- [ file-name ] [
- " " swap file-info size>> number>string
- "(" " bytes)." surround append
- ] bi 3append server-response ;
+ [
+ 150
+ "Opening BINARY mode data connection for "
+ ] dip
+ [
+ file-name
+ ] [
+ file-info size>> number>string
+ "(" " bytes)." surround
+ ] bi " " glue append server-response ;
: transfer-incoming-file ( path -- )
- 150 "Opening BINARY mode data connection for " rot append
+ [ 150 ] dip "Opening BINARY mode data connection for " prepend
server-response ;
: finish-file-transfer ( -- )
: handle-SIZE ( obj -- )
[
+ [ 213 ] dip
tokenized>> second file-info size>>
- 213 swap number>string server-response
+ number>string server-response
] [
2drop
550 "Could not get file size" server-response
: handle-PASV ( obj -- )
drop client get passive >>mode drop
- expect-connection
- [
- "Entering Passive Mode (127,0,0,1," %
- port>bytes [ number>string ] bi@ "," glue %
- ")" %
- ] "" make 227 swap server-response ;
+ 221
+ expect-connection port>bytes [ number>string ] bi@ "," glue
+ "Entering Passive Mode (127,0,0,1," ")" surround
+ server-response ;
: handle-EPSV ( obj -- )
drop
client get command-promise>> [
"You already have a passive stream" ftp-error
] [
- 229 "Entering Extended Passive Mode (|||"
+ 229
expect-connection number>string
- "|)" 3append server-response
+ "Entering Extended Passive Mode (|||" "|)" surround
+ server-response
] if ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
USING: kernel quotations classes.tuple make combinators generic
words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
-effects.parser locals.types locals.parser locals.rewrite.closures ;
+effects.parser locals.types locals.parser
+locals.rewrite.closures vocabs.parser ;
IN: functors
: scan-param ( -- obj )
furnace.auth.providers\r
furnace.auth.providers.db tools.test\r
namespaces db db.sqlite db.tuples continuations\r
-io.files accessors kernel ;\r
+io.files io.files.temp io.directories accessors kernel ;\r
\r
<action> "test" <login-realm> realm set\r
\r
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs
namespaces sequences splitting words
-fry urls multiline present qualified
+fry urls multiline present
xml
xml.data
xml.entities
{ $values { "url" url } { "response" response } }
{ $description "Creates a response which redirects the client to the given URL." } ;
-HELP: <secure-only> ( responder -- responder' )
-{ $values { "responder" "a responder" } { "responder'" "a responder" } }
+HELP: <secure-only>
+{ $values { "responder" "a responder" } { "secure-only" "a responder" } }
{ $description "Creates a new responder which ensures that the client is connecting via HTTPS before delegating to the underlying responder. If the client is connecting via HTTP, a redirect is sent instead." } ;
HELP: <secure-redirect>
USING: tools.test http furnace.sessions furnace.actions\r
http.server http.server.responses math namespaces make kernel\r
accessors io.sockets io.servers.connection prettyprint\r
-io.streams.string io.files splitting destructors sequences db\r
-db.tuples db.sqlite continuations urls math.parser furnace\r
-furnace.utilities ;\r
+io.streams.string io.files io.files.temp io.directories\r
+splitting destructors sequences db db.tuples db.sqlite\r
+continuations urls math.parser furnace furnace.utilities ;\r
\r
: with-session\r
[\r
TUPLE: chunking-seq { seq read-only } { n read-only } ;
-: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
+: check-groups ( n -- n )
+ dup 0 <= [ "Invalid group count" throw ] when ; inline
: new-groups ( seq n class -- groups )
[ check-groups ] dip boa ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
-: (heap-compare) drop [ key>> ] compare ; inline
+: (heap-compare) ( pair1 pair2 heap -- <=> )
+ drop [ key>> ] compare ; inline
M: min-heap heap-compare (heap-compare) +gt+ eq? ;
{ $heading "Streams" }
{ $subsection "streams" }
{ $subsection "io.files" }
+{ $heading "The file system" }
+{ $subsection "io.pathnames" }
+{ $subsection "io.files.info" }
+{ $subsection "io.files.links" }
+{ $subsection "io.directories" }
{ $heading "Encodings" }
{ $subsection "encodings-introduction" }
{ $subsection "io.encodings" }
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io io.styles kernel namespaces make
-parser prettyprint sequences words assocs definitions generic
-quotations effects slots continuations classes.tuple debugger
-combinators vocabs help.stylesheet help.topics help.crossref
-help.markup sorting classes vocabs.loader ;
+parser prettyprint sequences words words.symbol assocs
+definitions generic quotations effects slots continuations
+classes.tuple debugger combinators vocabs help.stylesheet
+help.topics help.crossref help.markup sorting classes
+vocabs.loader ;
IN: help
GENERIC: word-help* ( word -- content )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
-io.files html.streams html.elements help kernel
+io.files io.files.temp io.directories html.streams html.elements help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
io io.streams.string prettyprint definitions arrays vectors
combinators combinators.short-circuit splitting debugger
hashtables sorting effects vocabs vocabs.loader assocs editors
-continuations classes.predicate macros math sets eval ;
+continuations classes.predicate macros math sets eval
+vocabs.parser words.symbol ;
IN: help.lint
: check-example ( element -- )
: check-values ( word element -- )
{
+ [ drop { [ symbol? ] [ macro? ] [ parsing-word? ] } 1|| ]
[ drop "declared-effect" word-prop not ]
[ nip contains-funky-elements? ]
- [ drop macro? ]
[
[ effect-values >array ]
[ extract-values >array ]
] each ;
: vocab-exists? ( name -- ? )
- dup vocab swap "all-vocabs" get member? or ;
+ [ vocab ] [ "all-vocabs" get member? ] bi or ;
: check-modules ( element -- )
\ $vocab-link swap elements [
USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots
-vocabs help.stylesheet help.topics vocabs.loader alias
-quotations ;
+vocabs help.stylesheet help.topics vocabs.loader quotations ;
IN: help.markup
! Simple markup language.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel parser sequences words help
-help.topics namespaces vocabs definitions compiler.units ;
+help.topics namespaces vocabs definitions compiler.units
+vocabs.parser ;
IN: help.syntax
: HELP:
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting
-math generic generic.standard generic.standard.engines classes ;
+math generic generic.standard generic.standard.engines classes
+hashtables ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
] [ drop f ] if ;
: specialized-def ( word -- quot )
- dup def>> swap {
- {
- [ dup "specializer" word-prop ]
- [ "specializer" word-prop specialize-quot ]
- }
- { [ dup standard-method? ] [ specialize-method ] }
- [ drop ]
- } cond ;
+ [ def>> ] keep
+ [ dup standard-method? [ specialize-method ] [ drop ] if ]
+ [ "specializer" word-prop [ specialize-quot ] when* ]
+ bi ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;
\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
+
+\ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop
+
+\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop
html.templates.chloe.compiler html.templates.chloe.components
math xml.data strings quotations namespaces ;
-HELP: <chloe> ( path -- template )
-{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "template" chloe } }
+HELP: <chloe>
+{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } }
{ $description "Creates a new Chloe template object which can be passed to " { $link call-template } "." } ;
HELP: required-attr
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel fry
namespaces make classes.tuple assocs splitting words arrays io
-io.files io.encodings.utf8 io.streams.string unicode.case
-mirrors math urls present multiline quotations xml logging
-continuations
+io.files io.files.info io.encodings.utf8 io.streams.string
+unicode.case mirrors math urls present multiline quotations xml
+logging continuations
xml.data
html.forms
html.elements
IN: html.templates.fhtml
USING: help.markup help.syntax ;
-HELP: <fhtml> ( path -- fhtml )
+HELP: <fhtml>
{ $values { "path" "a pathname string" } { "fhtml" fhtml } }
{ $description "Creates an FHTML template descriptor." } ;
-USING: http help.markup help.syntax io.files io.streams.string
+USING: http help.markup help.syntax io.pathnames io.streams.string
io.encodings.8-bit io.encodings.binary kernel strings urls
urls.encoding byte-arrays strings assocs sequences ;
IN: http.client
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math math.parser namespaces make
-sequences io io.sockets io.streams.string io.files io.timeouts
-strings splitting calendar continuations accessors vectors
+sequences strings splitting calendar continuations accessors vectors
math.order hashtables byte-arrays destructors
-io.encodings
-io.encodings.string
-io.encodings.ascii
-io.encodings.utf8
-io.encodings.8-bit
-io.encodings.binary
-io.streams.duplex
-fry ascii urls urls.encoding present
+io io.sockets io.streams.string io.files io.timeouts
+io.pathnames io.encodings io.encodings.string io.encodings.ascii
+io.encodings.utf8 io.encodings.8-bit io.encodings.binary
+io.streams.duplex fry ascii urls urls.encoding present
http http.parsers ;
IN: http.client
! Live-fire exercise
USING: http.server http.server.static furnace.sessions furnace.alloy
furnace.actions furnace.auth furnace.auth.login furnace.db http.client
-io.servers.connection io.files io io.encodings.ascii
+io.servers.connection io.files io.files.temp io.directories io io.encodings.ascii
accessors namespaces threads
http.server.responses http.server.redirection furnace.redirection
http.server.dispatchers db.tuples ;
io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit
-unicode.case unicode.categories qualified
+unicode.case unicode.categories
http.parsers ;
HELP: trivial-responder
{ $description "The class of trivial responders, which output the same response for every request. New instances are created by calling " { $link <trivial-responder> } "." } ;
-HELP: <trivial-responder> ( response -- responder )
-{ $values { "response" response } { "responder" trivial-responder } }
+HELP: <trivial-responder>
+{ $values { "response" response } { "trivial-responder" trivial-responder } }
{ $description "Creates a new trivial responder which outputs the same response for every request." } ;
HELP: benchmark?
! Copyright (C) 2004, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar io io.files kernel math math.order\r
-math.parser namespaces parser sequences strings\r
-assocs hashtables debugger mime.types sorting logging\r
-calendar.format accessors splitting\r
-io.encodings.binary fry xml.entities destructors urls\r
-html.elements html.templates.fhtml\r
-http\r
-http.server\r
-http.server.responses\r
+USING: calendar kernel math math.order math.parser namespaces\r
+parser sequences strings assocs hashtables debugger mime.types\r
+sorting logging calendar.format accessors splitting io io.files\r
+io.files.info io.directories io.pathnames io.encodings.binary\r
+fry xml.entities destructors urls html.elements\r
+html.templates.fhtml http http.server http.server.responses\r
http.server.redirection ;\r
IN: http.server.static\r
\r
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces system kernel accessors assocs continuations
+unix io.backend io.backend.unix io.backend.unix.multiplexers
+io.backend.unix.multiplexers.kqueue io.files.unix ;
+IN: io.backend.unix.bsd
+
+M: bsd init-io ( -- )
+ <kqueue-mx> mx set-global ;
+
+! M: bsd (monitor) ( path recursive? mailbox -- )
+! swap [ "Recursive kqueue monitors not supported" throw ] when
+! <vnode-monitor> ;
--- /dev/null
+unportable
--- /dev/null
+USING: io.backend.unix.bsd io.backend system ;
+
+freebsd set-io-backend
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel system namespaces io.files.unix io.backend
+io.backend.unix io.backend.unix.multiplexers
+io.backend.unix.multiplexers.epoll ;
+IN: io.backend.unix.linux
+
+M: linux init-io ( -- )
+ <epoll-mx> mx set-global ;
+
+linux set-io-backend
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend system namespaces io.backend.unix.bsd
+io.backend.unix.multiplexers io.backend.unix.multiplexers.run-loop ;
+IN: io.backend.macosx
+
+M: macosx init-io ( -- )
+ <run-loop-mx> mx set-global ;
+
+macosx set-io-backend
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types kernel destructors bit-arrays
+sequences assocs struct-arrays math namespaces locals fry unix
+unix.linux.epoll unix.time io.ports io.backend.unix
+io.backend.unix.multiplexers ;
+IN: io.backend.unix.multiplexers.epoll
+
+TUPLE: epoll-mx < mx events ;
+
+: max-events ( -- n )
+ #! We read up to 256 events at a time. This is an arbitrary
+ #! constant...
+ 256 ; inline
+
+: <epoll-mx> ( -- mx )
+ epoll-mx new-mx
+ max-events epoll_create dup io-error >>fd
+ max-events "epoll-event" <struct-array> >>events ;
+
+M: epoll-mx dispose fd>> close-file ;
+
+: make-event ( fd events -- event )
+ "epoll-event" <c-object>
+ [ set-epoll-event-events ] keep
+ [ set-epoll-event-fd ] keep ;
+
+:: do-epoll-ctl ( fd mx what events -- )
+ mx fd>> what fd fd events make-event epoll_ctl io-error ;
+
+: do-epoll-add ( fd mx events -- )
+ EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ;
+
+: do-epoll-del ( fd mx events -- )
+ EPOLL_CTL_DEL swap do-epoll-ctl ;
+
+M: epoll-mx add-input-callback ( thread fd mx -- )
+ [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ;
+
+M: epoll-mx add-output-callback ( thread fd mx -- )
+ [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ;
+
+M: epoll-mx remove-input-callbacks ( fd mx -- seq )
+ 2dup reads>> key? [
+ [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
+ ] [ 2drop f ] if ;
+
+M: epoll-mx remove-output-callbacks ( fd mx -- seq )
+ 2dup writes>> key? [
+ [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi
+ ] [ 2drop f ] if ;
+
+: wait-event ( mx us -- n )
+ [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
+ epoll_wait multiplexer-error ;
+
+: handle-event ( event mx -- )
+ [ epoll-event-fd ] dip
+ [ EPOLLIN EPOLLOUT bitor do-epoll-del ]
+ [ input-available ] [ output-available ] 2tri ;
+
+: handle-events ( mx n -- )
+ [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ;
+
+M: epoll-mx wait-for-events ( us mx -- )
+ swap 60000000 or dupd wait-event handle-events ;
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types combinators destructors
+io.backend.unix kernel math.bitwise sequences struct-arrays unix
+unix.kqueue unix.time assocs io.backend.unix.multiplexers ;
+IN: io.backend.unix.multiplexers.kqueue
+
+TUPLE: kqueue-mx < mx events ;
+
+: max-events ( -- n )
+ #! We read up to 256 events at a time. This is an arbitrary
+ #! constant...
+ 256 ; inline
+
+: <kqueue-mx> ( -- mx )
+ kqueue-mx new-mx
+ kqueue dup io-error >>fd
+ max-events "kevent" <struct-array> >>events ;
+
+M: kqueue-mx dispose fd>> close-file ;
+
+: make-kevent ( fd filter flags -- event )
+ "kevent" <c-object>
+ [ set-kevent-flags ] keep
+ [ set-kevent-filter ] keep
+ [ set-kevent-ident ] keep ;
+
+: register-kevent ( kevent mx -- )
+ fd>> swap 1 f 0 f kevent io-error ;
+
+M: kqueue-mx add-input-callback ( thread fd mx -- )
+ [ call-next-method ] [
+ [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ register-kevent
+ ] 2bi ;
+
+M: kqueue-mx add-output-callback ( thread fd mx -- )
+ [ call-next-method ] [
+ [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ register-kevent
+ ] 2bi ;
+
+M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
+ 2dup reads>> key? [
+ [ call-next-method ] [
+ [ EVFILT_READ EV_DELETE make-kevent ] dip
+ register-kevent
+ ] 2bi
+ ] [ 2drop f ] if ;
+
+M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
+ 2dup writes>> key? [
+ [
+ [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+ register-kevent
+ ] [ call-next-method ] 2bi
+ ] [ 2drop f ] if ;
+
+: wait-kevent ( mx timespec -- n )
+ [
+ [ fd>> f 0 ]
+ [ events>> [ underlying>> ] [ length ] bi ] bi
+ ] dip kevent multiplexer-error ;
+
+: handle-kevent ( mx kevent -- )
+ [ kevent-ident swap ] [ kevent-filter ] bi {
+ { EVFILT_READ [ input-available ] }
+ { EVFILT_WRITE [ output-available ] }
+ } case ;
+
+: handle-kevents ( mx n -- )
+ [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
+
+M: kqueue-mx wait-for-events ( us mx -- )
+ swap dup [ make-timespec ] when
+ dupd wait-kevent handle-kevents ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs sequences threads ;
+IN: io.backend.unix.multiplexers
+
+TUPLE: mx fd reads writes ;
+
+: new-mx ( class -- obj )
+ new
+ H{ } clone >>reads
+ H{ } clone >>writes ; inline
+
+GENERIC: add-input-callback ( thread fd mx -- )
+
+M: mx add-input-callback reads>> push-at ;
+
+GENERIC: add-output-callback ( thread fd mx -- )
+
+M: mx add-output-callback writes>> push-at ;
+
+GENERIC: remove-input-callbacks ( fd mx -- callbacks )
+
+M: mx remove-input-callbacks reads>> delete-at* drop ;
+
+GENERIC: remove-output-callbacks ( fd mx -- callbacks )
+
+M: mx remove-output-callbacks writes>> delete-at* drop ;
+
+GENERIC: wait-for-events ( ms mx -- )
+
+: input-available ( fd mx -- )
+ reads>> delete-at* drop [ resume ] each ;
+
+: output-available ( fd mx -- )
+ writes>> delete-at* drop [ resume ] each ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays namespaces math accessors alien locals
+destructors system threads io.backend.unix.multiplexers
+io.backend.unix.multiplexers.kqueue core-foundation
+core-foundation.run-loop ;
+IN: io.backend.unix.multiplexers.run-loop
+
+TUPLE: run-loop-mx kqueue-mx ;
+
+: file-descriptor-callback ( -- callback )
+ "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
+ "cdecl" [
+ 3drop
+ 0 mx get kqueue-mx>> wait-for-events
+ reset-run-loop
+ yield
+ ] alien-callback ;
+
+: <run-loop-mx> ( -- mx )
+ [
+ <kqueue-mx> |dispose
+ dup fd>> file-descriptor-callback add-fd-to-run-loop
+ run-loop-mx boa
+ ] with-destructors ;
+
+M: run-loop-mx add-input-callback kqueue-mx>> add-input-callback ;
+M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ;
+M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ;
+M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ;
+
+M: run-loop-mx wait-for-events ( us mx -- )
+ swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ;
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel bit-arrays sequences assocs unix
+math namespaces accessors math.order locals unix.time fry
+io.ports io.backend.unix io.backend.unix.multiplexers ;
+IN: io.backend.unix.multiplexers.select
+
+TUPLE: select-mx < mx read-fdset write-fdset ;
+
+! Factor's bit-arrays are an array of bytes, OS X expects
+! FD_SET to be an array of cells, so we have to account for
+! byte order differences on big endian platforms
+: munge ( i -- i' )
+ little-endian? [ BIN: 11000 bitxor ] unless ; inline
+
+: <select-mx> ( -- mx )
+ select-mx new-mx
+ FD_SETSIZE 8 * <bit-array> >>read-fdset
+ FD_SETSIZE 8 * <bit-array> >>write-fdset ;
+
+: clear-nth ( n seq -- ? )
+ [ nth ] [ [ f ] 2dip set-nth ] 2bi ;
+
+:: check-fd ( fd fdset mx quot -- )
+ fd munge fdset clear-nth [ fd mx quot call ] when ; inline
+
+: check-fdset ( fds fdset mx quot -- )
+ [ check-fd ] 3curry each ; inline
+
+: init-fdset ( fds fdset -- )
+ '[ t swap munge _ set-nth ] each ;
+
+: read-fdset/tasks ( mx -- seq fdset )
+ [ reads>> keys ] [ read-fdset>> ] bi ;
+
+: write-fdset/tasks ( mx -- seq fdset )
+ [ writes>> keys ] [ write-fdset>> ] bi ;
+
+: max-fd ( assoc -- n )
+ dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
+
+: num-fds ( mx -- n )
+ [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
+
+: init-fdsets ( mx -- nfds read write except )
+ [ num-fds ]
+ [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
+ [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
+ f ;
+
+M:: select-mx wait-for-events ( us mx -- )
+ mx
+ [ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
+ [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
+ [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
+ tri ;
--- /dev/null
+unportable
--- /dev/null
+USING: io.backend.unix.bsd io.backend system ;
+
+netbsd set-io-backend
--- /dev/null
+unportable
--- /dev/null
+USING: io.backend.unix.bsd io.backend system ;
+
+openbsd set-io-backend
--- /dev/null
+unportable
--- /dev/null
+Non-blocking I/O and sockets on Unix-like systems
--- /dev/null
+unportable
--- /dev/null
+USING: io.files io.files.temp io.directories io.sockets io kernel threads
+namespaces tools.test continuations strings byte-arrays
+sequences prettyprint system io.encodings.binary io.encodings.ascii
+io.streams.duplex destructors make ;
+IN: io.backend.unix.tests
+
+! Unix domain stream sockets
+: socket-server "unix-domain-socket-test" temp-file ;
+
+[
+ [ socket-server delete-file ] ignore-errors
+
+ socket-server <local>
+ ascii <server> [
+ accept drop [
+ "Hello world" print flush
+ readln "XYZ" = "FOO" "BAR" ? print flush
+ ] with-stream
+ ] with-disposal
+
+ socket-server delete-file
+] "Test" spawn drop
+
+yield
+
+[ { "Hello world" "FOO" } ] [
+ [
+ socket-server <local> ascii [
+ readln ,
+ "XYZ" print flush
+ readln ,
+ ] with-client
+ ] { } make
+] unit-test
+
+: datagram-server "unix-domain-datagram-test" temp-file ;
+: datagram-client "unix-domain-datagram-test-2" temp-file ;
+
+! Unix domain datagram sockets
+[ datagram-server delete-file ] ignore-errors
+[ datagram-client delete-file ] ignore-errors
+
+[
+ [
+ datagram-server <local> <datagram> "d" set
+
+ "Receive 1" print
+
+ "d" get receive [ reverse ] dip
+
+ "Send 1" print
+ dup .
+
+ "d" get send
+
+ "Receive 2" print
+
+ "d" get receive [ " world" append ] dip
+
+ "Send 1" print
+ dup .
+
+ "d" get send
+
+ "d" get dispose
+
+ "Done" print
+
+ datagram-server delete-file
+ ] with-scope
+] "Test" spawn drop
+
+yield
+
+[ datagram-client delete-file ] ignore-errors
+
+datagram-client <local> <datagram>
+"d" set
+
+[ ] [
+ "hello" >byte-array
+ datagram-server <local>
+ "d" get send
+] unit-test
+
+[ "olleh" t ] [
+ "d" get receive
+ datagram-server <local> =
+ [ >string ] dip
+] unit-test
+
+[ ] [
+ "hello" >byte-array
+ datagram-server <local>
+ "d" get send
+] unit-test
+
+[ "hello world" t ] [
+ "d" get receive
+ datagram-server <local> =
+ [ >string ] dip
+] unit-test
+
+[ ] [ "d" get dispose ] unit-test
+
+! Test error behavior
+: another-datagram "unix-domain-datagram-test-3" temp-file ;
+
+[ another-datagram delete-file ] ignore-errors
+
+datagram-client delete-file
+
+[ ] [ datagram-client <local> <datagram> "d" set ] unit-test
+
+[ B{ 1 2 3 } another-datagram <local> "d" get send ] must-fail
+
+[ ] [ "d" get dispose ] unit-test
+
+! See what happens on send/receive after close
+
+[ "d" get receive ] must-fail
+
+[ B{ 1 2 } datagram-server <local> "d" get send ] must-fail
+
+! Invalid parameter tests
+
+[
+ image binary [ input-stream get accept ] with-file-reader
+] must-fail
+
+[
+ image binary [ input-stream get receive ] with-file-reader
+] must-fail
+
+[
+ image binary [
+ B{ 1 2 } datagram-server <local>
+ input-stream get send
+ ] with-file-reader
+] must-fail
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax generic assocs kernel
+kernel.private math io.ports sequences strings sbufs threads
+unix vectors io.buffers io.backend io.encodings math.parser
+continuations system libc namespaces make io.timeouts
+io.encodings.utf8 destructors accessors summary combinators
+locals unix.time fry io.backend.unix.multiplexers ;
+QUALIFIED: io
+IN: io.backend.unix
+
+GENERIC: handle-fd ( handle -- fd )
+
+TUPLE: fd fd disposed ;
+
+: init-fd ( fd -- fd )
+ [
+ |dispose
+ dup fd>> F_SETFL O_NONBLOCK fcntl io-error
+ dup fd>> F_SETFD FD_CLOEXEC fcntl io-error
+ ] with-destructors ;
+
+: <fd> ( n -- fd )
+ #! We drop the error code rather than calling io-error,
+ #! since on OS X 10.3, this operation fails from init-io
+ #! when running the Factor.app (presumably because fd 0 and
+ #! 1 are closed).
+ f fd boa ;
+
+M: fd dispose
+ dup disposed>> [ drop ] [
+ [ cancel-operation ]
+ [ t >>disposed drop ]
+ [ fd>> close-file ]
+ tri
+ ] if ;
+
+M: fd handle-fd dup check-disposed fd>> ;
+
+M: fd cancel-operation ( fd -- )
+ dup disposed>> [ drop ] [
+ fd>>
+ mx get-global
+ [ remove-input-callbacks [ t swap resume-with ] each ]
+ [ remove-output-callbacks [ t swap resume-with ] each ]
+ 2bi
+ ] if ;
+
+SYMBOL: +retry+ ! just try the operation again without blocking
+SYMBOL: +input+
+SYMBOL: +output+
+
+ERROR: io-timeout ;
+
+M: io-timeout summary drop "I/O operation timed out" ;
+
+: wait-for-fd ( handle event -- )
+ dup +retry+ eq? [ 2drop ] [
+ '[
+ swap handle-fd mx get-global _ {
+ { +input+ [ add-input-callback ] }
+ { +output+ [ add-output-callback ] }
+ } case
+ ] "I/O" suspend nip [ io-timeout ] when
+ ] if ;
+
+: wait-for-port ( port event -- )
+ '[ handle>> _ wait-for-fd ] with-timeout ;
+
+! Some general stuff
+: file-mode OCT: 0666 ;
+
+! Readers
+: (refill) ( port -- n )
+ [ handle>> ]
+ [ buffer>> buffer-end ]
+ [ buffer>> buffer-capacity ] tri read ;
+
+! Returns an event to wait for which will ensure completion of
+! this request
+GENERIC: refill ( port handle -- event/f )
+
+M: fd refill
+ fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
+ {
+ { [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
+ { [ err_no EINTR = ] [ 2drop +retry+ ] }
+ { [ err_no EAGAIN = ] [ 2drop +input+ ] }
+ [ (io-error) ]
+ } cond ;
+
+M: unix (wait-to-read) ( port -- )
+ dup
+ dup handle>> dup check-disposed refill dup
+ [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
+
+! Writers
+GENERIC: drain ( port handle -- event/f )
+
+M: fd drain
+ fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write
+ {
+ { [ dup 0 >= ] [
+ over buffer>> buffer-consume
+ buffer>> buffer-empty? f +output+ ?
+ ] }
+ { [ err_no EINTR = ] [ 2drop +retry+ ] }
+ { [ err_no EAGAIN = ] [ 2drop +output+ ] }
+ [ (io-error) ]
+ } cond ;
+
+M: unix (wait-to-write) ( port -- )
+ dup
+ dup handle>> dup check-disposed drain
+ dup [ wait-for-port ] [ 2drop ] if ;
+
+M: unix io-multiplex ( ms/f -- )
+ mx get-global wait-for-events ;
+
+! On Unix, you're not supposed to set stdin to non-blocking
+! because the fd might be shared with another process (either
+! parent or child). So what we do is have the VM start a thread
+! which pumps data from the real stdin to a pipe. We set the
+! pipe to non-blocking, and read from it instead of the real
+! stdin. Very crufty, but it will suffice until we get native
+! threading support at the language level.
+TUPLE: stdin control size data disposed ;
+
+M: stdin dispose*
+ [
+ [ control>> &dispose drop ]
+ [ size>> &dispose drop ]
+ [ data>> &dispose drop ]
+ tri
+ ] with-destructors ;
+
+: wait-for-stdin ( stdin -- n )
+ [ control>> CHAR: X over io:stream-write1 io:stream-flush ]
+ [ size>> "ssize_t" heap-size swap io:stream-read *int ]
+ bi ;
+
+:: refill-stdin ( buffer stdin size -- )
+ stdin data>> handle-fd buffer buffer-end size read
+ dup 0 < [
+ drop
+ err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
+ ] [
+ size = [ "Error reading stdin pipe" throw ] unless
+ size buffer n>buffer
+ ] if ;
+
+M: stdin refill
+ [ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
+
+: control-write-fd ( -- fd ) &: control_write *uint ;
+
+: size-read-fd ( -- fd ) &: size_read *uint ;
+
+: data-read-fd ( -- fd ) &: stdin_read *uint ;
+
+: <stdin> ( -- stdin )
+ stdin new
+ control-write-fd <fd> <output-port> >>control
+ size-read-fd <fd> init-fd <input-port> >>size
+ data-read-fd <fd> >>data ;
+
+M: unix (init-stdio) ( -- )
+ <stdin> <input-port>
+ 1 <fd> <output-port>
+ 2 <fd> <output-port> ;
+
+! mx io-task for embedding an fd-based mx inside another mx
+TUPLE: mx-port < port mx ;
+
+: <mx-port> ( mx -- port )
+ dup fd>> mx-port <port> swap >>mx ;
+
+: multiplexer-error ( n -- n )
+ dup 0 < [
+ err_no [ EAGAIN = ] [ EINTR = ] bi or
+ [ drop 0 ] [ (io-error) ] if
+ ] when ;
+
+: ?flag ( n mask symbol -- n )
+ pick rot bitand 0 > [ , ] [ drop ] if ;
--- /dev/null
+Doug Coleman
+Mackenzie Straight
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
--- /dev/null
+USING: alien alien.c-types arrays assocs combinators
+continuations destructors io io.backend io.ports io.timeouts
+io.backend.windows io.files.windows io.files.windows.nt io.files
+io.pathnames io.buffers io.streams.c libc kernel math namespaces
+sequences threads windows windows.errors windows.kernel32
+strings splitting ascii system accessors locals ;
+QUALIFIED: windows.winsock
+IN: io.backend.windows.nt
+
+! Global variable with assoc mapping overlapped to threads
+SYMBOL: pending-overlapped
+
+TUPLE: io-callback port thread ;
+
+C: <io-callback> io-callback
+
+: (make-overlapped) ( -- overlapped-ext )
+ "OVERLAPPED" malloc-object &free ;
+
+: make-overlapped ( port -- overlapped-ext )
+ [ (make-overlapped) ] dip
+ handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
+
+M: winnt FileArgs-overlapped ( port -- overlapped )
+ make-overlapped ;
+
+: <completion-port> ( handle existing -- handle )
+ f 1 CreateIoCompletionPort dup win32-error=0/f ;
+
+SYMBOL: master-completion-port
+
+: <master-completion-port> ( -- handle )
+ INVALID_HANDLE_VALUE f <completion-port> ;
+
+M: winnt add-completion ( win32-handle -- )
+ handle>> master-completion-port get-global <completion-port> drop ;
+
+: eof? ( error -- ? )
+ [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
+
+: twiddle-thumbs ( overlapped port -- bytes-transferred )
+ [
+ drop
+ [ pending-overlapped get-global set-at ] curry "I/O" suspend
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup array? ] [
+ first dup eof?
+ [ drop 0 ] [ (win32-error-string) throw ] if
+ ] }
+ } cond
+ ] with-timeout ;
+
+:: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
+ master-completion-port get-global
+ 0 <int> [ ! bytes
+ f <void*> ! key
+ f <void*> [ ! overlapped
+ us [ 1000 /i ] [ INFINITE ] if* ! timeout
+ GetQueuedCompletionStatus zero?
+ ] keep *void*
+ ] keep *int spin ;
+
+: resume-callback ( result overlapped -- )
+ pending-overlapped get-global delete-at* drop resume-with ;
+
+: handle-overlapped ( us -- ? )
+ wait-for-overlapped [
+ dup [
+ [ drop GetLastError 1array ] dip resume-callback t
+ ] [ 2drop f ] if
+ ] [ resume-callback t ] if ;
+
+M: win32-handle cancel-operation
+ [ check-disposed ] [ handle>> CancelIo drop ] bi ;
+
+M: winnt io-multiplex ( us -- )
+ handle-overlapped [ 0 io-multiplex ] when ;
+
+M: winnt init-io ( -- )
+ <master-completion-port> master-completion-port set-global
+ H{ } clone pending-overlapped set-global
+ windows.winsock:init-winsock ;
+
+: file-error? ( n -- eof? )
+ zero? [
+ GetLastError {
+ { [ dup expected-io-error? ] [ drop f ] }
+ { [ dup eof? ] [ drop t ] }
+ [ (win32-error-string) throw ]
+ } cond
+ ] [ f ] if ;
+
+: wait-for-file ( FileArgs n port -- n )
+ swap file-error?
+ [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
+
+: update-file-ptr ( n port -- )
+ handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
+
+: finish-write ( n port -- )
+ [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
+
+M: winnt (wait-to-write)
+ [
+ [ make-FileArgs dup setup-write WriteFile ]
+ [ wait-for-file ]
+ [ finish-write ]
+ tri
+ ] with-destructors ;
+
+: finish-read ( n port -- )
+ [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
+
+M: winnt (wait-to-read) ( port -- )
+ [
+ [ make-FileArgs dup setup-read ReadFile ]
+ [ wait-for-file ]
+ [ finish-read ]
+ tri
+ ] with-destructors ;
+
+M: winnt (init-stdio) init-c-stdio ;
+
+winnt set-io-backend
--- /dev/null
+USING: alien alien.c-types alien.syntax arrays continuations\r
+destructors generic io.mmap io.ports io.backend.windows io.files.windows\r
+kernel libc math math.bitwise namespaces quotations sequences windows\r
+windows.advapi32 windows.kernel32 io.backend system accessors\r
+io.backend.windows.privileges ;\r
+IN: io.backend.windows.nt.privileges\r
+\r
+TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES\r
+\r
+! Security tokens\r
+! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/\r
+\r
+: (open-process-token) ( handle -- handle )\r
+ { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>\r
+ [ OpenProcessToken win32-error=0/f ] keep *void* ;\r
+\r
+: open-process-token ( -- handle )\r
+ #! remember to CloseHandle\r
+ GetCurrentProcess (open-process-token) ;\r
+\r
+: with-process-token ( quot -- )\r
+ #! quot: ( token-handle -- token-handle )\r
+ [ open-process-token ] dip\r
+ [ keep ] curry\r
+ [ CloseHandle drop ] [ ] cleanup ; inline\r
+\r
+: lookup-privilege ( string -- luid )\r
+ [ f ] dip "LUID" <c-object>\r
+ [ LookupPrivilegeValue win32-error=0/f ] keep ;\r
+\r
+: make-token-privileges ( name ? -- obj )\r
+ "TOKEN_PRIVILEGES" <c-object>\r
+ 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep\r
+ "LUID_AND_ATTRIBUTES" malloc-array &free\r
+ over set-TOKEN_PRIVILEGES-Privileges\r
+\r
+ swap [\r
+ SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges\r
+ set-LUID_AND_ATTRIBUTES-Attributes\r
+ ] when\r
+\r
+ [ lookup-privilege ] dip\r
+ [\r
+ TOKEN_PRIVILEGES-Privileges\r
+ set-LUID_AND_ATTRIBUTES-Luid\r
+ ] keep ;\r
+\r
+M: winnt set-privilege ( name ? -- )\r
+ [\r
+ -rot 0 -rot make-token-privileges\r
+ dup length f f AdjustTokenPrivileges win32-error=0/f\r
+ ] with-process-token ;\r
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+USING: io.backend kernel continuations sequences\r
+system vocabs.loader combinators ;\r
+IN: io.backend.windows.privileges\r
+\r
+HOOK: set-privilege io-backend ( name ? -- ) inline\r
+\r
+: with-privileges ( seq quot -- )\r
+ over [ [ t set-privilege ] each ] curry compose\r
+ swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline\r
+\r
+{\r
+ { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }\r
+ { [ os wince? ] [ "io.backend.windows.ce.privileges" require ] }\r
+} cond\r
--- /dev/null
+unportable
--- /dev/null
+Microsoft Windows native I/O implementation
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types arrays destructors io io.backend
+io.buffers io.files io.ports io.binary io.timeouts
+windows.errors strings kernel math namespaces sequences windows
+windows.kernel32 windows.shell32 windows.types windows.winsock
+splitting continuations math.bitwise system accessors ;
+IN: io.backend.windows
+
+: set-inherit ( handle ? -- )
+ [ HANDLE_FLAG_INHERIT ] dip
+ >BOOLEAN SetHandleInformation win32-error=0/f ;
+
+TUPLE: win32-handle handle disposed ;
+
+: new-win32-handle ( handle class -- win32-handle )
+ new swap [ >>handle ] [ f set-inherit ] bi ;
+
+: <win32-handle> ( handle -- win32-handle )
+ win32-handle new-win32-handle ;
+
+M: win32-handle dispose* ( handle -- )
+ handle>> CloseHandle drop ;
+
+TUPLE: win32-file < win32-handle ptr ;
+
+: <win32-file> ( handle -- win32-file )
+ win32-file new-win32-handle ;
+
+M: win32-file dispose
+ dup disposed>> [ drop ] [
+ [ cancel-operation ] [ call-next-method ] bi
+ ] if ;
+
+HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
+HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
+HOOK: add-completion io-backend ( port -- )
+
+: opened-file ( handle -- win32-file )
+ dup invalid-handle?
+ <win32-file> |dispose
+ dup add-completion ;
+
+: share-mode ( -- fixnum )
+ {
+ FILE_SHARE_READ
+ FILE_SHARE_WRITE
+ FILE_SHARE_DELETE
+ } flags ; foldable
+
+: default-security-attributes ( -- obj )
+ "SECURITY_ATTRIBUTES" <c-object>
+ "SECURITY_ATTRIBUTES" heap-size
+ over set-SECURITY_ATTRIBUTES-nLength ;
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax io.files.private io.pathnames
+quotations ;
+IN: io.directories
+
+HELP: cwd
+{ $values { "path" "a pathname string" } }
+{ $description "Outputs the current working directory of the Factor process." }
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
+
+HELP: cd
+{ $values { "path" "a pathname string" } }
+{ $description "Changes the current working directory of the Factor process." }
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
+
+{ cd cwd current-directory set-current-directory with-directory } related-words
+
+HELP: current-directory
+{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable."
+$nl
+"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ;
+
+HELP: set-current-directory
+{ $values { "path" "a pathname string" } }
+{ $description "Changes the " { $link current-directory } " variable."
+$nl
+"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
+
+HELP: with-directory
+{ $values { "path" "a pathname string" } { "quot" quotation } }
+{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound."
+$nl
+"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
+
+HELP: (directory-entries)
+{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }
+{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
+{ $notes "This is a low-level word, and user code should call one of the related words instead." } ;
+
+HELP: directory-entries
+{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $link directory-entry } " objects" } }
+{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
+
+HELP: directory-files
+{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } }
+{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
+
+HELP: with-directory-files
+{ $values { "path" "a pathname string" } { "quot" quotation } }
+{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
+
+HELP: delete-file
+{ $values { "path" "a pathname string" } }
+{ $description "Deletes a file." }
+{ $errors "Throws an error if the file could not be deleted." } ;
+
+HELP: make-directory
+{ $values { "path" "a pathname string" } }
+{ $description "Creates a directory." }
+{ $errors "Throws an error if the directory could not be created." } ;
+
+HELP: make-directories
+{ $values { "path" "a pathname string" } }
+{ $description "Creates a directory and any parent directories which do not yet exist." }
+{ $errors "Throws an error if the directories could not be created." } ;
+
+HELP: delete-directory
+{ $values { "path" "a pathname string" } }
+{ $description "Deletes a directory. The directory must be empty." }
+{ $errors "Throws an error if the directory could not be deleted." } ;
+
+HELP: touch-file
+{ $values { "path" "a pathname string" } }
+{ $description "Updates the modification time of a file or directory. If the file does not exist, creates a new, empty file." }
+{ $errors "Throws an error if the file could not be touched." } ;
+
+HELP: move-file
+{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
+{ $description "Moves or renames a file." }
+{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
+
+HELP: move-file-into
+{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
+{ $description "Moves a file to another directory without renaming it." }
+{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
+
+HELP: move-files-into
+{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
+{ $description "Moves a set of files to another directory." }
+{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
+
+HELP: copy-file
+{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
+{ $description "Copies a file." }
+{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." }
+{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
+
+HELP: copy-file-into
+{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
+{ $description "Copies a file to another directory." }
+{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
+
+HELP: copy-files-into
+{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
+{ $description "Copies a set of files to another directory." }
+{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
+
+ARTICLE: "current-directory" "Current working directory"
+"File system I/O operations use the value of a variable to resolve relative pathnames:"
+{ $subsection current-directory }
+"This variable can be changed with a pair of words:"
+{ $subsection set-current-directory }
+{ $subsection with-directory }
+"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
+{ $subsection (normalize-path) }
+"The second is to change the working directory of the current process:"
+{ $subsection cd }
+{ $subsection cwd } ;
+
+ARTICLE: "io.directories.listing" "Directory listing"
+"Directory listing:"
+{ $subsection directory-entries }
+{ $subsection directory-files }
+{ $subsection with-directory-files } ;
+
+ARTICLE: "io.directories.create" "Creating directories"
+{ $subsection make-directory }
+{ $subsection make-directories } ;
+
+ARTICLE: "delete-move-copy" "Deleting, moving, and copying files"
+"Operations for deleting and copying files come in two forms:"
+{ $list
+ { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." }
+ { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." }
+}
+"The operations for moving and copying files come in three flavors:"
+{ $list
+ { "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." }
+ { "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." }
+ { "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." }
+}
+"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file."
+$nl
+"Deleting files:"
+{ $subsection delete-file }
+{ $subsection delete-directory }
+"Moving files:"
+{ $subsection move-file }
+{ $subsection move-file-into }
+{ $subsection move-files-into }
+"Copying files:"
+{ $subsection copy-file }
+{ $subsection copy-file-into }
+{ $subsection copy-files-into }
+"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ;
+
+ARTICLE: "io.directories" "Directory manipulation"
+"The " { $vocab-link "io.directories" } " vocabulary defines words for inspecting and manipulating directory trees."
+{ $subsection home }
+{ $subsection "current-directory" }
+{ $subsection "io.directories.listing" }
+{ $subsection "io.directories.create" }
+{ $subsection "delete-move-copy" } ;
+
+ABOUT: "io.directories"
--- /dev/null
+USING: continuations destructors io io.directories
+io.directories.hierarchy io.encodings.ascii io.encodings.utf8
+io.files io.files.info io.files.temp io.pathnames kernel
+sequences tools.test ;
+IN: io.directories.tests
+
+[ { "kernel" } ] [
+ "core" resource-path [
+ "." directory-files [ "kernel" = ] filter
+ ] with-directory
+] unit-test
+
+[ { "kernel" } ] [
+ "resource:core" [
+ "." directory-files [ "kernel" = ] filter
+ ] with-directory
+] unit-test
+
+[ { "kernel" } ] [
+ "resource:core" [
+ [ "kernel" = ] filter
+ ] with-directory-files
+] unit-test
+
+[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
+[ ] [ "blahblah" temp-file make-directory ] unit-test
+[ t ] [ "blahblah" temp-file file-info directory? ] unit-test
+
+[ t ] [
+ [ temp-directory "loldir" append-path delete-directory ] ignore-errors
+ temp-directory [
+ "loldir" make-directory
+ ] with-directory
+ temp-directory "loldir" append-path exists?
+] unit-test
+
+[ ] [
+ [ temp-directory "loldir" append-path delete-directory ] ignore-errors
+ temp-directory [
+ "loldir" make-directory
+ "loldir" delete-directory
+ ] with-directory
+] unit-test
+
+[ "file1 contents" ] [
+ [ temp-directory "loldir" append-path delete-directory ] ignore-errors
+ temp-directory [
+ "file1 contents" "file1" utf8 set-file-contents
+ "file1" "file2" copy-file
+ "file2" utf8 file-contents
+ ] with-directory
+ "file1" temp-file delete-file
+ "file2" temp-file delete-file
+] unit-test
+
+[ "file3 contents" ] [
+ temp-directory [
+ "file3 contents" "file3" utf8 set-file-contents
+ "file3" "file4" move-file
+ "file4" utf8 file-contents
+ ] with-directory
+ "file4" temp-file delete-file
+] unit-test
+
+[ "file5" temp-file delete-file ] ignore-errors
+
+[ ] [
+ temp-directory [
+ "file5" touch-file
+ "file5" delete-file
+ ] with-directory
+] unit-test
+
+[ "file6" temp-file delete-file ] ignore-errors
+
+[ ] [
+ temp-directory [
+ "file6" touch-file
+ "file6" link-info drop
+ ] with-directory
+] unit-test
+
+[ ] [
+ { "Hello world." }
+ "test-foo.txt" temp-file ascii set-file-lines
+] unit-test
+
+[ ] [
+ "test-foo.txt" temp-file ascii [
+ "Hello appender." print
+ ] with-file-appender
+] unit-test
+
+[ ] [
+ "test-bar.txt" temp-file ascii [
+ "Hello appender." print
+ ] with-file-appender
+] unit-test
+
+[ "Hello world.\nHello appender.\n" ] [
+ "test-foo.txt" temp-file ascii file-contents
+] unit-test
+
+[ "Hello appender.\n" ] [
+ "test-bar.txt" temp-file ascii file-contents
+] unit-test
+
+[ ] [ "test-foo.txt" temp-file delete-file ] unit-test
+
+[ ] [ "test-bar.txt" temp-file delete-file ] unit-test
+
+[ f ] [ "test-foo.txt" temp-file exists? ] unit-test
+
+[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
+
+[ "test-blah" temp-file delete-tree ] ignore-errors
+
+[ ] [ "test-blah" temp-file make-directory ] unit-test
+
+[ ] [
+ "test-blah/fooz" temp-file ascii <file-writer> dispose
+] unit-test
+
+[ t ] [
+ "test-blah/fooz" temp-file exists?
+] unit-test
+
+[ ] [ "test-blah/fooz" temp-file delete-file ] unit-test
+
+[ ] [ "test-blah" temp-file delete-directory ] unit-test
+
+[ f ] [ "test-blah" temp-file exists? ] unit-test
+
+[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test
+
+[ ] [
+ { "Hi" }
+ "delete-tree-test/a/b/c/d" temp-file ascii set-file-lines
+] unit-test
+
+[ ] [
+ "delete-tree-test" temp-file delete-tree
+] unit-test
+
+[ ] [
+ "copy-tree-test/a/b/c" temp-file make-directories
+] unit-test
+
+[ ] [
+ "Foobar"
+ "copy-tree-test/a/b/c/d" temp-file
+ ascii set-file-contents
+] unit-test
+
+[ ] [
+ "copy-tree-test" temp-file
+ "copy-destination" temp-file copy-tree
+] unit-test
+
+[ "Foobar" ] [
+ "copy-destination/a/b/c/d" temp-file ascii file-contents
+] unit-test
+
+[ ] [
+ "copy-destination" temp-file delete-tree
+] unit-test
+
+[ ] [
+ "copy-tree-test" temp-file
+ "copy-destination" temp-file copy-tree-into
+] unit-test
+
+[ "Foobar" ] [
+ "copy-destination/copy-tree-test/a/b/c/d" temp-file ascii file-contents
+] unit-test
+
+[ ] [
+ "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into
+] unit-test
+
+[ "Foobar" ] [
+ "d" temp-file ascii file-contents
+] unit-test
+
+[ ] [ "d" temp-file delete-file ] unit-test
+
+[ ] [ "copy-destination" temp-file delete-tree ] unit-test
+
+[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators destructors io io.backend
+io.encodings.binary io.files io.pathnames kernel namespaces
+sequences system vocabs.loader fry ;
+IN: io.directories
+
+: set-current-directory ( path -- )
+ (normalize-path) current-directory set ;
+
+: with-directory ( path quot -- )
+ [ (normalize-path) current-directory ] dip with-variable ; inline
+
+! Creating directories
+HOOK: make-directory io-backend ( path -- )
+
+: make-directories ( path -- )
+ normalize-path trim-right-separators {
+ { [ dup "." = ] [ ] }
+ { [ dup root-directory? ] [ ] }
+ { [ dup empty? ] [ ] }
+ { [ dup exists? ] [ ] }
+ [
+ dup parent-directory make-directories
+ dup make-directory
+ ]
+ } cond drop ;
+
+! Listing directories
+TUPLE: directory-entry name type ;
+
+HOOK: >directory-entry os ( byte-array -- directory-entry )
+
+HOOK: (directory-entries) os ( path -- seq )
+
+: directory-entries ( path -- seq )
+ normalize-path
+ (directory-entries)
+ [ name>> { "." ".." } member? not ] filter ;
+
+: directory-files ( path -- seq )
+ directory-entries [ name>> ] map ;
+
+: with-directory-files ( path quot -- )
+ '[ "" directory-files @ ] with-directory ; inline
+
+! Touching files
+HOOK: touch-file io-backend ( path -- )
+
+! Deleting files
+HOOK: delete-file io-backend ( path -- )
+
+HOOK: delete-directory io-backend ( path -- )
+
+: to-directory ( from to -- from to' )
+ over file-name append-path ;
+
+! Moving and renaming files
+HOOK: move-file io-backend ( from to -- )
+
+: move-file-into ( from to -- )
+ to-directory move-file ;
+
+: move-files-into ( files to -- )
+ '[ _ move-file-into ] each ;
+
+! Copying files
+HOOK: copy-file io-backend ( from to -- )
+
+M: object copy-file
+ dup parent-directory make-directories
+ binary <file-writer> [
+ swap binary <file-reader> [
+ swap stream-copy
+ ] with-disposal
+ ] with-disposal ;
+
+: copy-file-into ( from to -- )
+ to-directory copy-file ;
+
+: copy-files-into ( files to -- )
+ '[ _ copy-file-into ] each ;
+
+{
+ { [ os unix? ] [ "io.directories.unix" require ] }
+ { [ os windows? ] [ "io.directories.windows" require ] }
+} cond
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ;
+IN: io.directories.hierarchy
+
+HELP: delete-tree
+{ $values { "path" "a pathname string" } }
+{ $description "Deletes a file or directory, recursing into subdirectories." }
+{ $errors "Throws an error if the deletion fails." }
+{ $warning "Misuse of this word can lead to catastrophic data loss." } ;
+
+HELP: copy-tree
+{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
+{ $description "Copies a directory tree recursively." }
+{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." }
+{ $errors "Throws an error if the copy operation fails." } ;
+
+HELP: copy-tree-into
+{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
+{ $description "Copies a directory tree to another directory, recursively." }
+{ $errors "Throws an error if the copy operation fails." } ;
+
+HELP: copy-trees-into
+{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
+{ $description "Copies a set of directory trees to another directory, recursively." }
+{ $errors "Throws an error if the copy operation fails." } ;
+
+ARTICLE: "io.directories.hierarchy" "Directory hierarchy manipulation"
+"The " { $vocab-link "io.directories.hierarchy" } " vocabulary defines words for operating on directory hierarchies recursively."
+$nl
+"Deleting directory trees recursively:"
+{ $subsection delete-tree }
+"Copying directory trees recursively:"
+{ $subsection copy-tree }
+{ $subsection copy-tree-into }
+{ $subsection copy-trees-into } ;
+
+ABOUT: "io.directories.hierarchy"
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences combinators fry io.directories
+io.pathnames io.files.info io.files.types io.files.links
+io.backend ;
+IN: io.directories.hierarchy
+
+: delete-tree ( path -- )
+ dup link-info directory? [
+ [ [ [ delete-tree ] each ] with-directory-files ]
+ [ delete-directory ]
+ bi
+ ] [ delete-file ] if ;
+
+DEFER: copy-tree-into
+
+: copy-tree ( from to -- )
+ normalize-path
+ over link-info type>>
+ {
+ { +symbolic-link+ [ copy-link ] }
+ { +directory+ [ '[ [ _ copy-tree-into ] each ] with-directory-files ] }
+ [ drop copy-file ]
+ } case ;
+
+: copy-tree-into ( from to -- )
+ to-directory copy-tree ;
+
+: copy-trees-into ( files to -- )
+ '[ _ copy-tree-into ] each ;
+
--- /dev/null
+Deleting and copying directory hierarchies
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io.directories.search io.files io.files.unique
+io.pathnames kernel namespaces sequences sorting tools.test ;
+IN: io.directories.search.tests
+
+[ t ] [
+ [
+ 10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate
+ current-directory get t [ ] find-all-files
+ ] with-unique-directory
+ [ natural-sort ] bi@ =
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays continuations deques dlists fry
+io.directories io.files io.files.info io.pathnames kernel
+sequences system vocabs.loader ;
+IN: io.directories.search
+
+TUPLE: directory-iterator path bfs queue ;
+
+<PRIVATE
+
+: qualified-directory ( path -- seq )
+ dup directory-files [ append-path ] with map ;
+
+: push-directory ( path iter -- )
+ [ qualified-directory ] dip [
+ dup queue>> swap bfs>>
+ [ push-front ] [ push-back ] if
+ ] curry each ;
+
+: <directory-iterator> ( path bfs? -- iterator )
+ <dlist> directory-iterator boa
+ dup path>> over push-directory ;
+
+: next-file ( iter -- file/f )
+ dup queue>> deque-empty? [ drop f ] [
+ dup queue>> pop-back dup link-info directory?
+ [ over push-directory next-file ] [ nip ] if
+ ] if ;
+
+: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
+ over next-file [
+ over call
+ [ 2nip ] [ iterate-directory ] if*
+ ] [
+ 2drop f
+ ] if* ; inline recursive
+
+PRIVATE>
+
+: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
+ [ <directory-iterator> ] dip
+ [ keep and ] curry iterate-directory ; inline
+
+: each-file ( path bfs? quot: ( obj -- ? ) -- )
+ [ <directory-iterator> ] dip
+ [ f ] compose iterate-directory drop ; inline
+
+: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
+ [ <directory-iterator> ] dip
+ pusher [ [ f ] compose iterate-directory drop ] dip ; inline
+
+: recursive-directory ( path bfs? -- paths )
+ [ ] accumulator [ each-file ] dip ;
+
+: find-in-directories ( directories bfs? quot -- path' )
+ '[ _ _ find-file ] attempt-all ; inline
+
+os windows? [ "io.directories.search.windows" require ] when
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays fry io.pathnames kernel sequences windows.shell32
+io.directories.search ;
+IN: io.directories.search.windows
+
+: program-files-directories ( -- array )
+ program-files program-files-x86 2array ; inline
+
+: find-in-program-files ( base-directory bfs? quot -- path )
+ [
+ [ program-files-directories ] dip '[ _ append-path ] map
+ ] 2dip find-in-directories ; inline
--- /dev/null
+Listing directories, moving, copying and deleting files
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.strings combinators
+continuations destructors fry io io.backend io.backend.unix
+io.directories io.encodings.binary io.encodings.utf8 io.files
+io.pathnames io.files.types kernel math.bitwise sequences system
+unix unix.stat ;
+IN: io.directories.unix
+
+: touch-mode ( -- n )
+ { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
+
+M: unix touch-file ( path -- )
+ normalize-path
+ dup exists? [ touch ] [
+ touch-mode file-mode open-file close-file
+ ] if ;
+
+M: unix move-file ( from to -- )
+ [ normalize-path ] bi@ rename io-error ;
+
+M: unix delete-file ( path -- ) normalize-path unlink-file ;
+
+M: unix make-directory ( path -- )
+ normalize-path OCT: 777 mkdir io-error ;
+
+M: unix delete-directory ( path -- )
+ normalize-path rmdir io-error ;
+
+: (copy-file) ( from to -- )
+ dup parent-directory make-directories
+ binary <file-writer> [
+ swap binary <file-reader> [
+ swap stream-copy
+ ] with-disposal
+ ] with-disposal ;
+
+M: unix copy-file ( from to -- )
+ [ normalize-path ] bi@ (copy-file) ;
+
+: with-unix-directory ( path quot -- )
+ [ opendir dup [ (io-error) ] unless ] dip
+ dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
+
+: find-next-file ( DIR* -- byte-array )
+ "dirent" <c-object>
+ f <void*>
+ [ readdir_r 0 = [ (io-error) ] unless ] 2keep
+ *void* [ drop f ] unless ;
+
+: dirent-type>file-type ( ch -- type )
+ {
+ { DT_BLK [ +block-device+ ] }
+ { DT_CHR [ +character-device+ ] }
+ { DT_DIR [ +directory+ ] }
+ { DT_LNK [ +symbolic-link+ ] }
+ { DT_SOCK [ +socket+ ] }
+ { DT_FIFO [ +fifo+ ] }
+ { DT_REG [ +regular-file+ ] }
+ { DT_WHT [ +whiteout+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+M: unix >directory-entry ( byte-array -- directory-entry )
+ [ dirent-d_name utf8 alien>string ]
+ [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
+
+M: unix (directory-entries) ( path -- seq )
+ [
+ '[ _ find-next-file dup ]
+ [ >directory-entry ]
+ [ drop ] produce
+ ] with-unix-directory ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system io.directories io.encodings.utf16n alien.strings
+io.pathnames io.backend io.files.windows destructors
+kernel accessors calendar windows windows.errors
+windows.kernel32 alien.c-types sequences splitting
+fry continuations ;
+IN: io.directories.windows
+
+M: windows touch-file ( path -- )
+ [
+ normalize-path
+ maybe-create-file [ &dispose ] dip
+ [ drop ] [ handle>> f now dup (set-file-times) ] if
+ ] with-destructors ;
+
+M: windows move-file ( from to -- )
+ [ normalize-path ] bi@ MoveFile win32-error=0/f ;
+
+M: windows delete-file ( path -- )
+ normalize-path DeleteFile win32-error=0/f ;
+
+M: windows copy-file ( from to -- )
+ dup parent-directory make-directories
+ [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
+
+M: windows make-directory ( path -- )
+ normalize-path
+ f CreateDirectory win32-error=0/f ;
+
+M: windows delete-directory ( path -- )
+ normalize-path
+ RemoveDirectory win32-error=0/f ;
+
+: find-first-file ( path -- WIN32_FIND_DATA handle )
+ "WIN32_FIND_DATA" <c-object> tuck
+ FindFirstFile
+ [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
+
+: find-next-file ( path -- WIN32_FIND_DATA/f )
+ "WIN32_FIND_DATA" <c-object> tuck
+ FindNextFile 0 = [
+ GetLastError ERROR_NO_MORE_FILES = [
+ win32-error
+ ] unless drop f
+ ] when ;
+
+TUPLE: windows-directory-entry < directory-entry attributes ;
+
+M: windows >directory-entry ( byte-array -- directory-entry )
+ [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
+ tri
+ dupd remove windows-directory-entry boa ;
+
+M: windows (directory-entries) ( path -- seq )
+ "\\" ?tail drop "\\*" append
+ find-first-file [ >directory-entry ] dip
+ [
+ '[
+ [ _ find-next-file dup ]
+ [ >directory-entry ]
+ [ drop ] produce
+ over name>> "." = [ nip ] [ swap prefix ] if
+ ]
+ ] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ;
+
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+USING: help.syntax help.markup ;
+IN: io.encodings.binary
+
+HELP: binary
+{ $class-description "Encoding descriptor for binary I/O." } ;
+
+ARTICLE: "io.encodings.binary" "Binary encoding"
+"Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings."
+{ $subsection binary } ;
+
+ABOUT: "io.encodings.binary"
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings kernel ;
+IN: io.encodings.binary
+
+SINGLETON: binary
+M: binary <encoder> drop ;
+M: binary <decoder> drop ;
--- /dev/null
+Dummy encoding for binary I/O
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax arrays io.files ;
+IN: io.files.info
+
+HELP: file-info
+{ $values { "path" "a pathname string" } { "info" file-info } }
+{ $description "Queries the file system for metadata. If " { $snippet "path" } " refers to a symbolic link, it is followed. See the article " { $link "file-types" } " for a list of metadata symbols." }
+{ $errors "Throws an error if the file does not exist." } ;
+
+HELP: link-info
+{ $values { "path" "a pathname string" } { "info" "a file-info tuple" } }
+{ $description "Queries the file system for metadata. If path refers to a symbolic link, information about the symbolic link itself is returned. If the file does not exist, an exception is thrown." } ;
+
+{ file-info link-info } related-words
+
+HELP: directory?
+{ $values { "file-info" file-info } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "file-info" } " is a directory." } ;
+
+HELP: file-systems
+{ $values { "array" array } }
+{ $description "Returns an array of " { $link file-system-info } " objects returned by iterating the mount points and calling " { $link file-system-info } " on each." } ;
+
+HELP: file-system-info
+{ $values
+{ "path" "a pathname string" }
+{ "file-system-info" file-system-info } }
+{ $description "Returns a platform-specific object describing the file-system that contains the path. The cross-platform slot is " { $slot "free-space" } "." } ;
+
+ARTICLE: "io.files.info" "File system meta-data"
+"File meta-data:"
+{ $subsection file-info }
+{ $subsection link-info }
+{ $subsection exists? }
+{ $subsection directory? }
+"File types:"
+{ $subsection "file-types" }
+"File system meta-data:"
+{ $subsection file-system-info }
+{ $subsection file-systems } ;
+
+ABOUT: "io.files.info"
--- /dev/null
+USING: io.files.info io.pathnames io.encodings.utf8 io.files
+io.directories kernel io.pathnames accessors tools.test
+sequences io.files.temp ;
+IN: io.files.info.tests
+
+\ file-info must-infer
+\ link-info must-infer
+
+[ t ] [
+ temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
+ temp-directory "test41" append-path utf8 file-contents "hi41" =
+] unit-test
+
+[ t ] [
+ temp-directory [ "test41" file-info size>> ] with-directory 4 =
+] unit-test
+
+[ t ] [ "/" file-system-info file-system-info? ] unit-test
+[ t ] [ file-systems [ file-system-info? ] all? ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel system sequences combinators
+vocabs.loader io.files.types ;
+IN: io.files.info
+
+! File info
+TUPLE: file-info type size permissions created modified
+accessed ;
+
+HOOK: file-info os ( path -- info )
+
+HOOK: link-info os ( path -- info )
+
+: directory? ( file-info -- ? ) type>> +directory+ = ;
+
+! File systems
+HOOK: file-systems os ( -- array )
+
+TUPLE: file-system-info device-name mount-point type
+available-space free-space used-space total-space ;
+
+HOOK: file-system-info os ( path -- file-system-info )
+
+{
+ { [ os unix? ] [ "io.files.info.unix." os name>> append ] }
+ { [ os windows? ] [ "io.files.info.windows" ] }
+} cond require
\ No newline at end of file
--- /dev/null
+File and file system meta-data
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien.syntax math io.files.unix system
+unix.stat accessors combinators calendar.unix
+io.files.info.unix ;
+IN: io.files.info.unix.bsd
+
+TUPLE: bsd-file-info < unix-file-info birth-time flags gen ;
+
+M: bsd new-file-info ( -- class ) bsd-file-info new ;
+
+M: bsd stat>file-info ( stat -- file-info )
+ [ call-next-method ] keep
+ {
+ [ stat-st_flags >>flags ]
+ [ stat-st_gen >>gen ]
+ [
+ stat-st_birthtimespec timespec>unix-time
+ >>birth-time
+ ]
+ } cleave ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax combinators
+io.backend io.files io.files.info io.files.unix kernel math system unix
+unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
+sequences grouping alien.strings io.encodings.utf8
+specialized-arrays.direct.uint arrays io.files.info.unix ;
+IN: io.files.info.unix.freebsd
+
+TUPLE: freebsd-file-system-info < unix-file-system-info
+version io-size owner syncreads syncwrites asyncreads asyncwrites ;
+
+M: freebsd new-file-system-info freebsd-file-system-info new ;
+
+M: freebsd file-system-statfs ( path -- byte-array )
+ "statfs" <c-object> tuck statfs io-error ;
+
+M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
+ {
+ [ statfs-f_version >>version ]
+ [ statfs-f_type >>type ]
+ [ statfs-f_flags >>flags ]
+ [ statfs-f_bsize >>block-size ]
+ [ statfs-f_iosize >>io-size ]
+ [ statfs-f_blocks >>blocks ]
+ [ statfs-f_bfree >>blocks-free ]
+ [ statfs-f_bavail >>blocks-available ]
+ [ statfs-f_files >>files ]
+ [ statfs-f_ffree >>files-free ]
+ [ statfs-f_syncwrites >>syncwrites ]
+ [ statfs-f_asyncwrites >>asyncwrites ]
+ [ statfs-f_syncreads >>syncreads ]
+ [ statfs-f_asyncreads >>asyncreads ]
+ [ statfs-f_namemax >>name-max ]
+ [ statfs-f_owner >>owner ]
+ [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
+ [ statfs-f_fstypename utf8 alien>string >>type ]
+ [ statfs-f_mntfromname utf8 alien>string >>device-name ]
+ [ statfs-f_mntonname utf8 alien>string >>mount-point ]
+ } cleave ;
+
+M: freebsd file-system-statvfs ( path -- byte-array )
+ "statvfs" <c-object> tuck statvfs io-error ;
+
+M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
+ {
+ [ statvfs-f_favail >>files-available ]
+ [ statvfs-f_frsize >>preferred-block-size ]
+ } cleave ;
+
+M: freebsd file-systems ( -- array )
+ f 0 0 getfsstat dup io-error
+ "statfs" <c-array> dup dup length 0 getfsstat io-error
+ "statfs" heap-size group
+ [ statfs-f_mntonname alien>native-string file-system-info ] map ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax combinators csv
+io.backend io.encodings.utf8 io.files io.files.info io.streams.string
+io.files.unix kernel math.order namespaces sequences sorting
+system unix unix.statfs.linux unix.statvfs.linux
+specialized-arrays.direct.uint arrays io.files.info.unix ;
+IN: io.files.info.unix.linux
+
+TUPLE: linux-file-system-info < unix-file-system-info
+namelen ;
+
+M: linux new-file-system-info linux-file-system-info new ;
+
+M: linux file-system-statfs ( path -- byte-array )
+ "statfs64" <c-object> tuck statfs64 io-error ;
+
+M: linux statfs>file-system-info ( struct -- statfs )
+ {
+ [ statfs64-f_type >>type ]
+ [ statfs64-f_bsize >>block-size ]
+ [ statfs64-f_blocks >>blocks ]
+ [ statfs64-f_bfree >>blocks-free ]
+ [ statfs64-f_bavail >>blocks-available ]
+ [ statfs64-f_files >>files ]
+ [ statfs64-f_ffree >>files-free ]
+ [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
+ [ statfs64-f_namelen >>namelen ]
+ [ statfs64-f_frsize >>preferred-block-size ]
+ ! [ statfs64-f_spare >>spare ]
+ } cleave ;
+
+M: linux file-system-statvfs ( path -- byte-array )
+ "statvfs64" <c-object> tuck statvfs64 io-error ;
+
+M: linux statvfs>file-system-info ( struct -- statfs )
+ {
+ [ statvfs64-f_flag >>flags ]
+ [ statvfs64-f_namemax >>name-max ]
+ } cleave ;
+
+TUPLE: mtab-entry file-system-name mount-point type options
+frequency pass-number ;
+
+: mtab-csv>mtab-entry ( csv -- mtab-entry )
+ [ mtab-entry new ] dip
+ {
+ [ first >>file-system-name ]
+ [ second >>mount-point ]
+ [ third >>type ]
+ [ fourth <string-reader> csv first >>options ]
+ [ 4 swap nth >>frequency ]
+ [ 5 swap nth >>pass-number ]
+ } cleave ;
+
+: parse-mtab ( -- array )
+ [
+ "/etc/mtab" utf8 <file-reader>
+ CHAR: \s delimiter set csv
+ ] with-scope
+ [ mtab-csv>mtab-entry ] map ;
+
+M: linux file-systems
+ parse-mtab [
+ [ mount-point>> file-system-info ] keep
+ {
+ [ file-system-name>> >>device-name ]
+ [ mount-point>> >>mount-point ]
+ [ type>> >>type ]
+ } cleave
+ ] map ;
+
+ERROR: file-system-not-found ;
+
+M: linux file-system-info ( path -- )
+ normalize-path
+ [
+ [ new-file-system-info ] dip
+ [ file-system-statfs statfs>file-system-info ]
+ [ file-system-statvfs statvfs>file-system-info ] bi
+ file-system-calculations
+ ] keep
+
+ parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
+ [ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
+ {
+ [ file-system-name>> >>device-name drop ]
+ [ mount-point>> >>mount-point drop ]
+ [ type>> >>type ]
+ } 2cleave ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.strings combinators
+grouping io.encodings.utf8 io.files kernel math sequences
+system unix io.files.unix specialized-arrays.direct.uint arrays
+unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx
+io.files.info.unix io.files.info ;
+IN: io.files.info.unix.macosx
+
+TUPLE: macosx-file-system-info < unix-file-system-info
+io-size owner type-id filesystem-subtype ;
+
+M: macosx file-systems ( -- array )
+ f <void*> dup 0 getmntinfo64 dup io-error
+ [ *void* ] dip
+ "statfs64" heap-size [ * memory>byte-array ] keep group
+ [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
+ ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
+
+M: macosx new-file-system-info macosx-file-system-info new ;
+
+M: macosx file-system-statfs ( normalized-path -- statfs )
+ "statfs64" <c-object> tuck statfs64 io-error ;
+
+M: macosx file-system-statvfs ( normalized-path -- statvfs )
+ "statvfs" <c-object> tuck statvfs io-error ;
+
+M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
+ {
+ [ statfs64-f_bsize >>block-size ]
+ [ statfs64-f_iosize >>io-size ]
+ [ statfs64-f_blocks >>blocks ]
+ [ statfs64-f_bfree >>blocks-free ]
+ [ statfs64-f_bavail >>blocks-available ]
+ [ statfs64-f_files >>files ]
+ [ statfs64-f_ffree >>files-free ]
+ [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
+ [ statfs64-f_owner >>owner ]
+ [ statfs64-f_type >>type-id ]
+ [ statfs64-f_flags >>flags ]
+ [ statfs64-f_fssubtype >>filesystem-subtype ]
+ [ statfs64-f_fstypename utf8 alien>string >>type ]
+ [ statfs64-f_mntonname utf8 alien>string >>mount-point ]
+ [ statfs64-f_mntfromname utf8 alien>string >>device-name ]
+ } cleave ;
+
+M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
+ {
+ [ statvfs-f_frsize >>preferred-block-size ]
+ [ statvfs-f_favail >>files-available ]
+ [ statvfs-f_namemax >>name-max ]
+ } cleave ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel unix.stat math unix
+combinators system io.backend accessors alien.c-types
+io.encodings.utf8 alien.strings unix.types io.files.unix
+io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays
+grouping sequences io.encodings.utf8
+specialized-arrays.direct.uint io.files.info.unix ;
+IN: io.files.info.unix.netbsd
+
+TUPLE: netbsd-file-system-info < unix-file-system-info
+blocks-reserved files-reserved
+owner io-size sync-reads sync-writes async-reads async-writes
+idx mount-from ;
+
+M: netbsd new-file-system-info netbsd-file-system-info new ;
+
+M: netbsd file-system-statvfs
+ "statvfs" <c-object> tuck statvfs io-error ;
+
+M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
+ {
+ [ statvfs-f_flag >>flags ]
+ [ statvfs-f_bsize >>block-size ]
+ [ statvfs-f_frsize >>preferred-block-size ]
+ [ statvfs-f_iosize >>io-size ]
+ [ statvfs-f_blocks >>blocks ]
+ [ statvfs-f_bfree >>blocks-free ]
+ [ statvfs-f_bavail >>blocks-available ]
+ [ statvfs-f_bresvd >>blocks-reserved ]
+ [ statvfs-f_files >>files ]
+ [ statvfs-f_ffree >>files-free ]
+ [ statvfs-f_favail >>files-available ]
+ [ statvfs-f_fresvd >>files-reserved ]
+ [ statvfs-f_syncreads >>sync-reads ]
+ [ statvfs-f_syncwrites >>sync-writes ]
+ [ statvfs-f_asyncreads >>async-reads ]
+ [ statvfs-f_asyncwrites >>async-writes ]
+ [ statvfs-f_fsidx 2 <direct-uint-array> >array >>idx ]
+ [ statvfs-f_fsid >>id ]
+ [ statvfs-f_namemax >>name-max ]
+ [ statvfs-f_owner >>owner ]
+ ! [ statvfs-f_spare >>spare ]
+ [ statvfs-f_fstypename utf8 alien>string >>type ]
+ [ statvfs-f_mntonname utf8 alien>string >>mount-point ]
+ [ statvfs-f_mntfromname utf8 alien>string >>device-name ]
+ } cleave ;
+
+M: netbsd file-systems ( -- array )
+ f 0 0 getvfsstat dup io-error
+ "statvfs" <c-array> dup dup length 0 getvfsstat io-error
+ "statvfs" heap-size group
+ [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.strings alien.syntax
+combinators io.backend io.files io.files.info io.files.unix kernel math
+sequences system unix unix.getfsstat.openbsd grouping
+unix.statfs.openbsd unix.statvfs.openbsd unix.types
+specialized-arrays.direct.uint arrays io.files.info.unix ;
+IN: io.files.unix.openbsd
+
+TUPLE: freebsd-file-system-info < unix-file-system-info
+io-size sync-writes sync-reads async-writes async-reads
+owner ;
+
+M: openbsd new-file-system-info freebsd-file-system-info new ;
+
+M: openbsd file-system-statfs
+ "statfs" <c-object> tuck statfs io-error ;
+
+M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
+ {
+ [ statfs-f_flags >>flags ]
+ [ statfs-f_bsize >>block-size ]
+ [ statfs-f_iosize >>io-size ]
+ [ statfs-f_blocks >>blocks ]
+ [ statfs-f_bfree >>blocks-free ]
+ [ statfs-f_bavail >>blocks-available ]
+ [ statfs-f_files >>files ]
+ [ statfs-f_ffree >>files-free ]
+ [ statfs-f_favail >>files-available ]
+ [ statfs-f_syncwrites >>sync-writes ]
+ [ statfs-f_syncreads >>sync-reads ]
+ [ statfs-f_asyncwrites >>async-writes ]
+ [ statfs-f_asyncreads >>async-reads ]
+ [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
+ [ statfs-f_namemax >>name-max ]
+ [ statfs-f_owner >>owner ]
+ ! [ statfs-f_spare >>spare ]
+ [ statfs-f_fstypename alien>native-string >>type ]
+ [ statfs-f_mntonname alien>native-string >>mount-point ]
+ [ statfs-f_mntfromname alien>native-string >>device-name ]
+ } cleave ;
+
+M: openbsd file-system-statvfs ( normalized-path -- statvfs )
+ "statvfs" <c-object> tuck statvfs io-error ;
+
+M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
+ {
+ [ statvfs-f_frsize >>preferred-block-size ]
+ } cleave ;
+
+M: openbsd file-systems ( -- seq )
+ f 0 0 getfsstat dup io-error
+ "statfs" <c-array> dup dup length 0 getfsstat io-error
+ "statfs" heap-size group
+ [ statfs-f_mntonname alien>native-string file-system-info ] map ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes help.markup help.syntax io.streams.string
+strings math calendar io.files.info io.files.info.unix ;
+IN: io.files.unix
+
+HELP: file-group-id
+{ $values
+ { "path" "a pathname string" }
+ { "gid" integer } }
+{ $description "Returns the group id for a given file." } ;
+
+HELP: file-group-name
+{ $values
+ { "path" "a pathname string" }
+ { "string" string } }
+{ $description "Returns the group name for a given file." } ;
+
+HELP: file-permissions
+{ $values
+ { "path" "a pathname string" }
+ { "n" integer } }
+{ $description "Returns the Unix file permissions for a given file." } ;
+
+HELP: file-username
+{ $values
+ { "path" "a pathname string" }
+ { "string" string } }
+{ $description "Returns the username for a given file." } ;
+
+HELP: file-user-id
+{ $values
+ { "path" "a pathname string" }
+ { "uid" integer } }
+{ $description "Returns the user id for a given file." } ;
+
+HELP: group-execute?
+{ $values
+ { "obj" "a pathname string or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: group-read?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: group-write?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: other-execute?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: other-read?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: other-write?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: set-file-access-time
+{ $values
+ { "path" "a pathname string" } { "timestamp" timestamp } }
+{ $description "Sets a file's last access timestamp." } ;
+
+HELP: set-file-group
+{ $values
+ { "path" "a pathname string" } { "string/id" "a string or a group id" } }
+{ $description "Sets a file's group id from the given group id or group name." } ;
+
+HELP: set-file-ids
+{ $values
+ { "path" "a pathname string" } { "uid" integer } { "gid" integer } }
+{ $description "Sets the user id and group id of a file with a single library call." } ;
+
+HELP: set-file-permissions
+{ $values
+ { "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } }
+{ $description "Sets the file permissions for a given file with the supplied Unix permissions integer. Supplying an octal number with " { $link POSTPONE: OCT: } " is recommended." }
+{ $examples "Using the tradidional octal value:"
+ { $unchecked-example "USING: io.files.unix kernel ;"
+ "\"resource:license.txt\" OCT: 755 set-file-permissions"
+ ""
+ }
+ "Higher-level, setting named bits:"
+ { $unchecked-example "USING: io.files.unix kernel math.bitwise ;"
+ "\"resource:license.txt\""
+ "{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }"
+ "flags set-file-permissions"
+ "" }
+} ;
+
+HELP: set-file-times
+{ $values
+ { "path" "a pathname string" } { "timestamps" "an array of two timestamps" } }
+{ $description "Sets the access and write timestamps for a file as provided in the input array. A value of " { $link f } " provided for either of the timestamps will not change that timestamp." } ;
+
+HELP: set-file-user
+{ $values
+ { "path" "a pathname string" } { "string/id" "a string or a user id" } }
+{ $description "Sets a file's user id from the given user id or username." } ;
+
+HELP: set-file-modified-time
+{ $values
+ { "path" "a pathname string" } { "timestamp" timestamp } }
+{ $description "Sets a file's last modified timestamp, or write timestamp." } ;
+
+HELP: set-gid
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "gid" } " bit of a file to true or false." } ;
+
+HELP: gid?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: set-group-execute
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "group execute" } " bit of a file to true or false." } ;
+
+HELP: set-group-read
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "group read" } " bit of a file to true or false." } ;
+
+HELP: set-group-write
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "group write" } " bit of a file to true or false." } ;
+
+HELP: set-other-execute
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
+
+HELP: set-other-read
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "other read" } " bit of a file to true or false." } ;
+
+HELP: set-other-write
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
+
+HELP: set-sticky
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "sticky" } " bit of a file to true or false." } ;
+
+HELP: sticky?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: set-uid
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "uid" } " bit of a file to true or false." } ;
+
+HELP: uid?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: set-user-execute
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "user execute" } " bit of a file to true or false." } ;
+
+HELP: set-user-read
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "user read" } " bit of a file to true or false." } ;
+
+HELP: set-user-write
+{ $values
+ { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "user write" } " bit of a file to true or false." } ;
+
+HELP: user-execute?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: user-read?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: user-write?
+{ $values
+ { "obj" "a pathname string, file-info object, or an integer" }
+ { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+ARTICLE: "unix-file-permissions" "Unix file permissions"
+"Reading all file permissions:"
+{ $subsection file-permissions }
+"Reading individual file permissions:"
+{ $subsection uid? }
+{ $subsection gid? }
+{ $subsection sticky? }
+{ $subsection user-read? }
+{ $subsection user-write? }
+{ $subsection user-execute? }
+{ $subsection group-read? }
+{ $subsection group-write? }
+{ $subsection group-execute? }
+{ $subsection other-read? }
+{ $subsection other-write? }
+{ $subsection other-execute? }
+"Writing all file permissions:"
+{ $subsection set-file-permissions }
+"Writing individual file permissions:"
+{ $subsection set-uid }
+{ $subsection set-gid }
+{ $subsection set-sticky }
+{ $subsection set-user-read }
+{ $subsection set-user-write }
+{ $subsection set-user-execute }
+{ $subsection set-group-read }
+{ $subsection set-group-write }
+{ $subsection set-group-execute }
+{ $subsection set-other-read }
+{ $subsection set-other-write }
+{ $subsection set-other-execute } ;
+
+ARTICLE: "unix-file-timestamps" "Unix file timestamps"
+"To read file times, use the accessors on the object returned by the " { $link file-info } " word." $nl
+"Setting multiple file times:"
+{ $subsection set-file-times }
+"Setting just the last access time:"
+{ $subsection set-file-access-time }
+"Setting just the last modified time:"
+{ $subsection set-file-modified-time } ;
+
+
+ARTICLE: "unix-file-ids" "Unix file user and group ids"
+"Reading file user data:"
+{ $subsection file-user-id }
+{ $subsection file-username }
+"Setting file user data:"
+{ $subsection set-file-user }
+"Reading file group data:"
+{ $subsection file-group-id }
+{ $subsection file-group-name }
+"Setting file group data:"
+{ $subsection set-file-group } ;
+
+
+ARTICLE: "io.files.info.unix" "Unix file attributes"
+"The " { $vocab-link "io.files.info.unix" } " vocabulary implements a high-level way to set Unix-specific permissions, timestamps, and user and group IDs for files."
+{ $subsection "unix-file-permissions" }
+{ $subsection "unix-file-timestamps" }
+{ $subsection "unix-file-ids" } ;
+
+ABOUT: "io.files.info.unix"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel system math math.bitwise strings arrays
+sequences combinators combinators.short-circuit alien.c-types
+vocabs.loader calendar calendar.unix io.files.info
+io.files.types io.backend unix unix.stat unix.time unix.users
+unix.groups ;
+IN: io.files.info.unix
+
+TUPLE: unix-file-system-info < file-system-info
+block-size preferred-block-size
+blocks blocks-free blocks-available
+files files-free files-available
+name-max flags id ;
+
+HOOK: new-file-system-info os ( -- file-system-info )
+
+M: unix new-file-system-info ( -- ) unix-file-system-info new ;
+
+HOOK: file-system-statfs os ( path -- statfs )
+
+M: unix file-system-statfs drop f ;
+
+HOOK: file-system-statvfs os ( path -- statvfs )
+
+M: unix file-system-statvfs drop f ;
+
+HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
+
+M: unix statfs>file-system-info drop ;
+
+HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
+
+M: unix statvfs>file-system-info drop ;
+
+: file-system-calculations ( file-system-info -- file-system-info' )
+ dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space
+ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space
+ dup [ blocks>> ] [ block-size>> ] bi * >>total-space
+ dup [ total-space>> ] [ free-space>> ] bi - >>used-space ;
+
+M: unix file-system-info
+ normalize-path
+ [ new-file-system-info ] dip
+ [ file-system-statfs statfs>file-system-info ]
+ [ file-system-statvfs statvfs>file-system-info ] bi
+ file-system-calculations ;
+
+TUPLE: unix-file-info < file-info uid gid dev ino
+nlink rdev blocks blocksize ;
+
+HOOK: new-file-info os ( -- file-info )
+
+HOOK: stat>file-info os ( stat -- file-info )
+
+HOOK: stat>type os ( stat -- file-info )
+
+M: unix file-info ( path -- info )
+ normalize-path file-status stat>file-info ;
+
+M: unix link-info ( path -- info )
+ normalize-path link-status stat>file-info ;
+
+M: unix new-file-info ( -- class ) unix-file-info new ;
+
+M: unix stat>file-info ( stat -- file-info )
+ [ new-file-info ] dip
+ {
+ [ stat>type >>type ]
+ [ stat-st_size >>size ]
+ [ stat-st_mode >>permissions ]
+ [ stat-st_ctimespec timespec>unix-time >>created ]
+ [ stat-st_mtimespec timespec>unix-time >>modified ]
+ [ stat-st_atimespec timespec>unix-time >>accessed ]
+ [ stat-st_uid >>uid ]
+ [ stat-st_gid >>gid ]
+ [ stat-st_dev >>dev ]
+ [ stat-st_ino >>ino ]
+ [ stat-st_nlink >>nlink ]
+ [ stat-st_rdev >>rdev ]
+ [ stat-st_blocks >>blocks ]
+ [ stat-st_blksize >>blocksize ]
+ } cleave ;
+
+: n>file-type ( n -- type )
+ S_IFMT bitand {
+ { S_IFREG [ +regular-file+ ] }
+ { S_IFDIR [ +directory+ ] }
+ { S_IFCHR [ +character-device+ ] }
+ { S_IFBLK [ +block-device+ ] }
+ { S_IFIFO [ +fifo+ ] }
+ { S_IFLNK [ +symbolic-link+ ] }
+ { S_IFSOCK [ +socket+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+M: unix stat>type ( stat -- type )
+ stat-st_mode n>file-type ;
+
+<PRIVATE
+
+: stat-mode ( path -- mode )
+ normalize-path file-status stat-st_mode ;
+
+: chmod-set-bit ( path mask ? -- )
+ [ dup stat-mode ] 2dip
+ [ bitor ] [ unmask ] if chmod io-error ;
+
+GENERIC# file-mode? 1 ( obj mask -- ? )
+
+M: integer file-mode? mask? ;
+M: string file-mode? [ stat-mode ] dip mask? ;
+M: file-info file-mode? [ permissions>> ] dip mask? ;
+
+PRIVATE>
+
+: ch>file-type ( ch -- type )
+ {
+ { CHAR: b [ +block-device+ ] }
+ { CHAR: c [ +character-device+ ] }
+ { CHAR: d [ +directory+ ] }
+ { CHAR: l [ +symbolic-link+ ] }
+ { CHAR: s [ +socket+ ] }
+ { CHAR: p [ +fifo+ ] }
+ { CHAR: - [ +regular-file+ ] }
+ [ drop +unknown+ ]
+ } case ;
+
+: file-type>ch ( type -- string )
+ {
+ { +block-device+ [ CHAR: b ] }
+ { +character-device+ [ CHAR: c ] }
+ { +directory+ [ CHAR: d ] }
+ { +symbolic-link+ [ CHAR: l ] }
+ { +socket+ [ CHAR: s ] }
+ { +fifo+ [ CHAR: p ] }
+ { +regular-file+ [ CHAR: - ] }
+ [ drop CHAR: - ]
+ } case ;
+
+: UID OCT: 0004000 ; inline
+: GID OCT: 0002000 ; inline
+: STICKY OCT: 0001000 ; inline
+: USER-ALL OCT: 0000700 ; inline
+: USER-READ OCT: 0000400 ; inline
+: USER-WRITE OCT: 0000200 ; inline
+: USER-EXECUTE OCT: 0000100 ; inline
+: GROUP-ALL OCT: 0000070 ; inline
+: GROUP-READ OCT: 0000040 ; inline
+: GROUP-WRITE OCT: 0000020 ; inline
+: GROUP-EXECUTE OCT: 0000010 ; inline
+: OTHER-ALL OCT: 0000007 ; inline
+: OTHER-READ OCT: 0000004 ; inline
+: OTHER-WRITE OCT: 0000002 ; inline
+: OTHER-EXECUTE OCT: 0000001 ; inline
+
+: uid? ( obj -- ? ) UID file-mode? ;
+: gid? ( obj -- ? ) GID file-mode? ;
+: sticky? ( obj -- ? ) STICKY file-mode? ;
+: user-read? ( obj -- ? ) USER-READ file-mode? ;
+: user-write? ( obj -- ? ) USER-WRITE file-mode? ;
+: user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
+: group-read? ( obj -- ? ) GROUP-READ file-mode? ;
+: group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
+: group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
+: other-read? ( obj -- ? ) OTHER-READ file-mode? ;
+: other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
+: other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
+
+: any-read? ( obj -- ? )
+ { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
+
+: any-write? ( obj -- ? )
+ { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
+
+: any-execute? ( obj -- ? )
+ { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
+
+: set-uid ( path ? -- ) UID swap chmod-set-bit ;
+: set-gid ( path ? -- ) GID swap chmod-set-bit ;
+: set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
+: set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
+: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
+: set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
+: set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
+: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
+: set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
+: set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
+: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
+: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
+
+: set-file-permissions ( path n -- )
+ [ normalize-path ] dip chmod io-error ;
+
+: file-permissions ( path -- n )
+ normalize-path file-info permissions>> ;
+
+<PRIVATE
+
+: make-timeval-array ( array -- byte-array )
+ [ [ "timeval" <c-object> ] unless* ] map concat ;
+
+: timestamp>timeval ( timestamp -- timeval )
+ unix-1970 time- duration>microseconds make-timeval ;
+
+: timestamps>byte-array ( timestamps -- byte-array )
+ [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
+
+PRIVATE>
+
+: set-file-times ( path timestamps -- )
+ #! set access, write
+ [ normalize-path ] dip
+ timestamps>byte-array utimes io-error ;
+
+: set-file-access-time ( path timestamp -- )
+ f 2array set-file-times ;
+
+: set-file-modified-time ( path timestamp -- )
+ f swap 2array set-file-times ;
+
+: set-file-ids ( path uid gid -- )
+ [ normalize-path ] 2dip
+ [ [ -1 ] unless* ] bi@ chown io-error ;
+
+GENERIC: set-file-user ( path string/id -- )
+
+GENERIC: set-file-group ( path string/id -- )
+
+M: integer set-file-user ( path uid -- )
+ f set-file-ids ;
+
+M: string set-file-user ( path string -- )
+ user-id f set-file-ids ;
+
+M: integer set-file-group ( path gid -- )
+ f swap set-file-ids ;
+
+M: string set-file-group ( path string -- )
+ group-id
+ f swap set-file-ids ;
+
+: file-user-id ( path -- uid )
+ normalize-path file-info uid>> ;
+
+: file-username ( path -- string )
+ file-user-id username ;
+
+: file-group-id ( path -- gid )
+ normalize-path file-info gid>> ;
+
+: file-group-name ( path -- string )
+ file-group-id group-name ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: byte-arrays math io.backend io.files.info
+io.files.windows io.files.windows.nt kernel windows.kernel32
+windows.time windows accessors alien.c-types combinators
+generalizations system alien.strings io.encodings.utf16n
+sequences splitting windows.errors fry continuations destructors
+calendar ascii combinators.short-circuit ;
+IN: io.files.info.windows
+
+TUPLE: windows-file-info < file-info attributes ;
+
+: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
+ [ \ windows-file-info new ] dip
+ {
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
+ [
+ [ WIN32_FIND_DATA-nFileSizeLow ]
+ [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
+ ]
+ [ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
+ [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
+ [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
+ [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
+ } cleave ;
+
+: find-first-file-stat ( path -- WIN32_FIND_DATA )
+ "WIN32_FIND_DATA" <c-object> [
+ FindFirstFile
+ [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
+ FindClose win32-error=0/f
+ ] keep ;
+
+: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
+ [ \ windows-file-info new ] dip
+ {
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
+ [
+ [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
+ [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
+ ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
+ [
+ BY_HANDLE_FILE_INFORMATION-ftCreationTime
+ FILETIME>timestamp >>created
+ ]
+ [
+ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
+ FILETIME>timestamp >>modified
+ ]
+ [
+ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
+ FILETIME>timestamp >>accessed
+ ]
+ ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
+ ! [
+ ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
+ ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
+ ! ]
+ } cleave ;
+
+: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
+ [
+ "BY_HANDLE_FILE_INFORMATION" <c-object>
+ [ GetFileInformationByHandle win32-error=0/f ] keep
+ ] keep CloseHandle win32-error=0/f ;
+
+: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
+ dup
+ GENERIC_READ FILE_SHARE_READ f
+ OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
+ CreateFileW dup INVALID_HANDLE_VALUE = [
+ drop find-first-file-stat WIN32_FIND_DATA>file-info
+ ] [
+ nip
+ get-file-information BY_HANDLE_FILE_INFORMATION>file-info
+ ] if ;
+
+M: windows file-info ( path -- info )
+ normalize-path get-file-information-stat ;
+
+M: windows link-info ( path -- info )
+ file-info ;
+
+: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
+ MAX_PATH 1+ [ <byte-array> ] keep
+ "DWORD" <c-object>
+ "DWORD" <c-object>
+ "DWORD" <c-object>
+ MAX_PATH 1+ [ <byte-array> ] keep
+ [ GetVolumeInformation win32-error=0/f ] 7 nkeep
+ drop 5 nrot drop
+ [ utf16n alien>string ] 4 ndip
+ utf16n alien>string ;
+
+: file-system-space ( normalized-path -- available-space total-space free-space )
+ "ULARGE_INTEGER" <c-object>
+ "ULARGE_INTEGER" <c-object>
+ "ULARGE_INTEGER" <c-object>
+ [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
+
+: calculate-file-system-info ( file-system-info -- file-system-info' )
+ {
+ [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
+ [ ]
+ } cleave ;
+
+TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;
+
+ERROR: not-absolute-path ;
+
+: root-directory ( string -- string' )
+ unicode-prefix ?head drop
+ dup {
+ [ length 2 >= ]
+ [ second CHAR: : = ]
+ [ first Letter? ]
+ } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
+
+M: winnt file-system-info ( path -- file-system-info )
+ normalize-path root-directory
+ dup [ volume-information ] [ file-system-space ] bi
+ \ win32-file-system-info new
+ swap *ulonglong >>free-space
+ swap *ulonglong >>total-space
+ swap *ulonglong >>available-space
+ swap >>type
+ swap *uint >>flags
+ swap *uint >>max-component
+ swap *uint >>device-serial
+ swap >>device-name
+ swap >>mount-point
+ calculate-file-system-info ;
+
+: volume>paths ( string -- array )
+ 16384 "ushort" <c-array> tuck dup length
+ 0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
+ win32-error-string throw
+ ] [
+ *uint "ushort" heap-size * head
+ utf16n alien>string CHAR: \0 split
+ ] if ;
+
+: find-first-volume ( -- string handle )
+ MAX_PATH 1+ [ <byte-array> ] keep
+ dupd
+ FindFirstVolume dup win32-error=0/f
+ [ utf16n alien>string ] dip ;
+
+: find-next-volume ( handle -- string/f )
+ MAX_PATH 1+ [ <byte-array> tuck ] keep
+ FindNextVolume 0 = [
+ GetLastError ERROR_NO_MORE_FILES =
+ [ drop f ] [ win32-error-string throw ] if
+ ] [
+ utf16n alien>string
+ ] if ;
+
+: find-volumes ( -- array )
+ find-first-volume
+ [
+ '[
+ [ _ find-next-volume dup ]
+ [ ]
+ [ drop ] produce
+ swap prefix
+ ]
+ ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
+
+M: winnt file-systems ( -- array )
+ find-volumes [ volume>paths ] map
+ concat [
+ [ file-system-info ]
+ [ drop \ file-system-info new swap >>mount-point ] recover
+ ] map ;
+
+: file-times ( path -- timestamp timestamp timestamp )
+ [
+ normalize-path open-existing &dispose handle>>
+ "FILETIME" <c-object>
+ "FILETIME" <c-object>
+ "FILETIME" <c-object>
+ [ GetFileTime win32-error=0/f ] 3keep
+ [ FILETIME>timestamp >local-time ] tri@
+ ] with-destructors ;
+
+: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
+ #! timestamp order: creation access write
+ [
+ [
+ normalize-path open-existing &dispose handle>>
+ ] 3dip (set-file-times)
+ ] with-destructors ;
+
+: set-file-create-time ( path timestamp -- )
+ f f set-file-times ;
+
+: set-file-access-time ( path timestamp -- )
+ [ f ] dip f set-file-times ;
+
+: set-file-write-time ( path timestamp -- )
+ [ f f ] dip set-file-times ;
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax io.files.info ;
+IN: io.files.links
+
+HELP: make-link
+{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
+{ $description "Creates a symbolic link." } ;
+
+HELP: read-link
+{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
+{ $description "Reads the symbolic link and returns its target path." } ;
+
+HELP: copy-link
+{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
+{ $description "Copies a symbolic link without following the link." } ;
+
+{ make-link read-link copy-link } related-words
+
+ARTICLE: "io.files.links" "Symbolic links"
+"Reading and creating links:"
+{ $subsection read-link }
+{ $subsection make-link }
+"Copying links:"
+{ $subsection copy-link }
+"Not all operating systems support symbolic links."
+{ $see-also link-info } ;
+
+ABOUT: "io.files.links"
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system kernel vocabs.loader ;
+IN: io.files.links
+
+HOOK: make-link os ( target symlink -- )
+
+HOOK: read-link os ( symlink -- path )
+
+: copy-link ( target symlink -- )
+ [ read-link ] dip make-link ;
+
+os unix? [ "io.files.links.unix" require ] when
\ No newline at end of file
--- /dev/null
+Working with symbolic links
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend io.files.links system unix ;
+IN: io.files.links.unix
+
+M: unix make-link ( path1 path2 -- )
+ normalize-path symlink io-error ;
+
+M: unix read-link ( path -- path' )
+ normalize-path read-symbolic-link ;
--- /dev/null
+USING: help.markup help.syntax ;
+IN: io.files.temp
+
+ARTICLE: "io.files.temp" "Temporary files"
+"Pathnames relative to Factor's temporary files directory:"
+{ $subsection temp-directory }
+{ $subsection temp-file } ;
+
+ABOUT: "io.files.temp"
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io.pathnames io.directories ;
+IN: io.files.temp
+
+: temp-directory ( -- path )
+ "temp" resource-path dup make-directories ;
+
+: temp-file ( name -- path )
+ temp-directory prepend-path ;
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax ;
+IN: io.files.types
+
+HELP: +regular-file+
+{ $description "A regular file. This type exists on all platforms. See " { $link "io.files" } " for words operating on files." } ;
+
+HELP: +directory+
+{ $description "A directory. This type exists on all platforms. See " { $link "io.directories" } " for words operating on directories." } ;
+
+HELP: +symbolic-link+
+{ $description "A symbolic link file. This type is currently implemented on Unix platforms only. See " { $link "io.files.links" } " for words operating on symbolic links." } ;
+
+HELP: +character-device+
+{ $description "A Unix character device file. This type exists on Unix platforms only." } ;
+
+HELP: +block-device+
+{ $description "A Unix block device file. This type exists on Unix platforms only." } ;
+
+HELP: +fifo+
+{ $description "A Unix fifo file. This type exists on Unix platforms only." } ;
+
+HELP: +socket+
+{ $description "A Unix socket file. This type exists on Unix platforms only." } ;
+
+HELP: +unknown+
+{ $description "A unknown file type." } ;
+
+ARTICLE: "file-types" "File types"
+"Platform-independent types:"
+{ $subsection +regular-file+ }
+{ $subsection +directory+ }
+"Platform-specific types:"
+{ $subsection +character-device+ }
+{ $subsection +block-device+ }
+{ $subsection +fifo+ }
+{ $subsection +symbolic-link+ }
+{ $subsection +socket+ }
+{ $subsection +unknown+ } ;
+
+ABOUT: "file-types"
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: io.files.types
+
+SYMBOL: +regular-file+
+SYMBOL: +directory+
+SYMBOL: +symbolic-link+
+SYMBOL: +character-device+
+SYMBOL: +block-device+
+SYMBOL: +fifo+
+SYMBOL: +socket+
+SYMBOL: +whiteout+
+SYMBOL: +unknown+
USING: help.markup help.syntax io io.ports kernel math
-io.files.unique.private math.parser io.files ;
+io.pathnames io.directories math.parser io.files ;
IN: io.files.unique
HELP: temporary-path
USING: io.encodings.ascii sequences strings io io.files accessors
-tools.test kernel io.files.unique namespaces continuations ;
+tools.test kernel io.files.unique namespaces continuations
+io.files.info io.pathnames ;
IN: io.files.unique.tests
[ 123 ] [
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.bitwise math.parser random sequences
-continuations namespaces io.files io arrays system
-combinators vocabs.loader fry io.backend ;
+USING: arrays combinators continuations fry io io.backend
+io.directories io.directories.hierarchy io.files io.pathnames
+kernel math math.bitwise math.parser namespaces random
+sequences system vocabs.loader ;
IN: io.files.unique
HOOK: touch-unique-file io-backend ( path -- )
'[ _ with-directory ] [ delete-tree ] bi ; inline
{
- { [ os unix? ] [ "io.unix.files.unique" ] }
- { [ os windows? ] [ "io.windows.files.unique" ] }
+ { [ os unix? ] [ "io.files.unique.unix" ] }
+ { [ os windows? ] [ "io.files.unique.windows" ] }
} cond require
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io.ports io.backend.unix math.bitwise
+unix system io.files.unique ;
+IN: io.files.unique.unix
+
+: open-unique-flags ( -- flags )
+ { O_RDWR O_CREAT O_EXCL } flags ;
+
+M: unix touch-unique-file ( path -- )
+ open-unique-flags file-mode open-file close-file ;
+
+M: unix temporary-path ( -- path ) "/tmp" ;
--- /dev/null
+unportable
--- /dev/null
+USING: kernel system windows.kernel32 io.backend.windows
+io.files.windows io.ports windows destructors environment
+io.files.unique ;
+IN: io.files.unique.windows
+
+M: windows touch-unique-file ( path -- )
+ GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
+
+M: windows temporary-path ( -- path )
+ "TEMP" os-env ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Implementation of reading and writing files on Unix-like systems
--- /dev/null
+unportable
--- /dev/null
+USING: tools.test io.files io.files.temp io.pathnames
+io.directories io.files.info io.files.info.unix continuations
+kernel io.files.unix math.bitwise calendar accessors
+math.functions math unix.users unix.groups arrays sequences ;
+IN: io.files.unix.tests
+
+[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
+[ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test
+[ "/" ] [ "/etc/" parent-directory ] unit-test
+[ "/" ] [ "/etc" parent-directory ] unit-test
+[ "/" ] [ "/" parent-directory ] unit-test
+
+[ f ] [ "" root-directory? ] unit-test
+[ t ] [ "/" root-directory? ] unit-test
+[ t ] [ "//" root-directory? ] unit-test
+[ t ] [ "///////" root-directory? ] unit-test
+
+[ "/" ] [ "/" file-name ] unit-test
+[ "///" ] [ "///" file-name ] unit-test
+
+[ "/" ] [ "/" "../.." append-path ] unit-test
+[ "/" ] [ "/" "../../" append-path ] unit-test
+[ "/lib" ] [ "/" "../lib" append-path ] unit-test
+[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
+[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
+[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
+
+[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
+[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
+[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
+[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
+[ t ] [ "/foo" absolute-path? ] unit-test
+
+: test-file ( -- path )
+ "permissions" temp-file ;
+
+: prepare-test-file ( -- )
+ [ test-file delete-file ] ignore-errors
+ test-file touch-file ;
+
+: perms ( -- n )
+ test-file file-permissions OCT: 7777 mask ;
+
+prepare-test-file
+
+[ t ]
+[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test
+
+[ t ] [ test-file user-read? ] unit-test
+[ t ] [ test-file user-write? ] unit-test
+[ t ] [ test-file user-execute? ] unit-test
+[ t ] [ test-file group-read? ] unit-test
+[ t ] [ test-file group-write? ] unit-test
+[ t ] [ test-file group-execute? ] unit-test
+[ t ] [ test-file other-read? ] unit-test
+[ t ] [ test-file other-write? ] unit-test
+[ t ] [ test-file other-execute? ] unit-test
+
+[ t ] [ test-file f set-other-execute perms OCT: 776 = ] unit-test
+[ f ] [ test-file file-info other-execute? ] unit-test
+
+[ t ] [ test-file f set-other-write perms OCT: 774 = ] unit-test
+[ f ] [ test-file file-info other-write? ] unit-test
+
+[ t ] [ test-file f set-other-read perms OCT: 770 = ] unit-test
+[ f ] [ test-file file-info other-read? ] unit-test
+
+[ t ] [ test-file f set-group-execute perms OCT: 760 = ] unit-test
+[ f ] [ test-file file-info group-execute? ] unit-test
+
+[ t ] [ test-file f set-group-write perms OCT: 740 = ] unit-test
+[ f ] [ test-file file-info group-write? ] unit-test
+
+[ t ] [ test-file f set-group-read perms OCT: 700 = ] unit-test
+[ f ] [ test-file file-info group-read? ] unit-test
+
+[ t ] [ test-file f set-user-execute perms OCT: 600 = ] unit-test
+[ f ] [ test-file file-info other-execute? ] unit-test
+
+[ t ] [ test-file f set-user-write perms OCT: 400 = ] unit-test
+[ f ] [ test-file file-info other-write? ] unit-test
+
+[ t ] [ test-file f set-user-read perms OCT: 000 = ] unit-test
+[ f ] [ test-file file-info other-read? ] unit-test
+
+[ t ]
+[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
+
+prepare-test-file
+
+[ t ]
+[
+ test-file now
+ [ set-file-access-time ] 2keep
+ [ file-info accessed>> ]
+ [ [ [ truncate >integer ] change-second ] bi@ ] bi* =
+] unit-test
+
+[ t ]
+[
+ test-file now
+ [ set-file-modified-time ] 2keep
+ [ file-info modified>> ]
+ [ [ [ truncate >integer ] change-second ] bi@ ] bi* =
+] unit-test
+
+[ t ]
+[
+ test-file now [ dup 2array set-file-times ] 2keep
+ [ file-info [ modified>> ] [ accessed>> ] bi ] dip
+ 3array
+ [ [ truncate >integer ] change-second ] map all-equal?
+] unit-test
+
+[ ] [ test-file f now 2array set-file-times ] unit-test
+[ ] [ test-file now f 2array set-file-times ] unit-test
+[ ] [ test-file f f 2array set-file-times ] unit-test
+
+
+[ ] [ test-file real-username set-file-user ] unit-test
+[ ] [ test-file real-user-id set-file-user ] unit-test
+[ ] [ test-file real-group-name set-file-group ] unit-test
+[ ] [ test-file real-group-id set-file-group ] unit-test
+
+[ t ] [ test-file file-username real-username = ] unit-test
+[ t ] [ test-file file-group-name real-group-name = ] unit-test
+
+[ ]
+[ test-file real-user-id real-group-id set-file-ids ] unit-test
+
+[ ]
+[ test-file f real-group-id set-file-ids ] unit-test
+
+[ ]
+[ test-file real-user-id f set-file-ids ] unit-test
+
+[ ]
+[ test-file f f set-file-ids ] unit-test
+
+[ t ] [ OCT: 4000 uid? ] unit-test
+[ t ] [ OCT: 2000 gid? ] unit-test
+[ t ] [ OCT: 1000 sticky? ] unit-test
+[ t ] [ OCT: 400 user-read? ] unit-test
+[ t ] [ OCT: 200 user-write? ] unit-test
+[ t ] [ OCT: 100 user-execute? ] unit-test
+[ t ] [ OCT: 040 group-read? ] unit-test
+[ t ] [ OCT: 020 group-write? ] unit-test
+[ t ] [ OCT: 010 group-execute? ] unit-test
+[ t ] [ OCT: 004 other-read? ] unit-test
+[ t ] [ OCT: 002 other-write? ] unit-test
+[ t ] [ OCT: 001 other-execute? ] unit-test
+
+[ f ] [ 0 uid? ] unit-test
+[ f ] [ 0 gid? ] unit-test
+[ f ] [ 0 sticky? ] unit-test
+[ f ] [ 0 user-read? ] unit-test
+[ f ] [ 0 user-write? ] unit-test
+[ f ] [ 0 user-execute? ] unit-test
+[ f ] [ 0 group-read? ] unit-test
+[ f ] [ 0 group-write? ] unit-test
+[ f ] [ 0 group-execute? ] unit-test
+[ f ] [ 0 other-read? ] unit-test
+[ f ] [ 0 other-write? ] unit-test
+[ f ] [ 0 other-execute? ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: unix byte-arrays kernel io.backend.unix math.bitwise
+io.ports io.files io.files.private io.pathnames environment
+destructors system ;
+IN: io.files.unix
+
+M: unix cwd ( -- path )
+ MAXPATHLEN [ <byte-array> ] keep getcwd
+ [ (io-error) ] unless* ;
+
+M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
+
+: read-flags ( -- n ) O_RDONLY ; inline
+
+: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
+
+M: unix (file-reader) ( path -- stream )
+ open-read <fd> init-fd <input-port> ;
+
+: write-flags ( -- n )
+ { O_WRONLY O_CREAT O_TRUNC } flags ; inline
+
+: open-write ( path -- fd )
+ write-flags file-mode open-file ;
+
+M: unix (file-writer) ( path -- stream )
+ open-write <fd> init-fd <output-port> ;
+
+: append-flags ( -- n )
+ { O_WRONLY O_APPEND O_CREAT } flags ; inline
+
+: open-append ( path -- fd )
+ [
+ append-flags file-mode open-file |dispose
+ dup 0 SEEK_END lseek io-error
+ ] with-destructors ;
+
+M: unix (file-appender) ( path -- stream )
+ open-append <fd> init-fd <output-port> ;
+
+M: unix home "HOME" os-env ;
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
--- /dev/null
+USING: io.files io.pathnames kernel tools.test io.backend
+io.files.windows.nt splitting sequences ;
+IN: io.files.windows.nt.tests
+
+[ f ] [ "\\foo" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test
+[ t ] [ "c:\\foo" absolute-path? ] unit-test
+[ t ] [ "c:" absolute-path? ] unit-test
+[ t ] [ "c:\\" absolute-path? ] unit-test
+[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test
+
+[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
+[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
+[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
+! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
+[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
+[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
+[ "c:" ] [ "c:" parent-directory ] unit-test
+[ "Z:" ] [ "Z:" parent-directory ] unit-test
+
+[ f ] [ "" root-directory? ] unit-test
+[ t ] [ "\\" root-directory? ] unit-test
+[ t ] [ "\\\\" root-directory? ] unit-test
+[ t ] [ "/" root-directory? ] unit-test
+[ t ] [ "//" root-directory? ] unit-test
+[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test
+[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test
+[ f ] [ "c:\\foo" root-directory? ] unit-test
+[ f ] [ "." root-directory? ] unit-test
+[ f ] [ ".." root-directory? ] unit-test
+[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test
+[ t ] [ "\\\\?\\c:" root-directory? ] unit-test
+[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test
+
+[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
+
+[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\log.txt" append-path normalize-path
+] unit-test
+
+[ "\\\\?\\C:\\builds\\" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\.." append-path normalize-path
+] unit-test
+
+[ "\\\\?\\C:\\builds\\" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\.." append-path normalize-path
+] unit-test
+
+[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
+[ t ] [ "" resource-path 2 tail exists? ] unit-test
--- /dev/null
+USING: continuations destructors io.buffers io.files io.backend
+io.timeouts io.ports io.pathnames io.files.private
+io.backend.windows io.files.windows io.encodings.utf16n windows
+windows.kernel32 kernel libc math threads system environment
+alien.c-types alien.arrays alien.strings sequences combinators
+combinators.short-circuit ascii splitting alien strings assocs
+namespaces make accessors tr windows.time ;
+IN: io.files.windows.nt
+
+M: winnt cwd
+ MAX_UNICODE_PATH dup "ushort" <c-array>
+ [ GetCurrentDirectory win32-error=0/f ] keep
+ utf16n alien>string ;
+
+M: winnt cd
+ SetCurrentDirectory win32-error=0/f ;
+
+: unicode-prefix ( -- seq )
+ "\\\\?\\" ; inline
+
+M: winnt root-directory? ( path -- ? )
+ {
+ { [ dup empty? ] [ drop f ] }
+ { [ dup [ path-separator? ] all? ] [ drop t ] }
+ { [ dup trim-right-separators { [ length 2 = ]
+ [ second CHAR: : = ] } 1&& ] [ drop t ] }
+ { [ dup unicode-prefix head? ]
+ [ trim-right-separators length unicode-prefix length 2 + = ] }
+ [ drop f ]
+ } cond ;
+
+: prepend-prefix ( string -- string' )
+ dup unicode-prefix head? [
+ unicode-prefix prepend
+ ] unless ;
+
+TR: normalize-separators "/" "\\" ;
+
+M: winnt normalize-path ( string -- string' )
+ (normalize-path)
+ normalize-separators
+ prepend-prefix ;
+
+M: winnt CreateFile-flags ( DWORD -- DWORD )
+ FILE_FLAG_OVERLAPPED bitor ;
+
+<PRIVATE
+
+: windows-file-size ( path -- size )
+ normalize-path 0 "WIN32_FILE_ATTRIBUTE_DATA" <c-object>
+ [ GetFileAttributesEx win32-error=0/f ] keep
+ [ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeLow ]
+ [ WIN32_FILE_ATTRIBUTE_DATA-nFileSizeHigh ] bi >64bit ;
+
+PRIVATE>
+
+M: winnt open-append
+ [ dup windows-file-size ] [ drop 0 ] recover
+ [ (open-append) ] dip >>ptr ;
+
+M: winnt home "USERPROFILE" os-env ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types io.binary io.backend io.files
+io.files.types io.buffers io.encodings.utf16n io.ports
+io.backend.windows kernel math splitting fry alien.strings
+windows windows.kernel32 windows.time calendar combinators
+math.functions sequences namespaces make words system
+destructors accessors math.bitwise continuations windows.errors
+arrays byte-arrays generalizations ;
+IN: io.files.windows
+
+: open-file ( path access-mode create-mode flags -- handle )
+ [
+ [ share-mode default-security-attributes ] 2dip
+ CreateFile-flags f CreateFile opened-file
+ ] with-destructors ;
+
+: open-pipe-r/w ( path -- win32-file )
+ { GENERIC_READ GENERIC_WRITE } flags
+ OPEN_EXISTING 0 open-file ;
+
+: open-read ( path -- win32-file )
+ GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
+
+: open-write ( path -- win32-file )
+ GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
+
+: (open-append) ( path -- win32-file )
+ GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
+
+: open-existing ( path -- win32-file )
+ { GENERIC_READ GENERIC_WRITE } flags
+ share-mode
+ f
+ OPEN_EXISTING
+ FILE_FLAG_BACKUP_SEMANTICS
+ f CreateFileW dup win32-error=0/f <win32-file> ;
+
+: maybe-create-file ( path -- win32-file ? )
+ #! return true if file was just created
+ { GENERIC_READ GENERIC_WRITE } flags
+ share-mode
+ f
+ OPEN_ALWAYS
+ 0 CreateFile-flags
+ f CreateFileW dup win32-error=0/f <win32-file>
+ GetLastError ERROR_ALREADY_EXISTS = not ;
+
+: set-file-pointer ( handle length method -- )
+ [ dupd d>w/w <uint> ] dip SetFilePointer
+ INVALID_SET_FILE_POINTER = [
+ CloseHandle "SetFilePointer failed" throw
+ ] when drop ;
+
+HOOK: open-append os ( path -- win32-file )
+
+TUPLE: FileArgs
+ hFile lpBuffer nNumberOfBytesToRead
+ lpNumberOfBytesRet lpOverlapped ;
+
+C: <FileArgs> FileArgs
+
+: make-FileArgs ( port -- <FileArgs> )
+ {
+ [ handle>> check-disposed ]
+ [ handle>> handle>> ]
+ [ buffer>> ]
+ [ buffer>> buffer-length ]
+ [ drop "DWORD" <c-object> ]
+ [ FileArgs-overlapped ]
+ } cleave <FileArgs> ;
+
+: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
+ {
+ [ hFile>> ]
+ [ lpBuffer>> buffer-end ]
+ [ lpBuffer>> buffer-capacity ]
+ [ lpNumberOfBytesRet>> ]
+ [ lpOverlapped>> ]
+ } cleave ;
+
+: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
+ {
+ [ hFile>> ]
+ [ lpBuffer>> buffer@ ]
+ [ lpBuffer>> buffer-length ]
+ [ lpNumberOfBytesRet>> ]
+ [ lpOverlapped>> ]
+ } cleave ;
+
+M: windows (file-reader) ( path -- stream )
+ open-read <input-port> ;
+
+M: windows (file-writer) ( path -- stream )
+ open-write <output-port> ;
+
+M: windows (file-appender) ( path -- stream )
+ open-append <output-port> ;
+
+SYMBOLS: +read-only+ +hidden+ +system+
++archive+ +device+ +normal+ +temporary+
++sparse-file+ +reparse-point+ +compressed+ +offline+
++not-content-indexed+ +encrypted+ ;
+
+: win32-file-attribute ( n attr symbol -- )
+ rot mask? [ , ] [ drop ] if ;
+
+: win32-file-attributes ( n -- seq )
+ [
+ {
+ [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
+ [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
+ [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
+ [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
+ [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
+ [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
+ [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
+ [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
+ [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
+ [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
+ [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
+ [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
+ [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
+ [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
+ } cleave
+ ] { } make ;
+
+: win32-file-type ( n -- symbol )
+ FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
+
+: (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
+ [ timestamp>FILETIME ] tri@
+ SetFileTime win32-error=0/f ;
drop ;
{
- { [ os unix? ] [ "io.unix.launcher" require ] }
- { [ os winnt? ] [ "io.windows.nt.launcher" require ] }
- { [ os wince? ] [ "io.windows.launcher" require ] }
+ { [ os unix? ] [ "io.launcher.unix" require ] }
+ { [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ]
} cond
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: io.launcher.unix.parser.tests
+USING: io.launcher.unix.parser tools.test ;
+
+[ "" tokenize-command ] must-fail
+[ " " tokenize-command ] must-fail
+[ V{ "a" } ] [ "a" tokenize-command ] unit-test
+[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test
+[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test
+[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test
+[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
+[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
+[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
+[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
+[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
+[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
+[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
+[ "'abc def' \"hey" tokenize-command ] must-fail
+[ "'abc def" tokenize-command ] must-fail
+[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
+
+[
+ V{
+ "Hello world.app/Contents/MacOS/hello-ui"
+ "-i=boot.macosx-ppc.image"
+ "-include= math compiler ui"
+ "-deploy-vocab=hello-ui"
+ "-output-image=Hello world.app/Contents/Resources/hello-ui.image"
+ "-no-stack-traces"
+ "-no-user-init"
+ }
+] [
+ "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: peg peg.parsers kernel sequences strings words ;
+IN: io.launcher.unix.parser
+
+! Our command line parser. Supported syntax:
+! foo bar baz -- simple tokens
+! foo\ bar -- escaping the space
+! 'foo bar' -- quotation
+! "foo bar" -- quotation
+: 'escaped-char' ( -- parser )
+ "\\" token any-char 2seq [ second ] action ;
+
+: 'quoted-char' ( delimiter -- parser' )
+ 'escaped-char'
+ swap [ member? not ] curry satisfy
+ 2choice ; inline
+
+: 'quoted' ( delimiter -- parser )
+ dup 'quoted-char' repeat0 swap dup surrounded-by ;
+
+: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
+
+: 'argument' ( -- parser )
+ "\"" 'quoted'
+ "'" 'quoted'
+ 'unquoted' 3choice
+ [ >string ] action ;
+
+PEG: tokenize-command ( command -- ast/f )
+ 'argument' " " token repeat1 list-of
+ " " token repeat0 tuck pack
+ just ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+IN: io.launcher.unix.tests
+USING: io.files io.files.temp io.directories io.pathnames
+tools.test io.launcher arrays io namespaces continuations math
+io.encodings.binary io.encodings.ascii accessors kernel
+sequences io.encodings.utf8 destructors io.streams.duplex locals
+concurrency.promises threads unix.process ;
+
+[ ] [
+ [ "launcher-test-1" temp-file delete-file ] ignore-errors
+] unit-test
+
+[ ] [
+ "touch"
+ "launcher-test-1" temp-file
+ 2array
+ try-process
+] unit-test
+
+[ t ] [ "launcher-test-1" temp-file exists? ] unit-test
+
+[ ] [
+ [ "launcher-test-1" temp-file delete-file ] ignore-errors
+] unit-test
+
+[ ] [
+ <process>
+ "echo Hello" >>command
+ "launcher-test-1" temp-file >>stdout
+ try-process
+] unit-test
+
+[ "Hello\n" ] [
+ "cat"
+ "launcher-test-1" temp-file
+ 2array
+ ascii <process-reader> contents
+] unit-test
+
+[ ] [
+ [ "launcher-test-1" temp-file delete-file ] ignore-errors
+] unit-test
+
+[ ] [
+ <process>
+ "cat" >>command
+ +closed+ >>stdin
+ "launcher-test-1" temp-file >>stdout
+ try-process
+] unit-test
+
+[ f ] [
+ "cat"
+ "launcher-test-1" temp-file
+ 2array
+ ascii <process-reader> contents
+] unit-test
+
+[ ] [
+ 2 [
+ "launcher-test-1" temp-file binary <file-appender> [
+ <process>
+ swap >>stdout
+ "echo Hello" >>command
+ try-process
+ ] with-disposal
+ ] times
+] unit-test
+
+[ "Hello\nHello\n" ] [
+ "cat"
+ "launcher-test-1" temp-file
+ 2array
+ ascii <process-reader> contents
+] unit-test
+
+[ t ] [
+ <process>
+ "env" >>command
+ { { "A" "B" } } >>environment
+ ascii <process-reader> lines
+ "A=B" swap member?
+] unit-test
+
+[ { "A=B" } ] [
+ <process>
+ "env" >>command
+ { { "A" "B" } } >>environment
+ +replace-environment+ >>environment-mode
+ ascii <process-reader> lines
+] unit-test
+
+[ "hi\n" ] [
+ temp-directory [
+ [ "aloha" delete-file ] ignore-errors
+ <process>
+ { "echo" "hi" } >>command
+ "aloha" >>stdout
+ try-process
+ ] with-directory
+ temp-directory "aloha" append-path
+ utf8 file-contents
+] unit-test
+
+[ "append-test" temp-file delete-file ] ignore-errors
+
+[ "hi\nhi\n" ] [
+ 2 [
+ <process>
+ "echo hi" >>command
+ "append-test" temp-file <appender> >>stdout
+ try-process
+ ] times
+ "append-test" temp-file utf8 file-contents
+] unit-test
+
+[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
+
+[ "Hello world.\n" ] [
+ "cat" utf8 <process-stream> [
+ "Hello world.\n" write
+ output-stream get dispose
+ input-stream get contents
+ ] with-stream
+] unit-test
+
+! Killed processes were exiting with code 0 on FreeBSD
+[ f ] [
+ [let | p [ <promise> ]
+ s [ <promise> ] |
+ [
+ "sleep 1000" run-detached
+ [ p fulfill ] [ wait-for-process s fulfill ] bi
+ ] in-thread
+
+ p ?promise handle>> 9 kill drop
+ s ?promise 0 =
+ ]
+] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays assocs combinators
+continuations environment io io.backend io.backend.unix
+io.files io.files.private io.files.unix io.launcher
+io.launcher.unix.parser io.pathnames io.ports kernel math
+namespaces sequences strings system threads unix unix
+unix.process ;
+IN: io.launcher.unix
+
+! Search unix first
+USE: unix
+
+: get-arguments ( process -- seq )
+ command>> dup string? [ tokenize-command ] when ;
+
+: assoc>env ( assoc -- env )
+ [ "=" glue ] { } assoc>map ;
+
+: setup-priority ( process -- process )
+ dup priority>> [
+ H{
+ { +lowest-priority+ 20 }
+ { +low-priority+ 10 }
+ { +normal-priority+ 0 }
+ { +high-priority+ -10 }
+ { +highest-priority+ -20 }
+ { +realtime-priority+ -20 }
+ } at set-priority
+ ] when* ;
+
+: reset-fd ( fd -- )
+ [ F_SETFL 0 fcntl io-error ] [ F_SETFD 0 fcntl io-error ] bi ;
+
+: redirect-fd ( oldfd fd -- )
+ 2dup = [ 2drop ] [ dup2 io-error ] if ;
+
+: redirect-file ( obj mode fd -- )
+ [ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ;
+
+: redirect-file-append ( obj mode fd -- )
+ [ drop path>> normalize-path open-append ] dip redirect-fd ;
+
+: redirect-closed ( obj mode fd -- )
+ [ drop "/dev/null" ] 2dip redirect-file ;
+
+: redirect ( obj mode fd -- )
+ {
+ { [ pick not ] [ 3drop ] }
+ { [ pick string? ] [ redirect-file ] }
+ { [ pick appender? ] [ redirect-file-append ] }
+ { [ pick +closed+ eq? ] [ redirect-closed ] }
+ { [ pick fd? ] [ [ drop fd>> dup reset-fd ] dip redirect-fd ] }
+ [ [ underlying-handle ] 2dip redirect ]
+ } cond ;
+
+: ?closed ( obj -- obj' )
+ dup +closed+ eq? [ drop "/dev/null" ] when ;
+
+: setup-redirection ( process -- process )
+ dup stdin>> ?closed read-flags 0 redirect
+ dup stdout>> ?closed write-flags 1 redirect
+ dup stderr>> dup +stdout+ eq? [
+ drop 1 2 dup2 io-error
+ ] [
+ ?closed write-flags 2 redirect
+ ] if ;
+
+: setup-environment ( process -- process )
+ dup pass-environment? [
+ dup get-environment set-os-envs
+ ] when ;
+
+: spawn-process ( process -- * )
+ [ setup-priority ] [ 250 _exit ] recover
+ [ setup-redirection ] [ 251 _exit ] recover
+ [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover
+ [ setup-environment ] [ 253 _exit ] recover
+ [ get-arguments exec-args-with-path ] [ 254 _exit ] recover
+ 255 _exit ;
+
+M: unix current-process-handle ( -- handle ) getpid ;
+
+M: unix run-process* ( process -- pid )
+ [ spawn-process ] curry [ ] with-fork ;
+
+M: unix kill-process* ( pid -- )
+ SIGTERM kill io-error ;
+
+: find-process ( handle -- process )
+ processes get swap [ nip swap handle>> = ] curry
+ assoc-find 2drop ;
+
+TUPLE: signal n ;
+
+: code>status ( code -- obj )
+ dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
+
+M: unix wait-for-processes ( -- ? )
+ -1 0 <int> tuck WNOHANG waitpid
+ dup 0 <= [
+ 2drop t
+ ] [
+ find-process dup
+ [ swap *int code>status notify-exit f ] [ 2drop f ] if
+ ] if ;
--- /dev/null
+Doug Coleman
+Slava Pestov
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
--- /dev/null
+USING: io.launcher tools.test calendar accessors environment
+namespaces kernel system arrays io io.files io.encodings.ascii
+sequences parser assocs hashtables math continuations eval
+io.files.temp io.directories io.pathnames ;
+IN: io.launcher.windows.nt.tests
+
+[ ] [
+ <process>
+ "notepad" >>command
+ 1/2 seconds >>timeout
+ "notepad" set
+] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ f ] [ "notepad" get process-started? ] unit-test
+
+[ ] [ "notepad" [ run-detached ] change ] unit-test
+
+[ "notepad" get wait-for-process ] must-fail
+
+[ t ] [ "notepad" get killed>> ] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ ] [
+ <process>
+ vm "-quiet" "-run=hello-world" 3array >>command
+ "out.txt" temp-file >>stdout
+ try-process
+] unit-test
+
+[ "Hello world" ] [
+ "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+ <process>
+ vm "-run=listener" 2array >>command
+ +closed+ >>stdin
+ try-process
+] unit-test
+
+: launcher-test-path ( -- str )
+ "resource:basis/io/launcher/windows/nt/test" ;
+
+[ ] [
+ launcher-test-path [
+ <process>
+ vm "-script" "stderr.factor" 3array >>command
+ "out.txt" temp-file >>stdout
+ "err.txt" temp-file >>stderr
+ try-process
+ ] with-directory
+] unit-test
+
+[ "output" ] [
+ "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "error" ] [
+ "err.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+ launcher-test-path [
+ <process>
+ vm "-script" "stderr.factor" 3array >>command
+ "out.txt" temp-file >>stdout
+ +stdout+ >>stderr
+ try-process
+ ] with-directory
+] unit-test
+
+[ "outputerror" ] [
+ "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "output" ] [
+ launcher-test-path [
+ <process>
+ vm "-script" "stderr.factor" 3array >>command
+ "err2.txt" temp-file >>stderr
+ ascii <process-reader> lines first
+ ] with-directory
+] unit-test
+
+[ "error" ] [
+ "err2.txt" temp-file ascii file-lines first
+] unit-test
+
+[ t ] [
+ launcher-test-path [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ os-envs =
+] unit-test
+
+[ t ] [
+ launcher-test-path [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ +replace-environment+ >>environment-mode
+ os-envs >>environment
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ os-envs =
+] unit-test
+
+[ "B" ] [
+ launcher-test-path [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ { { "A" "B" } } >>environment
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ "A" swap at
+] unit-test
+
+[ f ] [
+ launcher-test-path [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ { { "USERPROFILE" "XXX" } } >>environment
+ +prepend-environment+ >>environment-mode
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ "USERPROFILE" swap at "XXX" =
+] unit-test
+
+2 [
+ [ ] [
+ <process>
+ "cmd.exe /c dir" >>command
+ "dir.txt" temp-file >>stdout
+ try-process
+ ] unit-test
+
+ [ ] [ "dir.txt" temp-file delete-file ] unit-test
+] times
+
+[ "append-test" temp-file delete-file ] ignore-errors
+
+[ "Hello appender\r\nHello appender\r\n" ] [
+ 2 [
+ launcher-test-path [
+ <process>
+ vm "-script" "append.factor" 3array >>command
+ "append-test" temp-file <appender> >>stdout
+ try-process
+ ] with-directory
+ ] times
+
+ "append-test" temp-file ascii file-contents
+] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types arrays continuations destructors io
+io.backend.windows libc io.ports io.pipes windows.types math
+windows.kernel32 windows namespaces make io.launcher kernel
+sequences windows.errors assocs splitting system strings
+io.launcher.windows io.files.windows io.backend io.files
+io.files.private combinators shuffle accessors locals ;
+IN: io.launcher.windows.nt
+
+: duplicate-handle ( handle -- handle' )
+ GetCurrentProcess ! source process
+ swap ! handle
+ GetCurrentProcess ! target process
+ f <void*> [ ! target handle
+ DUPLICATE_SAME_ACCESS ! desired access
+ TRUE ! inherit handle
+ DUPLICATE_CLOSE_SOURCE ! options
+ DuplicateHandle win32-error=0/f
+ ] keep *void* ;
+
+! /dev/null simulation
+: null-input ( -- pipe )
+ (pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
+
+: null-output ( -- pipe )
+ (pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
+
+: null-pipe ( mode -- pipe )
+ {
+ { GENERIC_READ [ null-input ] }
+ { GENERIC_WRITE [ null-output ] }
+ } case ;
+
+! The below code is based on the example given in
+! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
+
+: redirect-default ( obj access-mode create-mode -- handle )
+ 3drop f ;
+
+: redirect-closed ( obj access-mode create-mode -- handle )
+ drop nip null-pipe ;
+
+:: redirect-file ( path access-mode create-mode -- handle )
+ path normalize-path
+ access-mode
+ share-mode
+ default-security-attributes
+ create-mode
+ FILE_ATTRIBUTE_NORMAL ! flags and attributes
+ f ! template file
+ CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
+
+: redirect-append ( path access-mode create-mode -- handle )
+ [ path>> ] 2dip
+ drop OPEN_ALWAYS
+ redirect-file
+ dup 0 FILE_END set-file-pointer ;
+
+: redirect-handle ( handle access-mode create-mode -- handle )
+ 2drop handle>> duplicate-handle ;
+
+: redirect-stream ( stream access-mode create-mode -- handle )
+ [ underlying-handle handle>> ] 2dip redirect-handle ;
+
+: redirect ( obj access-mode create-mode -- handle )
+ {
+ { [ pick not ] [ redirect-default ] }
+ { [ pick +closed+ eq? ] [ redirect-closed ] }
+ { [ pick string? ] [ redirect-file ] }
+ { [ pick appender? ] [ redirect-append ] }
+ { [ pick win32-file? ] [ redirect-handle ] }
+ [ redirect-stream ]
+ } cond
+ dup [ dup t set-inherit ] when ;
+
+: redirect-stdout ( process args -- handle )
+ drop
+ stdout>>
+ GENERIC_WRITE
+ CREATE_ALWAYS
+ redirect
+ STD_OUTPUT_HANDLE GetStdHandle or ;
+
+: redirect-stderr ( process args -- handle )
+ over stderr>> +stdout+ eq? [
+ nip
+ lpStartupInfo>> STARTUPINFO-hStdOutput
+ ] [
+ drop
+ stderr>>
+ GENERIC_WRITE
+ CREATE_ALWAYS
+ redirect
+ STD_ERROR_HANDLE GetStdHandle or
+ ] if ;
+
+: redirect-stdin ( process args -- handle )
+ drop
+ stdin>>
+ GENERIC_READ
+ OPEN_EXISTING
+ redirect
+ STD_INPUT_HANDLE GetStdHandle or ;
+
+M: winnt fill-redirection ( process args -- )
+ [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
+ [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
+ [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
+ 2drop ;
--- /dev/null
+unportable
--- /dev/null
+USE: io\r
+"Hello appender" print\r
--- /dev/null
+USE: system
+USE: prettyprint
+USE: environment
+os-envs .
--- /dev/null
+USE: io\r
+USE: namespaces\r
+\r
+"output" write flush\r
+"error" error-stream get stream-write error-stream get stream-flush\r
--- /dev/null
+unportable
--- /dev/null
+IN: io.launcher.windows.tests\r
+USING: tools.test io.launcher.windows ;\r
+\r
+[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test\r
+\r
+[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test\r
+\r
+[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test\r
+\r
+[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test\r
--- /dev/null
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types arrays continuations io
+io.backend.windows io.pipes.windows.nt io.pathnames libc io.ports
+windows.types math windows.kernel32
+namespaces make io.launcher kernel sequences windows.errors
+splitting system threads init strings combinators
+io.backend accessors concurrency.flags io.files assocs
+io.files.private windows destructors specialized-arrays.ushort
+specialized-arrays.alien ;
+IN: io.launcher.windows
+
+TUPLE: CreateProcess-args
+ lpApplicationName
+ lpCommandLine
+ lpProcessAttributes
+ lpThreadAttributes
+ bInheritHandles
+ dwCreateFlags
+ lpEnvironment
+ lpCurrentDirectory
+ lpStartupInfo
+ lpProcessInformation ;
+
+: default-CreateProcess-args ( -- obj )
+ CreateProcess-args new
+ "STARTUPINFO" <c-object>
+ "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
+ "PROCESS_INFORMATION" <c-object> >>lpProcessInformation
+ TRUE >>bInheritHandles
+ 0 >>dwCreateFlags ;
+
+: call-CreateProcess ( CreateProcess-args -- )
+ {
+ [ lpApplicationName>> ]
+ [ lpCommandLine>> ]
+ [ lpProcessAttributes>> ]
+ [ lpThreadAttributes>> ]
+ [ bInheritHandles>> ]
+ [ dwCreateFlags>> ]
+ [ lpEnvironment>> ]
+ [ lpCurrentDirectory>> ]
+ [ lpStartupInfo>> ]
+ [ lpProcessInformation>> ]
+ } cleave
+ CreateProcess win32-error=0/f ;
+
+: count-trailing-backslashes ( str n -- str n )
+ [ "\\" ?tail ] dip swap [
+ 1+ count-trailing-backslashes
+ ] when ;
+
+: fix-trailing-backslashes ( str -- str' )
+ 0 count-trailing-backslashes
+ 2 * CHAR: \\ <repetition> append ;
+
+: escape-argument ( str -- newstr )
+ CHAR: \s over member? [
+ fix-trailing-backslashes "\"" dup surround
+ ] when ;
+
+: join-arguments ( args -- cmd-line )
+ [ escape-argument ] map " " join ;
+
+: lookup-priority ( process -- n )
+ priority>> {
+ { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
+ { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
+ { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
+ { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
+ { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
+ { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
+ [ drop f ]
+ } case ;
+
+: app-name/cmd-line ( process -- app-name cmd-line )
+ command>> dup string? [
+ " " split1
+ ] [
+ unclip swap join-arguments
+ ] if ;
+
+: cmd-line ( process -- cmd-line )
+ command>> dup string? [ join-arguments ] unless ;
+
+: fill-lpApplicationName ( process args -- process args )
+ over app-name/cmd-line
+ [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ;
+
+: fill-lpCommandLine ( process args -- process args )
+ over cmd-line >>lpCommandLine ;
+
+: fill-dwCreateFlags ( process args -- process args )
+ 0
+ pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
+ pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
+ pick lookup-priority [ bitor ] when*
+ >>dwCreateFlags ;
+
+: fill-lpEnvironment ( process args -- process args )
+ over pass-environment? [
+ [
+ over get-environment
+ [ swap % "=" % % "\0" % ] assoc-each
+ "\0" %
+ ] ushort-array{ } make underlying>>
+ >>lpEnvironment
+ ] when ;
+
+: fill-startup-info ( process args -- process args )
+ STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
+
+HOOK: fill-redirection io-backend ( process args -- )
+
+M: wince fill-redirection 2drop ;
+
+: make-CreateProcess-args ( process -- args )
+ default-CreateProcess-args
+ os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
+ fill-dwCreateFlags
+ fill-lpEnvironment
+ fill-startup-info
+ nip ;
+
+M: windows current-process-handle ( -- handle )
+ GetCurrentProcessId ;
+
+M: windows run-process* ( process -- handle )
+ [
+ current-directory get (normalize-path) cd
+
+ dup make-CreateProcess-args
+ tuck fill-redirection
+ dup call-CreateProcess
+ lpProcessInformation>>
+ ] with-destructors ;
+
+M: windows kill-process* ( handle -- )
+ PROCESS_INFORMATION-hProcess
+ 255 TerminateProcess win32-error=0/f ;
+
+: dispose-process ( process-information -- )
+ #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
+ #! with CloseHandle when they are no longer needed."
+ dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
+ PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
+
+: exit-code ( process -- n )
+ PROCESS_INFORMATION-hProcess
+ 0 <ulong> [ GetExitCodeProcess ] keep *ulong
+ swap win32-error=0/f ;
+
+: process-exited ( process -- )
+ dup handle>> exit-code
+ over handle>> dispose-process
+ notify-exit ;
+
+M: windows wait-for-processes ( -- ? )
+ processes get keys dup
+ [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
+ [ length ] [ underlying>> ] bi 0 0
+ WaitForMultipleObjects
+ dup HEX: ffffffff = [ win32-error ] when
+ dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
-USING: io io.mmap io.mmap.char io.files kernel tools.test
-continuations sequences io.encodings.ascii accessors ;
+USING: io io.mmap io.mmap.char io.files io.files.temp
+io.directories kernel tools.test continuations sequences
+io.encodings.ascii accessors ;
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations destructors io.files io.backend kernel
-quotations system alien alien.accessors accessors system
-vocabs.loader combinators alien.c-types ;
+USING: continuations destructors io.files io.files.info
+io.backend kernel quotations system alien alien.accessors
+accessors system vocabs.loader combinators alien.c-types ;
IN: io.mmap
TUPLE: mapped-file address handle length disposed ;
-HOOK: (mapped-file) io-backend ( path length -- address handle )
+HOOK: (mapped-file) os ( path length -- address handle )
: <mapped-file> ( path -- mmap )
[ normalize-path ] [ file-info size>> ] bi [ (mapped-file) ] keep
[ <mapped-file> ] dip with-disposal ; inline
{
- { [ os unix? ] [ "io.unix.mmap" require ] }
- { [ os winnt? ] [ "io.windows.mmap" require ] }
+ { [ os unix? ] [ "io.mmap.unix" require ] }
+ { [ os winnt? ] [ "io.mmap.windows" require ] }
} cond
--- /dev/null
+Slava Pestov
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien io io.files kernel math math.bitwise system unix
+io.backend.unix io.ports io.mmap destructors locals accessors ;
+IN: io.mmap.unix
+
+: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
+
+:: mmap-open ( path length prot flags -- alien fd )
+ [
+ f length prot flags
+ path open-r/w |dispose
+ [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
+ ] with-destructors ;
+
+M: unix (mapped-file)
+ { PROT_READ PROT_WRITE } flags
+ { MAP_FILE MAP_SHARED } flags
+ mmap-open ;
+
+M: unix close-mapped-file ( mmap -- )
+ [ [ address>> ] [ length>> ] bi munmap io-error ]
+ [ handle>> close-file ]
+ bi ;
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+USING: alien alien.c-types arrays destructors generic io.mmap
+io.ports io.backend.windows io.files.windows io.backend.windows.privileges
+kernel libc math math.bitwise namespaces quotations sequences
+windows windows.advapi32 windows.kernel32 io.backend system
+accessors locals ;
+IN: io.mmap.windows
+
+: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
+ CreateFileMapping [ win32-error=0/f ] keep <win32-handle> ;
+
+: map-view-of-file ( hFileMappingObject dwDesiredAccess dwFileOffsetHigh dwFileOffsetLow dwNumberOfBytesToMap -- HANDLE )
+ MapViewOfFile [ win32-error=0/f ] keep ;
+
+:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
+ [let | lo [ length HEX: ffffffff bitand ]
+ hi [ length -32 shift HEX: ffffffff bitand ] |
+ { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
+ path access-mode create-mode 0 open-file |dispose
+ dup handle>> f protect hi lo f create-file-mapping |dispose
+ dup handle>> access 0 0 0 map-view-of-file
+ ] with-privileges
+ ] ;
+
+TUPLE: win32-mapped-file file mapping ;
+
+M: win32-mapped-file dispose
+ [ file>> dispose ] [ mapping>> dispose ] bi ;
+
+C: <win32-mapped-file> win32-mapped-file
+
+M: windows (mapped-file)
+ [
+ { GENERIC_WRITE GENERIC_READ } flags
+ OPEN_ALWAYS
+ { PAGE_READWRITE SEC_COMMIT } flags
+ FILE_MAP_ALL_ACCESS mmap-open
+ -rot <win32-mapped-file>
+ ] with-destructors ;
+
+M: windows close-mapped-file ( mapped-file -- )
+ [
+ [ handle>> &dispose drop ]
+ [ address>> UnmapViewOfFile win32-error=0/f ] bi
+ ] with-destructors ;
--- /dev/null
+IN: io.monitors.linux.tests
+USING: io.monitors tools.test io.files io.files.temp
+io.directories system sequences continuations namespaces
+concurrency.count-downs kernel io threads calendar prettyprint
+destructors io.timeouts ;
+
+! On Linux, a notification on the directory itself would report an invalid
+! path name
+[
+ [ ] [ "monitor-test-self" temp-file make-directories ] unit-test
+
+ ! Non-recursive
+ [ ] [ "monitor-test-self" temp-file f <monitor> "m" set ] unit-test
+ [ ] [ 3 seconds "m" get set-timeout ] unit-test
+
+ [ ] [ "monitor-test-self" temp-file touch-file ] unit-test
+
+ [ t ] [
+ "m" get next-change drop
+ [ "" = ] [ "monitor-test-self" temp-file = ] bi or
+ ] unit-test
+
+ [ ] [ "m" get dispose ] unit-test
+
+ ! Recursive
+ [ ] [ "monitor-test-self" temp-file t <monitor> "m" set ] unit-test
+ [ ] [ 3 seconds "m" get set-timeout ] unit-test
+
+ [ ] [ "monitor-test-self" temp-file touch-file ] unit-test
+
+ [ t ] [
+ "m" get next-change drop
+ [ "" = ] [ "monitor-test-self" temp-file = ] bi or
+ ] unit-test
+
+ [ ] [ "m" get dispose ] unit-test
+] with-monitors
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io.backend io.monitors io.monitors.recursive
+io.files io.pathnames io.buffers io.monitors io.ports io.timeouts
+io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
+namespaces make threads continuations init math math.bitwise
+sets alien alien.strings alien.c-types vocabs.loader accessors
+system hashtables destructors unix ;
+IN: io.monitors.linux
+
+SYMBOL: watches
+
+SYMBOL: inotify
+
+TUPLE: linux-monitor < monitor wd inotify watches disposed ;
+
+: <linux-monitor> ( wd path mailbox -- monitor )
+ linux-monitor new-monitor
+ inotify get >>inotify
+ watches get >>watches
+ swap >>wd ;
+
+: wd>monitor ( wd -- monitor ) watches get at ;
+
+: <inotify> ( -- port/f )
+ inotify_init dup 0 < [ drop f ] [ <fd> init-fd <input-port> ] if ;
+
+: inotify-fd ( -- fd ) inotify get handle>> handle-fd ;
+
+: check-existing ( wd -- )
+ watches get key? [
+ "Cannot open multiple monitors for the same file" throw
+ ] when ;
+
+: (add-watch) ( path mask -- wd )
+ inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
+
+: add-watch ( path mask mailbox -- monitor )
+ [ [ (normalize-path) ] dip [ (add-watch) ] [ drop ] 2bi ] dip
+ <linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
+
+: check-inotify ( -- )
+ inotify get [
+ "Calling <monitor> outside with-monitors" throw
+ ] unless ;
+
+M: linux (monitor) ( path recursive? mailbox -- monitor )
+ swap [
+ <recursive-monitor>
+ ] [
+ check-inotify
+ IN_CHANGE_EVENTS swap add-watch
+ ] if ;
+
+M: linux-monitor dispose* ( monitor -- )
+ [ [ wd>> ] [ watches>> ] bi delete-at ]
+ [
+ dup inotify>> disposed>> [ drop ] [
+ [ inotify>> handle>> handle-fd ] [ wd>> ] bi
+ inotify_rm_watch io-error
+ ] if
+ ] bi ;
+
+: ignore-flags? ( mask -- ? )
+ {
+ IN_DELETE_SELF
+ IN_MOVE_SELF
+ IN_UNMOUNT
+ IN_Q_OVERFLOW
+ IN_IGNORED
+ } flags bitand 0 > ;
+
+: parse-action ( mask -- changed )
+ [
+ IN_CREATE +add-file+ ?flag
+ IN_DELETE +remove-file+ ?flag
+ IN_MODIFY +modify-file+ ?flag
+ IN_ATTRIB +modify-file+ ?flag
+ IN_MOVED_FROM +rename-file-old+ ?flag
+ IN_MOVED_TO +rename-file-new+ ?flag
+ drop
+ ] { } make prune ;
+
+: parse-event-name ( event -- name )
+ dup inotify-event-len zero?
+ [ drop "" ] [ inotify-event-name utf8 alien>string ] if ;
+
+: parse-file-notify ( buffer -- path changed )
+ dup inotify-event-mask ignore-flags? [
+ drop f f
+ ] [
+ [ parse-event-name ] [ inotify-event-mask parse-action ] bi
+ ] if ;
+
+: events-exhausted? ( i buffer -- ? )
+ fill>> >= ;
+
+: inotify-event@ ( i buffer -- alien )
+ ptr>> <displaced-alien> ;
+
+: next-event ( i buffer -- i buffer )
+ 2dup inotify-event@
+ inotify-event-len "inotify-event" heap-size +
+ swap [ + ] dip ;
+
+: parse-file-notifications ( i buffer -- )
+ 2dup events-exhausted? [ 2drop ] [
+ 2dup inotify-event@ dup inotify-event-wd wd>monitor
+ [ parse-file-notify ] dip queue-change
+ next-event parse-file-notifications
+ ] if ;
+
+: inotify-read-loop ( port -- )
+ dup check-disposed
+ dup wait-to-read drop
+ 0 over buffer>> parse-file-notifications
+ 0 over buffer>> buffer-reset
+ inotify-read-loop ;
+
+: inotify-read-thread ( port -- )
+ [ inotify-read-loop ] curry ignore-errors ;
+
+M: linux init-monitors
+ H{ } clone watches set
+ <inotify> [
+ [ inotify set ]
+ [
+ [ inotify-read-thread ] curry
+ "Linux monitor thread" spawn drop
+ ] bi
+ ] [
+ "Linux kernel version is too old" throw
+ ] if* ;
+
+M: linux dispose-monitors
+ inotify get dispose ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend io.monitors
+core-foundation.fsevents continuations kernel sequences
+namespaces arrays system locals accessors destructors fry ;
+IN: io.monitors.macosx
+
+TUPLE: macosx-monitor < monitor handle ;
+
+: enqueue-notifications ( triples monitor -- )
+ '[ first { +modify-file+ } _ queue-change ] each ;
+
+M:: macosx (monitor) ( path recursive? mailbox -- monitor )
+ [let | path [ path normalize-path ] |
+ path mailbox macosx-monitor new-monitor
+ dup [ enqueue-notifications ] curry
+ path 1array 0 0 <event-stream> >>handle
+ ] ;
+
+M: macosx-monitor dispose
+ handle>> dispose ;
+
+macosx set-io-backend
--- /dev/null
+unportable
IN: io.monitors.tests
USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io
-threads calendar prettyprint destructors io.timeouts ;
+threads calendar prettyprint destructors io.timeouts
+io.files.temp io.directories io.directories.hierarchy
+io.pathnames ;
os { winnt linux macosx } member? [
[
[ <monitor> ] dip with-disposal ; inline
{
- { [ os macosx? ] [ "io.unix.macosx.monitors" require ] }
- { [ os linux? ] [ "io.unix.linux.monitors" require ] }
- { [ os winnt? ] [ "io.windows.nt.monitors" require ] }
+ { [ os macosx? ] [ "io.monitors.macosx" require ] }
+ { [ os linux? ] [ "io.monitors.linux" require ] }
+ { [ os winnt? ] [ "io.monitors.windows.nt" require ] }
[ ]
} cond
USING: accessors math kernel namespaces continuations
io.files io.monitors io.monitors.recursive io.backend
-concurrency.mailboxes tools.test destructors ;
+concurrency.mailboxes tools.test destructors io.files.info
+io.pathnames io.files.temp io.directories.hierarchy ;
IN: io.monitors.recursive.tests
\ pump-thread must-infer
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences assocs arrays continuations
destructors combinators kernel threads concurrency.messaging
-concurrency.mailboxes concurrency.promises io.files io.monitors
-debugger fry ;
+concurrency.mailboxes concurrency.promises io.files io.files.info
+io.directories io.pathnames io.monitors debugger fry ;
IN: io.monitors.recursive
! Simulate recursive monitors on platforms that don't have them
--- /dev/null
+Doug Coleman
--- /dev/null
+IN: io.monitors.windows.nt.tests\r
+USING: io.monitors.windows.nt tools.test ;\r
+\r
+\ fill-queue-thread must-infer\r
--- /dev/null
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings libc destructors locals
+kernel math assocs namespaces make continuations sequences
+hashtables sorting arrays combinators math.bitwise strings
+system accessors threads splitting io.backend io.backend.windows
+io.backend.windows.nt io.files.windows.nt io.monitors io.ports
+io.buffers io.files io.timeouts io.encodings.string
+io.encodings.utf16n io windows windows.kernel32 windows.types
+io.pathnames ;
+IN: io.monitors.windows.nt
+
+: open-directory ( path -- handle )
+ normalize-path
+ FILE_LIST_DIRECTORY
+ share-mode
+ f
+ OPEN_EXISTING
+ { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
+ f
+ CreateFile opened-file ;
+
+TUPLE: win32-monitor-port < input-port recursive ;
+
+TUPLE: win32-monitor < monitor port ;
+
+: begin-reading-changes ( port -- overlapped )
+ {
+ [ handle>> handle>> ]
+ [ buffer>> ptr>> ]
+ [ buffer>> size>> ]
+ [ recursive>> 1 0 ? ]
+ } cleave
+ FILE_NOTIFY_CHANGE_ALL
+ 0 <uint>
+ (make-overlapped)
+ [ f ReadDirectoryChangesW win32-error=0/f ] keep ;
+
+: read-changes ( port -- bytes-transferred )
+ [
+ [ begin-reading-changes ] [ twiddle-thumbs ] bi
+ ] with-destructors ;
+
+: parse-action ( action -- changed )
+ {
+ { FILE_ACTION_ADDED [ +add-file+ ] }
+ { FILE_ACTION_REMOVED [ +remove-file+ ] }
+ { FILE_ACTION_MODIFIED [ +modify-file+ ] }
+ { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] }
+ { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] }
+ [ drop +modify-file+ ]
+ } case 1array ;
+
+: memory>u16-string ( alien len -- string )
+ memory>byte-array utf16n decode ;
+
+: parse-notify-record ( buffer -- path changed )
+ [
+ [ FILE_NOTIFY_INFORMATION-FileName ]
+ [ FILE_NOTIFY_INFORMATION-FileNameLength ]
+ bi memory>u16-string
+ ]
+ [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
+
+: (file-notify-records) ( buffer -- buffer )
+ dup ,
+ dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
+ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
+ (file-notify-records)
+ ] unless ;
+
+: file-notify-records ( buffer -- seq )
+ [ (file-notify-records) drop ] { } make ;
+
+:: parse-notify-records ( monitor buffer -- )
+ buffer file-notify-records [
+ parse-notify-record
+ [ monitor path>> prepend-path normalize-path ] dip
+ monitor queue-change
+ ] each ;
+
+: fill-queue ( monitor -- )
+ dup port>> dup check-disposed
+ [ buffer>> ptr>> ] [ read-changes zero? ] bi
+ [ 2dup parse-notify-records ] unless
+ 2drop ;
+
+: (fill-queue-thread) ( monitor -- )
+ dup fill-queue (fill-queue-thread) ;
+
+: fill-queue-thread ( monitor -- )
+ [ dup fill-queue (fill-queue-thread) ]
+ [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ;
+
+M:: winnt (monitor) ( path recursive? mailbox -- monitor )
+ [
+ path normalize-path mailbox win32-monitor new-monitor
+ path open-directory \ win32-monitor-port <buffered-port>
+ recursive? >>recursive
+ >>port
+ dup [ fill-queue-thread ] curry
+ "Windows monitor thread" spawn drop
+ ] with-destructors ;
+
+M: win32-monitor dispose
+ port>> dispose ;
--- /dev/null
+unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: io.paths kernel tools.test io.files.unique sequences
-io.files namespaces sorting ;
-IN: io.paths.tests
-
-[ t ] [
- [
- 10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate
- current-directory get t [ ] find-all-files
- ] with-unique-directory
- [ natural-sort ] bi@ =
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays deques dlists io.files
-kernel sequences system vocabs.loader fry continuations ;
-IN: io.paths
-
-TUPLE: directory-iterator path bfs queue ;
-
-<PRIVATE
-
-: qualified-directory ( path -- seq )
- dup directory-files [ append-path ] with map ;
-
-: push-directory ( path iter -- )
- [ qualified-directory ] dip [
- dup queue>> swap bfs>>
- [ push-front ] [ push-back ] if
- ] curry each ;
-
-: <directory-iterator> ( path bfs? -- iterator )
- <dlist> directory-iterator boa
- dup path>> over push-directory ;
-
-: next-file ( iter -- file/f )
- dup queue>> deque-empty? [ drop f ] [
- dup queue>> pop-back dup link-info directory?
- [ over push-directory next-file ] [ nip ] if
- ] if ;
-
-: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
- over next-file [
- over call
- [ 2nip ] [ iterate-directory ] if*
- ] [
- 2drop f
- ] if* ; inline recursive
-
-PRIVATE>
-
-: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
- [ <directory-iterator> ] dip
- [ keep and ] curry iterate-directory ; inline
-
-: each-file ( path bfs? quot: ( obj -- ? ) -- )
- [ <directory-iterator> ] dip
- [ f ] compose iterate-directory drop ; inline
-
-: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
- [ <directory-iterator> ] dip
- pusher [ [ f ] compose iterate-directory drop ] dip ; inline
-
-: recursive-directory ( path bfs? -- paths )
- [ ] accumulator [ each-file ] dip ;
-
-: find-in-directories ( directories bfs? quot -- path' )
- '[ _ _ find-file ] attempt-all ; inline
-
-os windows? [ "io.paths.windows" require ] when
+++ /dev/null
-Doug Coleman
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays continuations fry io.files io.paths
-kernel windows.shell32 sequences ;
-IN: io.paths.windows
-
-: program-files-directories ( -- array )
- program-files program-files-x86 2array ; inline
-
-: find-in-program-files ( base-directory bfs? quot -- path )
- [
- [ program-files-directories ] dip '[ _ append-path ] map
- ] 2dip find-in-directories ; inline
] 2parallel-map ;
{
- { [ os unix? ] [ "io.unix.pipes" require ] }
- { [ os winnt? ] [ "io.windows.nt.pipes" require ] }
+ { [ os unix? ] [ "io.pipes.unix" require ] }
+ { [ os winnt? ] [ "io.pipes.windows.nt" require ] }
[ ]
} cond
--- /dev/null
+USING: tools.test io.pipes io.pipes.unix io.encodings.utf8
+io.encodings io namespaces sequences ;
+IN: io.pipes.unix.tests
+
+[ { 0 0 } ] [ { "ls" "grep ." } run-pipeline ] unit-test
+
+[ { 0 f 0 } ] [
+ {
+ "ls"
+ [
+ input-stream [ utf8 <decoder> ] change
+ output-stream [ utf8 <encoder> ] change
+ input-stream get lines reverse [ print ] each f
+ ]
+ "grep ."
+ } run-pipeline
+] unit-test
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system kernel unix math sequences
+io.backend.unix io.ports specialized-arrays.int accessors ;
+IN: io.pipes.unix
+QUALIFIED: io.pipes
+
+M: unix io.pipes:(pipe) ( -- pair )
+ 2 <int-array>
+ [ underlying>> pipe io-error ]
+ [ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types arrays destructors io io.backend.windows libc
+windows.types math.bitwise windows.kernel32 windows namespaces
+make kernel sequences windows.errors assocs math.parser system
+random combinators accessors io.pipes io.ports ;
+IN: io.pipes.windows.nt
+
+! This code is based on
+! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
+
+: create-named-pipe ( name -- handle )
+ { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags
+ PIPE_TYPE_BYTE
+ 1
+ 4096
+ 4096
+ 0
+ default-security-attributes
+ CreateNamedPipe opened-file ;
+
+: open-other-end ( name -- handle )
+ GENERIC_WRITE
+ { FILE_SHARE_READ FILE_SHARE_WRITE } flags
+ default-security-attributes
+ OPEN_EXISTING
+ FILE_FLAG_OVERLAPPED
+ f
+ CreateFile opened-file ;
+
+: unique-pipe-name ( -- string )
+ [
+ "\\\\.\\pipe\\factor-" %
+ pipe counter #
+ "-" %
+ 32 random-bits #
+ "-" %
+ micros #
+ ] "" make ;
+
+M: winnt (pipe) ( -- pipe )
+ [
+ unique-pipe-name
+ [ create-named-pipe ] [ open-other-end ] bi
+ pipe boa
+ ] with-destructors ;
--- /dev/null
+unportable
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays kernel sequences
-namespaces math math.order combinators init alien alien.c-types
-alien.strings libc continuations destructors summary
-splitting assocs random math.parser locals unicode.case openssl
-openssl.libcrypto openssl.libssl io.backend io.ports io.files
+USING: accessors byte-arrays kernel sequences namespaces math
+math.order combinators init alien alien.c-types alien.strings
+libc continuations destructors summary splitting assocs random
+math.parser locals unicode.case openssl openssl.libcrypto
+openssl.libssl io.backend io.ports io.pathnames
io.encodings.8-bit io.timeouts io.sockets.secure ;
IN: io.sockets.secure.openssl
HELP: secure
{ $class-description "The class of secure socket addresses." } ;
-HELP: <secure> ( addrspec -- secure )
+HELP: <secure>
{ $values { "addrspec" "an address specifier" } { "secure" secure } }
{ $description "Creates a new secure socket address, which can then be passed to " { $link <client> } " or " { $link <server> } "." } ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel symbols namespaces continuations
+USING: accessors kernel namespaces continuations
destructors io debugger io.sockets sequences summary calendar
delegate system vocabs.loader combinators present ;
IN: io.sockets.secure
HOOK: accept-secure-handshake secure-socket-backend ( -- )
{
- { [ os unix? ] [ "io.unix.sockets.secure" require ] }
+ { [ os unix? ] [ "io.sockets.secure.unix" require ] }
{ [ os windows? ] [ "openssl" require ] }
} cond
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.sockets.secure kernel ;
+IN: io.sockets.secure.unix.debug
+
+: with-test-context ( quot -- )
+ <secure-config>
+ "resource:basis/openssl/test/server.pem" >>key-file
+ "resource:basis/openssl/test/dh1024.pem" >>dh-file
+ "password" >>password
+ swap with-secure-context ; inline
--- /dev/null
+unportable
--- /dev/null
+IN: io.sockets.secure.tests
+USING: accessors kernel namespaces io io.sockets
+io.sockets.secure io.encodings.ascii io.streams.duplex
+io.backend.unix classes words destructors threads tools.test
+concurrency.promises byte-arrays locals calendar io.timeouts
+io.sockets.secure.unix.debug ;
+
+\ <secure-config> must-infer
+{ 1 0 } [ [ ] with-secure-context ] must-infer-as
+
+[ ] [ <promise> "port" set ] unit-test
+
+:: server-test ( quot -- )
+ [
+ [
+ "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+ dup addr>> addrspec>> port>> "port" get fulfill
+ accept [
+ quot call
+ ] curry with-stream
+ ] with-disposal
+ ] with-test-context
+ ] "SSL server test" spawn drop ;
+
+: client-test ( -- string )
+ <secure-config> [
+ "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
+ ] with-secure-context ;
+
+[ ] [ [ class name>> write ] server-test ] unit-test
+
+[ "secure" ] [ client-test ] unit-test
+
+! Now, see what happens if the server closes the connection prematurely
+[ ] [ <promise> "port" set ] unit-test
+
+[ ] [
+ [
+ drop
+ "hello" write flush
+ input-stream get stream>> handle>> f >>connected drop
+ ] server-test
+] unit-test
+
+[ client-test ] [ premature-close? ] must-fail-with
+
+! Now, try validating the certificate. This should fail because its
+! actually an invalid certificate
+[ ] [ <promise> "port" set ] unit-test
+
+[ ] [ [ drop "hi" write ] server-test ] unit-test
+
+[
+ <secure-config> [
+ "localhost" "port" get ?promise <inet> <secure> ascii
+ <client> drop dispose
+ ] with-secure-context
+] [ certificate-verify-error? ] must-fail-with
+
+! Client-side handshake timeout
+[ ] [ <promise> "port" set ] unit-test
+
+[ ] [
+ [
+ "127.0.0.1" 0 <inet4> ascii <server> [
+ dup addr>> port>> "port" get fulfill
+ accept drop 1 minutes sleep dispose
+ ] with-disposal
+ ] "Silly server" spawn drop
+] unit-test
+
+[
+ 1 seconds secure-socket-timeout [
+ client-test
+ ] with-variable
+] [ io-timeout? ] must-fail-with
+
+! Server-side handshake timeout
+[ ] [ <promise> "port" set ] unit-test
+
+[ ] [
+ [
+ "127.0.0.1" "port" get ?promise
+ <inet4> ascii <client> drop 1 minutes sleep dispose
+ ] "Silly client" spawn drop
+] unit-test
+
+[
+ 1 seconds secure-socket-timeout [
+ [
+ "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+ dup addr>> addrspec>> port>> "port" get fulfill
+ accept drop dup stream-read1 drop dispose
+ ] with-disposal
+ ] with-test-context
+ ] with-variable
+] [ io-timeout? ] must-fail-with
+
+! Client socket shutdown timeout
+
+! Until I sort out two-stage handshaking, I can't do much here
+[
+ [ ] [ <promise> "port" set ] unit-test
+
+ [ ] [
+ [
+ [
+ "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+ dup addr>> addrspec>> port>> "port" get fulfill
+ accept drop 1 minutes sleep dispose
+ ] with-disposal
+ ] with-test-context
+ ] "Silly server" spawn drop
+ ] unit-test
+
+ [
+ 1 seconds secure-socket-timeout [
+ <secure-config> [
+ "127.0.0.1" "port" get ?promise <inet4> <secure>
+ ascii <client> drop dispose
+ ] with-secure-context
+ ] with-variable
+ ] [ io-timeout? ] must-fail-with
+
+ ! Server socket shutdown timeout
+ [ ] [ <promise> "port" set ] unit-test
+
+ [ ] [
+ [
+ [
+ "127.0.0.1" "port" get ?promise
+ <inet4> <secure> ascii <client> drop 1 minutes sleep dispose
+ ] with-test-context
+ ] "Silly client" spawn drop
+ ] unit-test
+
+ [
+ 1 seconds secure-socket-timeout [
+ [
+ "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+ dup addr>> addrspec>> port>> "port" get fulfill
+ accept drop dispose
+ ] with-disposal
+ ] with-test-context
+ ] with-variable
+ ] [ io-timeout? ] must-fail-with
+] drop
--- /dev/null
+! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors unix byte-arrays kernel sequences
+namespaces math math.order combinators init alien alien.c-types
+alien.strings libc continuations destructors openssl
+openssl.libcrypto openssl.libssl io io.files io.ports
+io.backend.unix io.sockets.unix io.encodings.ascii io.buffers
+io.sockets io.sockets.secure io.sockets.secure.openssl
+io.timeouts system summary fry ;
+IN: io.sockets.secure.unix
+
+M: ssl-handle handle-fd file>> handle-fd ;
+
+: syscall-error ( r -- * )
+ ERR_get_error dup zero? [
+ drop
+ {
+ { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
+ { 0 [ premature-close ] }
+ } case
+ ] [ nip (ssl-error) ] if ;
+
+: check-accept-response ( handle r -- event )
+ over handle>> over SSL_get_error
+ {
+ { SSL_ERROR_NONE [ 2drop f ] }
+ { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
+ { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] }
+ { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
+ { SSL_ERROR_SYSCALL [ syscall-error ] }
+ { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
+ { SSL_ERROR_SSL [ (ssl-error) ] }
+ } case ;
+
+: do-ssl-accept ( ssl-handle -- )
+ dup dup handle>> SSL_accept check-accept-response dup
+ [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ;
+
+: maybe-handshake ( ssl-handle -- )
+ dup connected>> [ drop ] [
+ t >>connected
+ [ do-ssl-accept ] with-timeout
+ ] if ;
+
+: check-response ( port r -- port r n )
+ over handle>> handle>> over SSL_get_error ; inline
+
+! Input ports
+: check-read-response ( port r -- event )
+ check-response
+ {
+ { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
+ { SSL_ERROR_ZERO_RETURN [ 2drop f ] }
+ { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
+ { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
+ { SSL_ERROR_SYSCALL [ syscall-error ] }
+ { SSL_ERROR_SSL [ (ssl-error) ] }
+ } case ;
+
+M: ssl-handle refill
+ dup maybe-handshake
+ handle>> ! ssl
+ over buffer>>
+ [ buffer-end ] ! buf
+ [ buffer-capacity ] bi ! len
+ SSL_read
+ check-read-response ;
+
+! Output ports
+: check-write-response ( port r -- event )
+ check-response
+ {
+ { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
+ { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
+ { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
+ { SSL_ERROR_SYSCALL [ syscall-error ] }
+ { SSL_ERROR_SSL [ (ssl-error) ] }
+ } case ;
+
+M: ssl-handle drain
+ dup maybe-handshake
+ handle>> ! ssl
+ over buffer>>
+ [ buffer@ ] ! buf
+ [ buffer-length ] bi ! len
+ SSL_write
+ check-write-response ;
+
+M: ssl-handle cancel-operation
+ file>> cancel-operation ;
+
+M: ssl-handle timeout
+ drop secure-socket-timeout get ;
+
+! Client sockets
+: <ssl-socket> ( fd -- ssl )
+ [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
+ [ handle>> swap dup SSL_set_bio ] keep ;
+
+M: secure ((client)) ( addrspec -- handle )
+ addrspec>> ((client)) <ssl-socket> ;
+
+M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
+
+M: secure (get-local-address) addrspec>> (get-local-address) ;
+
+: check-connect-response ( ssl-handle r -- event )
+ over handle>> over SSL_get_error
+ {
+ { SSL_ERROR_NONE [ 2drop f ] }
+ { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
+ { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
+ { SSL_ERROR_SYSCALL [ syscall-error ] }
+ { SSL_ERROR_SSL [ (ssl-error) ] }
+ } case ;
+
+: do-ssl-connect ( ssl-handle -- )
+ dup dup handle>> SSL_connect check-connect-response dup
+ [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
+
+: resume-session ( ssl-handle ssl-session -- )
+ [ [ handle>> ] dip SSL_set_session ssl-error ]
+ [ drop do-ssl-connect ]
+ 2bi ;
+
+: begin-session ( ssl-handle addrspec -- )
+ [ drop do-ssl-connect ]
+ [ [ handle>> SSL_get1_session ] dip save-session ]
+ 2bi ;
+
+: secure-connection ( client-out addrspec -- )
+ [ handle>> ] dip
+ [
+ '[
+ _ dup get-session
+ [ resume-session ] [ begin-session ] ?if
+ ] with-timeout
+ ] [ drop t >>connected drop ] 2bi ;
+
+M: secure establish-connection ( client-out remote -- )
+ addrspec>> [ establish-connection ] [ secure-connection ] 2bi ;
+
+M: secure (server) addrspec>> (server) ;
+
+M: secure (accept)
+ [
+ addrspec>> (accept) [ |dispose <ssl-socket> ] dip
+ ] with-destructors ;
+
+: check-shutdown-response ( handle r -- event )
+ #! We don't do two-step shutdown here because I couldn't
+ #! figure out how to do it with non-blocking BIOs. Also, it
+ #! seems that SSL_shutdown always returns 0 -- this sounds
+ #! like a bug
+ over handle>> over SSL_get_error
+ {
+ { SSL_ERROR_NONE [ 2drop f ] }
+ { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
+ { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
+ { SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] }
+ { SSL_ERROR_SSL [ (ssl-error) ] }
+ } case ;
+
+: (shutdown) ( handle -- )
+ dup dup handle>> SSL_shutdown check-shutdown-response
+ dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
+
+M: ssl-handle shutdown
+ dup connected>> [
+ f >>connected [ (shutdown) ] with-timeout
+ ] [ drop ] if ;
+
+: check-buffer ( port -- port )
+ dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ;
+
+: input/output-ports ( -- input output )
+ input-stream output-stream
+ [ get underlying-port check-buffer ] bi@
+ 2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ;
+
+: make-input/output-secure ( input output -- )
+ dup handle>> fd? [ upgrade-on-non-socket ] unless
+ [ <ssl-socket> ] change-handle
+ handle>> >>handle drop ;
+
+: (send-secure-handshake) ( output -- )
+ remote-address get [ upgrade-on-non-socket ] unless*
+ secure-connection ;
+
+M: openssl send-secure-handshake
+ input/output-ports
+ [ make-input/output-secure ] keep
+ [ (send-secure-handshake) ] keep
+ remote-address get dup inet? [
+ host>> swap handle>> check-certificate
+ ] [ 2drop ] if ;
+
+M: openssl accept-secure-handshake
+ input/output-ports
+ make-input/output-secure ;
io.encodings.ascii alien.strings io.binary accessors destructors
classes byte-arrays system combinators parser
alien.c-types math.parser splitting grouping math assocs summary
-system vocabs.loader combinators present fry ;
+system vocabs.loader combinators present fry vocabs.parser ;
IN: io.sockets
<< {
invalid-inet-server ;
{
- { [ os unix? ] [ "io.unix.sockets" require ] }
- { [ os winnt? ] [ "io.windows.nt.sockets" require ] }
- { [ os wince? ] [ "io.windows.ce.sockets" require ] }
+ { [ os unix? ] [ "io.sockets.unix" require ] }
+ { [ os winnt? ] [ "io.sockets.windows.nt" require ] }
} cond
--- /dev/null
+Slava Pestov
--- /dev/null
+Implementation of TCP/IP and UDP/IP sockets on Unix-like systems
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings generic kernel math
+namespaces threads sequences byte-arrays io.ports
+io.binary io.backend.unix io.streams.duplex
+io.backend io.ports io.pathnames io.files.private
+io.encodings.utf8 math.parser continuations libc combinators
+system accessors destructors unix locals init ;
+
+EXCLUDE: io => read write close ;
+EXCLUDE: io.sockets => accept ;
+
+IN: io.sockets.unix
+
+: socket-fd ( domain type -- fd )
+ 0 socket dup io-error <fd> init-fd |dispose ;
+
+: set-socket-option ( fd level opt -- )
+ [ handle-fd ] 2dip 1 <int> "int" heap-size setsockopt io-error ;
+
+M: unix addrinfo-error ( n -- )
+ dup zero? [ drop ] [ gai_strerror throw ] if ;
+
+! Client sockets - TCP and Unix domain
+M: object (get-local-address) ( handle remote -- sockaddr )
+ [ handle-fd ] dip empty-sockaddr/size <int>
+ [ getsockname io-error ] 2keep drop ;
+
+M: object (get-remote-address) ( handle local -- sockaddr )
+ [ handle-fd ] dip empty-sockaddr/size <int>
+ [ getpeername io-error ] 2keep drop ;
+
+: init-client-socket ( fd -- )
+ SOL_SOCKET SO_OOBINLINE set-socket-option ;
+
+: wait-to-connect ( port -- )
+ dup handle>> handle-fd f 0 write
+ {
+ { [ 0 = ] [ drop ] }
+ { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
+ { [ err_no EINTR = ] [ wait-to-connect ] }
+ [ (io-error) ]
+ } cond ;
+
+M: object establish-connection ( client-out remote -- )
+ [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
+ {
+ { [ 0 = ] [ drop ] }
+ { [ err_no EINPROGRESS = ] [
+ [ +output+ wait-for-port ] [ wait-to-connect ] bi
+ ] }
+ [ (io-error) ]
+ } cond ;
+
+M: object ((client)) ( addrspec -- fd )
+ protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
+
+! Server sockets - TCP and Unix domain
+: init-server-socket ( fd -- )
+ SOL_SOCKET SO_REUSEADDR set-socket-option ;
+
+: server-socket-fd ( addrspec type -- fd )
+ [ dup protocol-family ] dip socket-fd
+ dup init-server-socket
+ dup handle-fd rot make-sockaddr/size bind io-error ;
+
+M: object (server) ( addrspec -- handle )
+ [
+ SOCK_STREAM server-socket-fd
+ dup handle-fd 128 listen io-error
+ ] with-destructors ;
+
+: do-accept ( server addrspec -- fd sockaddr )
+ [ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
+ [ accept ] 2keep drop ; inline
+
+M: object (accept) ( server addrspec -- fd sockaddr )
+ 2dup do-accept
+ {
+ { [ over 0 >= ] [ [ 2nip <fd> init-fd ] dip ] }
+ { [ err_no EINTR = ] [ 2drop (accept) ] }
+ { [ err_no EAGAIN = ] [
+ 2drop
+ [ drop +input+ wait-for-port ]
+ [ (accept) ]
+ 2bi
+ ] }
+ [ (io-error) ]
+ } cond ;
+
+! Datagram sockets - UDP and Unix domain
+M: unix (datagram)
+ [ SOCK_DGRAM server-socket-fd ] with-destructors ;
+
+SYMBOL: receive-buffer
+
+: packet-size 65536 ; inline
+
+[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
+
+:: do-receive ( port -- packet sockaddr )
+ port addr>> empty-sockaddr/size [| sockaddr len |
+ port handle>> handle-fd ! s
+ receive-buffer get-global ! buf
+ packet-size ! nbytes
+ 0 ! flags
+ sockaddr ! from
+ len <int> ! fromlen
+ recvfrom dup 0 >= [
+ receive-buffer get-global swap memory>byte-array sockaddr
+ ] [
+ drop f f
+ ] if
+ ] call ;
+
+M: unix (receive) ( datagram -- packet sockaddr )
+ dup do-receive dup [ [ drop ] 2dip ] [
+ 2drop [ +input+ wait-for-port ] [ (receive) ] bi
+ ] if ;
+
+:: do-send ( packet sockaddr len socket datagram -- )
+ socket handle-fd packet dup length 0 sockaddr len sendto
+ 0 < [
+ err_no EINTR = [
+ packet sockaddr len socket datagram do-send
+ ] [
+ err_no EAGAIN = [
+ datagram +output+ wait-for-port
+ packet sockaddr len socket datagram do-send
+ ] [
+ (io-error)
+ ] if
+ ] if
+ ] when ;
+
+M: unix (send) ( packet addrspec datagram -- )
+ [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ;
+
+! Unix domain sockets
+M: local protocol-family drop PF_UNIX ;
+
+M: local sockaddr-size drop "sockaddr-un" heap-size ;
+
+M: local empty-sockaddr drop "sockaddr-un" <c-object> ;
+
+M: local make-sockaddr
+ path>> (normalize-path)
+ dup length 1 + max-un-path > [ "Path too long" throw ] when
+ "sockaddr-un" <c-object>
+ AF_UNIX over set-sockaddr-un-family
+ dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
+
+M: local parse-sockaddr
+ drop
+ sockaddr-un-path utf8 alien>string <local> ;
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
--- /dev/null
+USING: alien alien.accessors alien.c-types byte-arrays
+continuations destructors io.ports io.timeouts io.sockets
+io.sockets io namespaces io.streams.duplex io.backend.windows
+io.sockets.windows io.backend.windows.nt windows.winsock kernel
+libc math sequences threads system combinators accessors ;
+IN: io.sockets.windows.nt
+
+: malloc-int ( object -- object )
+ "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
+
+M: winnt WSASocket-flags ( -- DWORD )
+ WSA_FLAG_OVERLAPPED ;
+
+: get-ConnectEx-ptr ( socket -- void* )
+ SIO_GET_EXTENSION_FUNCTION_POINTER
+ WSAID_CONNECTEX
+ "GUID" heap-size
+ "void*" <c-object>
+ [
+ "void*" heap-size
+ "DWORD" <c-object>
+ f
+ f
+ WSAIoctl SOCKET_ERROR = [
+ winsock-error-string throw
+ ] when
+ ] keep *void* ;
+
+TUPLE: ConnectEx-args port
+ s name namelen lpSendBuffer dwSendDataLength
+ lpdwBytesSent lpOverlapped ptr ;
+
+: wait-for-socket ( args -- n )
+ [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
+
+: <ConnectEx-args> ( sockaddr size -- ConnectEx )
+ ConnectEx-args new
+ swap >>namelen
+ swap >>name
+ f >>lpSendBuffer
+ 0 >>dwSendDataLength
+ f >>lpdwBytesSent
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-ConnectEx ( ConnectEx -- )
+ {
+ [ s>> ]
+ [ name>> ]
+ [ namelen>> ]
+ [ lpSendBuffer>> ]
+ [ dwSendDataLength>> ]
+ [ lpdwBytesSent>> ]
+ [ lpOverlapped>> ]
+ [ ptr>> ]
+ } cleave
+ "int"
+ { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
+ "stdcall" alien-indirect drop
+ winsock-error-string [ throw ] when* ; inline
+
+M: object establish-connection ( client-out remote -- )
+ make-sockaddr/size <ConnectEx-args>
+ swap >>port
+ dup port>> handle>> handle>> >>s
+ dup s>> get-ConnectEx-ptr >>ptr
+ dup call-ConnectEx
+ wait-for-socket drop ;
+
+TUPLE: AcceptEx-args port
+ sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
+ dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
+
+: init-accept-buffer ( addr AcceptEx -- )
+ swap sockaddr-size 16 +
+ [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
+ dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
+ drop ; inline
+
+: <AcceptEx-args> ( server addr -- AcceptEx )
+ AcceptEx-args new
+ 2dup init-accept-buffer
+ swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
+ over handle>> handle>> >>sListenSocket
+ swap >>port
+ 0 >>dwReceiveDataLength
+ f >>lpdwBytesReceived
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-AcceptEx ( AcceptEx -- )
+ {
+ [ sListenSocket>> ]
+ [ sAcceptSocket>> ]
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ [ lpdwBytesReceived>> ]
+ [ lpOverlapped>> ]
+ } cleave AcceptEx drop
+ winsock-error-string [ throw ] when* ; inline
+
+: extract-remote-address ( AcceptEx -- sockaddr )
+ {
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ } cleave
+ f <void*>
+ 0 <int>
+ f <void*>
+ [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
+
+M: object (accept) ( server addr -- handle sockaddr )
+ [
+ <AcceptEx-args>
+ {
+ [ call-AcceptEx ]
+ [ wait-for-socket drop ]
+ [ sAcceptSocket>> <win32-socket> ]
+ [ extract-remote-address ]
+ } cleave
+ ] with-destructors ;
+
+TUPLE: WSARecvFrom-args port
+ s lpBuffers dwBufferCount lpNumberOfBytesRecvd
+ lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
+
+: make-receive-buffer ( -- WSABUF )
+ "WSABUF" malloc-object &free
+ default-buffer-size get over set-WSABUF-len
+ default-buffer-size get malloc &free over set-WSABUF-buf ; inline
+
+: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
+ WSARecvFrom-args new
+ swap >>port
+ dup port>> handle>> handle>> >>s
+ dup port>> addr>> sockaddr-size
+ [ malloc &free >>lpFrom ]
+ [ malloc-int &free >>lpFromLen ] bi
+ make-receive-buffer >>lpBuffers
+ 1 >>dwBufferCount
+ 0 malloc-int &free >>lpFlags
+ 0 malloc-int &free >>lpNumberOfBytesRecvd
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-WSARecvFrom ( WSARecvFrom -- )
+ {
+ [ s>> ]
+ [ lpBuffers>> ]
+ [ dwBufferCount>> ]
+ [ lpNumberOfBytesRecvd>> ]
+ [ lpFlags>> ]
+ [ lpFrom>> ]
+ [ lpFromLen>> ]
+ [ lpOverlapped>> ]
+ [ lpCompletionRoutine>> ]
+ } cleave WSARecvFrom socket-error* ; inline
+
+: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
+ [ lpBuffers>> WSABUF-buf swap memory>byte-array ]
+ [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
+
+M: winnt (receive) ( datagram -- packet addrspec )
+ [
+ <WSARecvFrom-args>
+ [ call-WSARecvFrom ]
+ [ wait-for-socket ]
+ [ parse-WSARecvFrom ]
+ tri
+ ] with-destructors ;
+
+TUPLE: WSASendTo-args port
+ s lpBuffers dwBufferCount lpNumberOfBytesSent
+ dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
+
+: make-send-buffer ( packet -- WSABUF )
+ "WSABUF" malloc-object &free
+ [ [ malloc-byte-array &free ] dip set-WSABUF-buf ]
+ [ [ length ] dip set-WSABUF-len ]
+ [ nip ]
+ 2tri ; inline
+
+: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
+ WSASendTo-args new
+ swap >>port
+ dup port>> handle>> handle>> >>s
+ swap make-sockaddr/size
+ [ malloc-byte-array &free ] dip
+ [ >>lpTo ] [ >>iToLen ] bi*
+ swap make-send-buffer >>lpBuffers
+ 1 >>dwBufferCount
+ 0 >>dwFlags
+ 0 <uint> >>lpNumberOfBytesSent
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-WSASendTo ( WSASendTo -- )
+ {
+ [ s>> ]
+ [ lpBuffers>> ]
+ [ dwBufferCount>> ]
+ [ lpNumberOfBytesSent>> ]
+ [ dwFlags>> ]
+ [ lpTo>> ]
+ [ iToLen>> ]
+ [ lpOverlapped>> ]
+ [ lpCompletionRoutine>> ]
+ } cleave WSASendTo socket-error* ; inline
+
+M: winnt (send) ( packet addrspec datagram -- )
+ [
+ <WSASendTo-args>
+ [ call-WSASendTo ]
+ [ wait-for-socket drop ]
+ bi
+ ] with-destructors ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+USING: kernel accessors io.sockets io.backend.windows io.backend\r
+windows.winsock system destructors alien.c-types ;\r
+IN: io.sockets.windows\r
+\r
+HOOK: WSASocket-flags io-backend ( -- DWORD )\r
+\r
+TUPLE: win32-socket < win32-file ;\r
+\r
+: <win32-socket> ( handle -- win32-socket )\r
+ win32-socket new-win32-handle ;\r
+\r
+M: win32-socket dispose ( stream -- )\r
+ handle>> closesocket drop ;\r
+\r
+: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
+ [ empty-sockaddr/size ] [ protocol-family ] bi\r
+ pick set-sockaddr-in-family ;\r
+\r
+: opened-socket ( handle -- win32-socket )\r
+ <win32-socket> |dispose dup add-completion ;\r
+\r
+: open-socket ( addrspec type -- win32-socket )\r
+ [ protocol-family ] dip\r
+ 0 f 0 WSASocket-flags WSASocket\r
+ dup socket-error\r
+ opened-socket ;\r
+\r
+M: object (get-local-address) ( socket addrspec -- sockaddr )\r
+ [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ getsockname socket-error ] 2keep drop ;\r
+\r
+M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
+ [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ getpeername socket-error ] 2keep drop ;\r
+\r
+: bind-socket ( win32-socket sockaddr len -- )\r
+ [ handle>> ] 2dip bind socket-error ;\r
+\r
+M: object ((client)) ( addrspec -- handle )\r
+ [ SOCK_STREAM open-socket ] keep\r
+ [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
+\r
+: server-socket ( addrspec type -- fd )\r
+ [ open-socket ] [ drop ] 2bi\r
+ [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
+\r
+! http://support.microsoft.com/kb/127144\r
+! NOTE: Possibly tweak this because of SYN flood attacks\r
+: listen-backlog ( -- n ) HEX: 7fffffff ; inline\r
+\r
+M: object (server) ( addrspec -- handle )\r
+ [\r
+ SOCK_STREAM server-socket\r
+ dup handle>> listen-backlog listen winsock-return-check\r
+ ] with-destructors ;\r
+\r
+M: windows (datagram) ( addrspec -- handle )\r
+ [ SOCK_DGRAM server-socket ] with-destructors ;\r
+\r
+M: windows addrinfo-error ( n -- )\r
+ winsock-return-check ;\r
{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
HELP: <duplex-stream>
-{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
+{ $values { "in" "an input stream" } { "out" "an output stream" } { "duplex-stream" duplex-stream } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
HELP: with-stream
{ $code "\"2 3 + .\" dup <input> write-object nl" }
} ;
-HELP: <input> ( string -- input )
+HELP: <input>
{ $values { "string" string } { "input" input } }
{ $description "Creates a new " { $link input } "." } ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax generic assocs kernel
-kernel.private math io.ports sequences strings sbufs threads
-unix vectors io.buffers io.backend io.encodings math.parser
-continuations system libc qualified namespaces make io.timeouts
-io.encodings.utf8 destructors accessors summary combinators
-locals unix.time fry io.unix.multiplexers ;
-QUALIFIED: io
-IN: io.unix.backend
-
-GENERIC: handle-fd ( handle -- fd )
-
-TUPLE: fd fd disposed ;
-
-: init-fd ( fd -- fd )
- [
- |dispose
- dup fd>> F_SETFL O_NONBLOCK fcntl io-error
- dup fd>> F_SETFD FD_CLOEXEC fcntl io-error
- ] with-destructors ;
-
-: <fd> ( n -- fd )
- #! We drop the error code rather than calling io-error,
- #! since on OS X 10.3, this operation fails from init-io
- #! when running the Factor.app (presumably because fd 0 and
- #! 1 are closed).
- f fd boa ;
-
-M: fd dispose
- dup disposed>> [ drop ] [
- [ cancel-operation ]
- [ t >>disposed drop ]
- [ fd>> close-file ]
- tri
- ] if ;
-
-M: fd handle-fd dup check-disposed fd>> ;
-
-M: fd cancel-operation ( fd -- )
- dup disposed>> [ drop ] [
- fd>>
- mx get-global
- [ remove-input-callbacks [ t swap resume-with ] each ]
- [ remove-output-callbacks [ t swap resume-with ] each ]
- 2bi
- ] if ;
-
-SYMBOL: +retry+ ! just try the operation again without blocking
-SYMBOL: +input+
-SYMBOL: +output+
-
-ERROR: io-timeout ;
-
-M: io-timeout summary drop "I/O operation timed out" ;
-
-: wait-for-fd ( handle event -- )
- dup +retry+ eq? [ 2drop ] [
- '[
- swap handle-fd mx get-global _ {
- { +input+ [ add-input-callback ] }
- { +output+ [ add-output-callback ] }
- } case
- ] "I/O" suspend nip [ io-timeout ] when
- ] if ;
-
-: wait-for-port ( port event -- )
- '[ handle>> _ wait-for-fd ] with-timeout ;
-
-! Some general stuff
-: file-mode OCT: 0666 ;
-
-! Readers
-: (refill) ( port -- n )
- [ handle>> ]
- [ buffer>> buffer-end ]
- [ buffer>> buffer-capacity ] tri read ;
-
-! Returns an event to wait for which will ensure completion of
-! this request
-GENERIC: refill ( port handle -- event/f )
-
-M: fd refill
- fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
- {
- { [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
- { [ err_no EINTR = ] [ 2drop +retry+ ] }
- { [ err_no EAGAIN = ] [ 2drop +input+ ] }
- [ (io-error) ]
- } cond ;
-
-M: unix (wait-to-read) ( port -- )
- dup
- dup handle>> dup check-disposed refill dup
- [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
-
-! Writers
-GENERIC: drain ( port handle -- event/f )
-
-M: fd drain
- fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write
- {
- { [ dup 0 >= ] [
- over buffer>> buffer-consume
- buffer>> buffer-empty? f +output+ ?
- ] }
- { [ err_no EINTR = ] [ 2drop +retry+ ] }
- { [ err_no EAGAIN = ] [ 2drop +output+ ] }
- [ (io-error) ]
- } cond ;
-
-M: unix (wait-to-write) ( port -- )
- dup
- dup handle>> dup check-disposed drain
- dup [ wait-for-port ] [ 2drop ] if ;
-
-M: unix io-multiplex ( ms/f -- )
- mx get-global wait-for-events ;
-
-! On Unix, you're not supposed to set stdin to non-blocking
-! because the fd might be shared with another process (either
-! parent or child). So what we do is have the VM start a thread
-! which pumps data from the real stdin to a pipe. We set the
-! pipe to non-blocking, and read from it instead of the real
-! stdin. Very crufty, but it will suffice until we get native
-! threading support at the language level.
-TUPLE: stdin control size data disposed ;
-
-M: stdin dispose*
- [
- [ control>> &dispose drop ]
- [ size>> &dispose drop ]
- [ data>> &dispose drop ]
- tri
- ] with-destructors ;
-
-: wait-for-stdin ( stdin -- n )
- [ control>> CHAR: X over io:stream-write1 io:stream-flush ]
- [ size>> "ssize_t" heap-size swap io:stream-read *int ]
- bi ;
-
-:: refill-stdin ( buffer stdin size -- )
- stdin data>> handle-fd buffer buffer-end size read
- dup 0 < [
- drop
- err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
- ] [
- size = [ "Error reading stdin pipe" throw ] unless
- size buffer n>buffer
- ] if ;
-
-M: stdin refill
- [ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
-
-: control-write-fd ( -- fd ) &: control_write *uint ;
-
-: size-read-fd ( -- fd ) &: size_read *uint ;
-
-: data-read-fd ( -- fd ) &: stdin_read *uint ;
-
-: <stdin> ( -- stdin )
- stdin new
- control-write-fd <fd> <output-port> >>control
- size-read-fd <fd> init-fd <input-port> >>size
- data-read-fd <fd> >>data ;
-
-M: unix (init-stdio) ( -- )
- <stdin> <input-port>
- 1 <fd> <output-port>
- 2 <fd> <output-port> ;
-
-! mx io-task for embedding an fd-based mx inside another mx
-TUPLE: mx-port < port mx ;
-
-: <mx-port> ( mx -- port )
- dup fd>> mx-port <port> swap >>mx ;
-
-: multiplexer-error ( n -- n )
- dup 0 < [
- err_no [ EAGAIN = ] [ EINTR = ] bi or
- [ drop 0 ] [ (io-error) ] if
- ] when ;
-
-: ?flag ( n mask symbol -- n )
- pick rot bitand 0 > [ , ] [ drop ] if ;
+++ /dev/null
-Non-blocking I/O and sockets on Unix-like systems
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces system kernel accessors assocs continuations
-unix io.backend io.unix.backend io.unix.multiplexers
-io.unix.multiplexers.kqueue ;
-IN: io.unix.bsd
-
-M: bsd init-io ( -- )
- <kqueue-mx> mx set-global ;
-
-! M: bsd (monitor) ( path recursive? mailbox -- )
-! swap [ "Recursive kqueue monitors not supported" throw ] when
-! <vnode-monitor> ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types kernel io.ports io.unix.backend
-bit-arrays sequences assocs struct-arrays math namespaces locals
-fry unix unix.linux.epoll unix.time ;
-IN: io.unix.epoll
-
-TUPLE: epoll-mx < mx events ;
-
-: max-events ( -- n )
- #! We read up to 256 events at a time. This is an arbitrary
- #! constant...
- 256 ; inline
-
-: <epoll-mx> ( -- mx )
- epoll-mx new-mx
- max-events epoll_create dup io-error >>fd
- max-events "epoll-event" <struct-array> >>events ;
-
-: make-event ( fd events -- event )
- "epoll-event" <c-object>
- [ set-epoll-event-events ] keep
- [ set-epoll-event-fd ] keep ;
-
-:: do-epoll-ctl ( fd mx what events -- )
- mx fd>> what fd fd events make-event epoll_ctl io-error ;
-
-: do-epoll-add ( fd mx events -- )
- EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ;
-
-: do-epoll-del ( fd mx events -- )
- EPOLL_CTL_DEL swap do-epoll-ctl ;
-
-M: epoll-mx add-input-callback ( thread fd mx -- )
- [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ;
-
-M: epoll-mx add-output-callback ( thread fd mx -- )
- [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ;
-
-M: epoll-mx remove-input-callbacks ( fd mx -- seq )
- 2dup reads>> key? [
- [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
- ] [ 2drop f ] if ;
-
-M: epoll-mx remove-output-callbacks ( fd mx -- seq )
- 2dup writes>> key? [
- [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi
- ] [ 2drop f ] if ;
-
-: wait-event ( mx us -- n )
- [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
- epoll_wait multiplexer-error ;
-
-: handle-event ( event mx -- )
- [ epoll-event-fd ] dip
- [ EPOLLIN EPOLLOUT bitor do-epoll-del ]
- [ input-available ] [ output-available ] 2tri ;
-
-: handle-events ( mx n -- )
- [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ;
-
-M: epoll-mx wait-for-events ( us mx -- )
- swap 60000000 or dupd wait-event handle-events ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien.syntax math io.unix.files system
-unix.stat accessors combinators calendar.unix ;
-IN: io.unix.files.bsd
-
-TUPLE: bsd-file-info < unix-file-info birth-time flags gen ;
-
-M: bsd new-file-info ( -- class ) bsd-file-info new ;
-
-M: bsd stat>file-info ( stat -- file-info )
- [ call-next-method ] keep
- {
- [ stat-st_flags >>flags ]
- [ stat-st_gen >>gen ]
- [
- stat-st_birthtimespec timespec>unix-time
- >>birth-time
- ]
- } cleave ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes help.markup help.syntax io.streams.string
-strings math calendar io.files ;
-IN: io.unix.files
-
-HELP: file-group-id
-{ $values
- { "path" "a pathname string" }
- { "gid" integer } }
-{ $description "Returns the group id for a given file." } ;
-
-HELP: file-group-name
-{ $values
- { "path" "a pathname string" }
- { "string" string } }
-{ $description "Returns the group name for a given file." } ;
-
-HELP: file-permissions
-{ $values
- { "path" "a pathname string" }
- { "n" integer } }
-{ $description "Returns the Unix file permissions for a given file." } ;
-
-HELP: file-username
-{ $values
- { "path" "a pathname string" }
- { "string" string } }
-{ $description "Returns the username for a given file." } ;
-
-HELP: file-user-id
-{ $values
- { "path" "a pathname string" }
- { "uid" integer } }
-{ $description "Returns the user id for a given file." } ;
-
-HELP: group-execute?
-{ $values
- { "obj" "a pathname string or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: group-read?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: group-write?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: other-execute?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: other-read?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: other-write?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: set-file-access-time
-{ $values
- { "path" "a pathname string" } { "timestamp" timestamp } }
-{ $description "Sets a file's last access timestamp." } ;
-
-HELP: set-file-group
-{ $values
- { "path" "a pathname string" } { "string/id" "a string or a group id" } }
-{ $description "Sets a file's group id from the given group id or group name." } ;
-
-HELP: set-file-ids
-{ $values
- { "path" "a pathname string" } { "uid" integer } { "gid" integer } }
-{ $description "Sets the user id and group id of a file with a single library call." } ;
-
-HELP: set-file-permissions
-{ $values
- { "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } }
-{ $description "Sets the file permissions for a given file with the supplied Unix permissions integer. Supplying an octal number with " { $link POSTPONE: OCT: } " is recommended." }
-{ $examples "Using the tradidional octal value:"
- { $unchecked-example "USING: io.unix.files kernel ;"
- "\"resource:license.txt\" OCT: 755 set-file-permissions"
- ""
- }
- "Higher-level, setting named bits:"
- { $unchecked-example "USING: io.unix.files kernel math.bitwise ;"
- "\"resource:license.txt\""
- "{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }"
- "flags set-file-permissions"
- "" }
-} ;
-
-HELP: set-file-times
-{ $values
- { "path" "a pathname string" } { "timestamps" "an array of two timestamps" } }
-{ $description "Sets the access and write timestamps for a file as provided in the input array. A value of " { $link f } " provided for either of the timestamps will not change that timestamp." } ;
-
-HELP: set-file-user
-{ $values
- { "path" "a pathname string" } { "string/id" "a string or a user id" } }
-{ $description "Sets a file's user id from the given user id or username." } ;
-
-HELP: set-file-modified-time
-{ $values
- { "path" "a pathname string" } { "timestamp" timestamp } }
-{ $description "Sets a file's last modified timestamp, or write timestamp." } ;
-
-HELP: set-gid
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "gid" } " bit of a file to true or false." } ;
-
-HELP: gid?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: set-group-execute
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "group execute" } " bit of a file to true or false." } ;
-
-HELP: set-group-read
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "group read" } " bit of a file to true or false." } ;
-
-HELP: set-group-write
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "group write" } " bit of a file to true or false." } ;
-
-HELP: set-other-execute
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
-
-HELP: set-other-read
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "other read" } " bit of a file to true or false." } ;
-
-HELP: set-other-write
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
-
-HELP: set-sticky
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "sticky" } " bit of a file to true or false." } ;
-
-HELP: sticky?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: set-uid
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "uid" } " bit of a file to true or false." } ;
-
-HELP: uid?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: set-user-execute
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "user execute" } " bit of a file to true or false." } ;
-
-HELP: set-user-read
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "user read" } " bit of a file to true or false." } ;
-
-HELP: set-user-write
-{ $values
- { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Sets the " { $snippet "user write" } " bit of a file to true or false." } ;
-
-HELP: user-execute?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: user-read?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-HELP: user-write?
-{ $values
- { "obj" "a pathname string, file-info object, or an integer" }
- { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
-
-ARTICLE: "unix-file-permissions" "Unix file permissions"
-"Reading all file permissions:"
-{ $subsection file-permissions }
-"Reading individual file permissions:"
-{ $subsection uid? }
-{ $subsection gid? }
-{ $subsection sticky? }
-{ $subsection user-read? }
-{ $subsection user-write? }
-{ $subsection user-execute? }
-{ $subsection group-read? }
-{ $subsection group-write? }
-{ $subsection group-execute? }
-{ $subsection other-read? }
-{ $subsection other-write? }
-{ $subsection other-execute? }
-"Writing all file permissions:"
-{ $subsection set-file-permissions }
-"Writing individual file permissions:"
-{ $subsection set-uid }
-{ $subsection set-gid }
-{ $subsection set-sticky }
-{ $subsection set-user-read }
-{ $subsection set-user-write }
-{ $subsection set-user-execute }
-{ $subsection set-group-read }
-{ $subsection set-group-write }
-{ $subsection set-group-execute }
-{ $subsection set-other-read }
-{ $subsection set-other-write }
-{ $subsection set-other-execute } ;
-
-ARTICLE: "unix-file-timestamps" "Unix file timestamps"
-"To read file times, use the accessors on the object returned by the " { $link file-info } " word." $nl
-"Setting multiple file times:"
-{ $subsection set-file-times }
-"Setting just the last access time:"
-{ $subsection set-file-access-time }
-"Setting just the last modified time:"
-{ $subsection set-file-modified-time } ;
-
-
-ARTICLE: "unix-file-ids" "Unix file user and group ids"
-"Reading file user data:"
-{ $subsection file-user-id }
-{ $subsection file-username }
-"Setting file user data:"
-{ $subsection set-file-user }
-"Reading file group data:"
-{ $subsection file-group-id }
-{ $subsection file-group-name }
-"Setting file group data:"
-{ $subsection set-file-group } ;
-
-
-ARTICLE: "io.unix.files" "Unix file attributes"
-"The " { $vocab-link "io.unix.files" } " vocabulary implements the Unix backend for opening files and provides a high-level way to set permissions, timestamps, and user and group ids for files."
-{ $subsection "unix-file-permissions" }
-{ $subsection "unix-file-timestamps" }
-{ $subsection "unix-file-ids" } ;
-
-ABOUT: "io.unix.files"
+++ /dev/null
-USING: tools.test io.files continuations kernel io.unix.files
-math.bitwise calendar accessors math.functions math unix.users
-unix.groups arrays sequences ;
-IN: io.unix.files.tests
-
-[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
-[ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test
-[ "/" ] [ "/etc/" parent-directory ] unit-test
-[ "/" ] [ "/etc" parent-directory ] unit-test
-[ "/" ] [ "/" parent-directory ] unit-test
-
-[ f ] [ "" root-directory? ] unit-test
-[ t ] [ "/" root-directory? ] unit-test
-[ t ] [ "//" root-directory? ] unit-test
-[ t ] [ "///////" root-directory? ] unit-test
-
-[ "/" ] [ "/" file-name ] unit-test
-[ "///" ] [ "///" file-name ] unit-test
-
-[ "/" ] [ "/" "../.." append-path ] unit-test
-[ "/" ] [ "/" "../../" append-path ] unit-test
-[ "/lib" ] [ "/" "../lib" append-path ] unit-test
-[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
-[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
-[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
-
-[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
-[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
-[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
-[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
-[ t ] [ "/foo" absolute-path? ] unit-test
-
-: test-file ( -- path )
- "permissions" temp-file ;
-
-: prepare-test-file ( -- )
- [ test-file delete-file ] ignore-errors
- test-file touch-file ;
-
-: perms ( -- n )
- test-file file-permissions OCT: 7777 mask ;
-
-prepare-test-file
-
-[ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test
-
-[ t ] [ test-file user-read? ] unit-test
-[ t ] [ test-file user-write? ] unit-test
-[ t ] [ test-file user-execute? ] unit-test
-[ t ] [ test-file group-read? ] unit-test
-[ t ] [ test-file group-write? ] unit-test
-[ t ] [ test-file group-execute? ] unit-test
-[ t ] [ test-file other-read? ] unit-test
-[ t ] [ test-file other-write? ] unit-test
-[ t ] [ test-file other-execute? ] unit-test
-
-[ t ] [ test-file f set-other-execute perms OCT: 776 = ] unit-test
-[ f ] [ test-file file-info other-execute? ] unit-test
-
-[ t ] [ test-file f set-other-write perms OCT: 774 = ] unit-test
-[ f ] [ test-file file-info other-write? ] unit-test
-
-[ t ] [ test-file f set-other-read perms OCT: 770 = ] unit-test
-[ f ] [ test-file file-info other-read? ] unit-test
-
-[ t ] [ test-file f set-group-execute perms OCT: 760 = ] unit-test
-[ f ] [ test-file file-info group-execute? ] unit-test
-
-[ t ] [ test-file f set-group-write perms OCT: 740 = ] unit-test
-[ f ] [ test-file file-info group-write? ] unit-test
-
-[ t ] [ test-file f set-group-read perms OCT: 700 = ] unit-test
-[ f ] [ test-file file-info group-read? ] unit-test
-
-[ t ] [ test-file f set-user-execute perms OCT: 600 = ] unit-test
-[ f ] [ test-file file-info other-execute? ] unit-test
-
-[ t ] [ test-file f set-user-write perms OCT: 400 = ] unit-test
-[ f ] [ test-file file-info other-write? ] unit-test
-
-[ t ] [ test-file f set-user-read perms OCT: 000 = ] unit-test
-[ f ] [ test-file file-info other-read? ] unit-test
-
-[ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
-
-prepare-test-file
-
-[ t ]
-[
- test-file now
- [ set-file-access-time ] 2keep
- [ file-info accessed>> ]
- [ [ [ truncate >integer ] change-second ] bi@ ] bi* =
-] unit-test
-
-[ t ]
-[
- test-file now
- [ set-file-modified-time ] 2keep
- [ file-info modified>> ]
- [ [ [ truncate >integer ] change-second ] bi@ ] bi* =
-] unit-test
-
-[ t ]
-[
- test-file now [ dup 2array set-file-times ] 2keep
- [ file-info [ modified>> ] [ accessed>> ] bi ] dip
- 3array
- [ [ truncate >integer ] change-second ] map all-equal?
-] unit-test
-
-[ ] [ test-file f now 2array set-file-times ] unit-test
-[ ] [ test-file now f 2array set-file-times ] unit-test
-[ ] [ test-file f f 2array set-file-times ] unit-test
-
-
-[ ] [ test-file real-username set-file-user ] unit-test
-[ ] [ test-file real-user-id set-file-user ] unit-test
-[ ] [ test-file real-group-name set-file-group ] unit-test
-[ ] [ test-file real-group-id set-file-group ] unit-test
-
-[ t ] [ test-file file-username real-username = ] unit-test
-[ t ] [ test-file file-group-name real-group-name = ] unit-test
-
-[ ]
-[ test-file real-user-id real-group-id set-file-ids ] unit-test
-
-[ ]
-[ test-file f real-group-id set-file-ids ] unit-test
-
-[ ]
-[ test-file real-user-id f set-file-ids ] unit-test
-
-[ ]
-[ test-file f f set-file-ids ] unit-test
-
-[ t ] [ OCT: 4000 uid? ] unit-test
-[ t ] [ OCT: 2000 gid? ] unit-test
-[ t ] [ OCT: 1000 sticky? ] unit-test
-[ t ] [ OCT: 400 user-read? ] unit-test
-[ t ] [ OCT: 200 user-write? ] unit-test
-[ t ] [ OCT: 100 user-execute? ] unit-test
-[ t ] [ OCT: 040 group-read? ] unit-test
-[ t ] [ OCT: 020 group-write? ] unit-test
-[ t ] [ OCT: 010 group-execute? ] unit-test
-[ t ] [ OCT: 004 other-read? ] unit-test
-[ t ] [ OCT: 002 other-write? ] unit-test
-[ t ] [ OCT: 001 other-execute? ] unit-test
-
-[ f ] [ 0 uid? ] unit-test
-[ f ] [ 0 gid? ] unit-test
-[ f ] [ 0 sticky? ] unit-test
-[ f ] [ 0 user-read? ] unit-test
-[ f ] [ 0 user-write? ] unit-test
-[ f ] [ 0 user-execute? ] unit-test
-[ f ] [ 0 group-read? ] unit-test
-[ f ] [ 0 group-write? ] unit-test
-[ f ] [ 0 group-execute? ] unit-test
-[ f ] [ 0 other-read? ] unit-test
-[ f ] [ 0 other-write? ] unit-test
-[ f ] [ 0 other-execute? ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend io.ports io.unix.backend io.files io
-unix unix.stat unix.time kernel math continuations
-math.bitwise byte-arrays alien combinators calendar
-io.encodings.binary accessors sequences strings system
-io.files.private destructors vocabs.loader calendar.unix
-unix.stat alien.c-types arrays unix.users unix.groups
-environment fry io.encodings.utf8 alien.strings
-combinators.short-circuit ;
-IN: io.unix.files
-
-M: unix cwd ( -- path )
- MAXPATHLEN [ <byte-array> ] keep getcwd
- [ (io-error) ] unless* ;
-
-M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
-
-: read-flags O_RDONLY ; inline
-
-: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
-
-M: unix (file-reader) ( path -- stream )
- open-read <fd> init-fd <input-port> ;
-
-: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
-
-: open-write ( path -- fd )
- write-flags file-mode open-file ;
-
-M: unix (file-writer) ( path -- stream )
- open-write <fd> init-fd <output-port> ;
-
-: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
-
-: open-append ( path -- fd )
- [
- append-flags file-mode open-file |dispose
- dup 0 SEEK_END lseek io-error
- ] with-destructors ;
-
-M: unix (file-appender) ( path -- stream )
- open-append <fd> init-fd <output-port> ;
-
-: touch-mode ( -- n )
- { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
-
-M: unix touch-file ( path -- )
- normalize-path
- dup exists? [ touch ] [
- touch-mode file-mode open-file close-file
- ] if ;
-
-M: unix move-file ( from to -- )
- [ normalize-path ] bi@ rename io-error ;
-
-M: unix delete-file ( path -- ) normalize-path unlink-file ;
-
-M: unix make-directory ( path -- )
- normalize-path OCT: 777 mkdir io-error ;
-
-M: unix delete-directory ( path -- )
- normalize-path rmdir io-error ;
-
-: (copy-file) ( from to -- )
- dup parent-directory make-directories
- binary <file-writer> [
- swap binary <file-reader> [
- swap stream-copy
- ] with-disposal
- ] with-disposal ;
-
-M: unix copy-file ( from to -- )
- [ normalize-path ] bi@
- [ (copy-file) ]
- [ swap file-info permissions>> chmod io-error ]
- 2bi ;
-
-TUPLE: unix-file-system-info < file-system-info
-block-size preferred-block-size
-blocks blocks-free blocks-available
-files files-free files-available
-name-max flags id ;
-
-HOOK: new-file-system-info os ( -- file-system-info )
-
-M: unix new-file-system-info ( -- ) unix-file-system-info new ;
-
-HOOK: file-system-statfs os ( path -- statfs )
-
-M: unix file-system-statfs drop f ;
-
-HOOK: file-system-statvfs os ( path -- statvfs )
-
-M: unix file-system-statvfs drop f ;
-
-HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
-
-M: unix statfs>file-system-info drop ;
-
-HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
-
-M: unix statvfs>file-system-info drop ;
-
-: file-system-calculations ( file-system-info -- file-system-info' )
- {
- [ dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space drop ]
- [ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ]
- [ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ]
- [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
- [ ]
- } cleave ;
-
-M: unix file-system-info
- normalize-path
- [ new-file-system-info ] dip
- [ file-system-statfs statfs>file-system-info ]
- [ file-system-statvfs statvfs>file-system-info ] bi
- file-system-calculations ;
-
-os {
- { linux [ "io.unix.files.linux" require ] }
- { macosx [ "io.unix.files.macosx" require ] }
- { freebsd [ "io.unix.files.freebsd" require ] }
- { netbsd [ "io.unix.files.netbsd" require ] }
- { openbsd [ "io.unix.files.openbsd" require ] }
-} case
-
-TUPLE: unix-file-info < file-info uid gid dev ino
-nlink rdev blocks blocksize ;
-
-HOOK: new-file-info os ( -- file-info )
-
-HOOK: stat>file-info os ( stat -- file-info )
-
-HOOK: stat>type os ( stat -- file-info )
-
-M: unix file-info ( path -- info )
- normalize-path file-status stat>file-info ;
-
-M: unix link-info ( path -- info )
- normalize-path link-status stat>file-info ;
-
-M: unix make-link ( path1 path2 -- )
- normalize-path symlink io-error ;
-
-M: unix read-link ( path -- path' )
- normalize-path read-symbolic-link ;
-
-M: unix new-file-info ( -- class ) unix-file-info new ;
-
-M: unix stat>file-info ( stat -- file-info )
- [ new-file-info ] dip
- {
- [ stat>type >>type ]
- [ stat-st_size >>size ]
- [ stat-st_mode >>permissions ]
- [ stat-st_ctimespec timespec>unix-time >>created ]
- [ stat-st_mtimespec timespec>unix-time >>modified ]
- [ stat-st_atimespec timespec>unix-time >>accessed ]
- [ stat-st_uid >>uid ]
- [ stat-st_gid >>gid ]
- [ stat-st_dev >>dev ]
- [ stat-st_ino >>ino ]
- [ stat-st_nlink >>nlink ]
- [ stat-st_rdev >>rdev ]
- [ stat-st_blocks >>blocks ]
- [ stat-st_blksize >>blocksize ]
- } cleave ;
-
-: n>file-type ( n -- type )
- S_IFMT bitand {
- { S_IFREG [ +regular-file+ ] }
- { S_IFDIR [ +directory+ ] }
- { S_IFCHR [ +character-device+ ] }
- { S_IFBLK [ +block-device+ ] }
- { S_IFIFO [ +fifo+ ] }
- { S_IFLNK [ +symbolic-link+ ] }
- { S_IFSOCK [ +socket+ ] }
- [ drop +unknown+ ]
- } case ;
-
-M: unix stat>type ( stat -- type )
- stat-st_mode n>file-type ;
-
-! Linux has no extra fields in its stat struct
-os {
- { macosx [ "io.unix.files.bsd" require ] }
- { netbsd [ "io.unix.files.bsd" require ] }
- { openbsd [ "io.unix.files.bsd" require ] }
- { freebsd [ "io.unix.files.bsd" require ] }
- { linux [ ] }
-} case
-
-: with-unix-directory ( path quot -- )
- [ opendir dup [ (io-error) ] unless ] dip
- dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
-
-: find-next-file ( DIR* -- byte-array )
- "dirent" <c-object>
- f <void*>
- [ readdir_r 0 = [ (io-error) ] unless ] 2keep
- *void* [ drop f ] unless ;
-
-M: unix >directory-entry ( byte-array -- directory-entry )
- [ dirent-d_name utf8 alien>string ]
- [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
-
-M: unix (directory-entries) ( path -- seq )
- [
- '[ _ find-next-file dup ]
- [ >directory-entry ]
- [ drop ] produce
- ] with-unix-directory ;
-
-<PRIVATE
-
-: stat-mode ( path -- mode )
- normalize-path file-status stat-st_mode ;
-
-: chmod-set-bit ( path mask ? -- )
- [ dup stat-mode ] 2dip
- [ bitor ] [ unmask ] if chmod io-error ;
-
-GENERIC# file-mode? 1 ( obj mask -- ? )
-
-M: integer file-mode? mask? ;
-M: string file-mode? [ stat-mode ] dip mask? ;
-M: file-info file-mode? [ permissions>> ] dip mask? ;
-
-PRIVATE>
-
-: ch>file-type ( ch -- type )
- {
- { CHAR: b [ +block-device+ ] }
- { CHAR: c [ +character-device+ ] }
- { CHAR: d [ +directory+ ] }
- { CHAR: l [ +symbolic-link+ ] }
- { CHAR: s [ +socket+ ] }
- { CHAR: p [ +fifo+ ] }
- { CHAR: - [ +regular-file+ ] }
- [ drop +unknown+ ]
- } case ;
-
-: file-type>ch ( type -- string )
- {
- { +block-device+ [ CHAR: b ] }
- { +character-device+ [ CHAR: c ] }
- { +directory+ [ CHAR: d ] }
- { +symbolic-link+ [ CHAR: l ] }
- { +socket+ [ CHAR: s ] }
- { +fifo+ [ CHAR: p ] }
- { +regular-file+ [ CHAR: - ] }
- [ drop CHAR: - ]
- } case ;
-
-: UID OCT: 0004000 ; inline
-: GID OCT: 0002000 ; inline
-: STICKY OCT: 0001000 ; inline
-: USER-ALL OCT: 0000700 ; inline
-: USER-READ OCT: 0000400 ; inline
-: USER-WRITE OCT: 0000200 ; inline
-: USER-EXECUTE OCT: 0000100 ; inline
-: GROUP-ALL OCT: 0000070 ; inline
-: GROUP-READ OCT: 0000040 ; inline
-: GROUP-WRITE OCT: 0000020 ; inline
-: GROUP-EXECUTE OCT: 0000010 ; inline
-: OTHER-ALL OCT: 0000007 ; inline
-: OTHER-READ OCT: 0000004 ; inline
-: OTHER-WRITE OCT: 0000002 ; inline
-: OTHER-EXECUTE OCT: 0000001 ; inline
-
-: uid? ( obj -- ? ) UID file-mode? ;
-: gid? ( obj -- ? ) GID file-mode? ;
-: sticky? ( obj -- ? ) STICKY file-mode? ;
-: user-read? ( obj -- ? ) USER-READ file-mode? ;
-: user-write? ( obj -- ? ) USER-WRITE file-mode? ;
-: user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
-: group-read? ( obj -- ? ) GROUP-READ file-mode? ;
-: group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
-: group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
-: other-read? ( obj -- ? ) OTHER-READ file-mode? ;
-: other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
-: other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
-
-: any-read? ( obj -- ? )
- { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
-
-: any-write? ( obj -- ? )
- { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
-
-: any-execute? ( obj -- ? )
- { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
-
-: set-uid ( path ? -- ) UID swap chmod-set-bit ;
-: set-gid ( path ? -- ) GID swap chmod-set-bit ;
-: set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
-: set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
-: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
-: set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
-: set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
-: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
-: set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
-: set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
-: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
-: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
-
-: set-file-permissions ( path n -- )
- [ normalize-path ] dip chmod io-error ;
-
-: file-permissions ( path -- n )
- normalize-path file-info permissions>> ;
-
-<PRIVATE
-
-: make-timeval-array ( array -- byte-array )
- [ [ "timeval" <c-object> ] unless* ] map concat ;
-
-: timestamp>timeval ( timestamp -- timeval )
- unix-1970 time- duration>microseconds make-timeval ;
-
-: timestamps>byte-array ( timestamps -- byte-array )
- [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
-
-PRIVATE>
-
-: set-file-times ( path timestamps -- )
- #! set access, write
- [ normalize-path ] dip
- timestamps>byte-array utimes io-error ;
-
-: set-file-access-time ( path timestamp -- )
- f 2array set-file-times ;
-
-: set-file-modified-time ( path timestamp -- )
- f swap 2array set-file-times ;
-
-: set-file-ids ( path uid gid -- )
- [ normalize-path ] 2dip
- [ [ -1 ] unless* ] bi@ chown io-error ;
-
-GENERIC: set-file-user ( path string/id -- )
-
-GENERIC: set-file-group ( path string/id -- )
-
-M: integer set-file-user ( path uid -- )
- f set-file-ids ;
-
-M: string set-file-user ( path string -- )
- user-id f set-file-ids ;
-
-M: integer set-file-group ( path gid -- )
- f swap set-file-ids ;
-
-M: string set-file-group ( path string -- )
- group-id
- f swap set-file-ids ;
-
-: file-user-id ( path -- uid )
- normalize-path file-info uid>> ;
-
-: file-username ( path -- string )
- file-user-id username ;
-
-: file-group-id ( path -- gid )
- normalize-path file-info gid>> ;
-
-: file-group-name ( path -- string )
- file-group-id group-name ;
-
-M: unix home "HOME" os-env ;
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.syntax combinators
-io.backend io.files io.unix.files kernel math system unix
-unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
-sequences grouping alien.strings io.encodings.utf8
-specialized-arrays.direct.uint arrays ;
-IN: io.unix.files.freebsd
-
-TUPLE: freebsd-file-system-info < unix-file-system-info
-version io-size owner syncreads syncwrites asyncreads asyncwrites ;
-
-M: freebsd new-file-system-info freebsd-file-system-info new ;
-
-M: freebsd file-system-statfs ( path -- byte-array )
- "statfs" <c-object> tuck statfs io-error ;
-
-M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
- {
- [ statfs-f_version >>version ]
- [ statfs-f_type >>type ]
- [ statfs-f_flags >>flags ]
- [ statfs-f_bsize >>block-size ]
- [ statfs-f_iosize >>io-size ]
- [ statfs-f_blocks >>blocks ]
- [ statfs-f_bfree >>blocks-free ]
- [ statfs-f_bavail >>blocks-available ]
- [ statfs-f_files >>files ]
- [ statfs-f_ffree >>files-free ]
- [ statfs-f_syncwrites >>syncwrites ]
- [ statfs-f_asyncwrites >>asyncwrites ]
- [ statfs-f_syncreads >>syncreads ]
- [ statfs-f_asyncreads >>asyncreads ]
- [ statfs-f_namemax >>name-max ]
- [ statfs-f_owner >>owner ]
- [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs-f_fstypename utf8 alien>string >>type ]
- [ statfs-f_mntfromname utf8 alien>string >>device-name ]
- [ statfs-f_mntonname utf8 alien>string >>mount-point ]
- } cleave ;
-
-M: freebsd file-system-statvfs ( path -- byte-array )
- "statvfs" <c-object> tuck statvfs io-error ;
-
-M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
- {
- [ statvfs-f_favail >>files-available ]
- [ statvfs-f_frsize >>preferred-block-size ]
- } cleave ;
-
-M: freebsd file-systems ( -- array )
- f 0 0 getfsstat dup io-error
- "statfs" <c-array> dup dup length 0 getfsstat io-error
- "statfs" heap-size group
- [ statfs-f_mntonname alien>native-string file-system-info ] map ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.syntax combinators csv
-io.backend io.encodings.utf8 io.files io.streams.string
-io.unix.files kernel math.order namespaces sequences sorting
-system unix unix.statfs.linux unix.statvfs.linux
-specialized-arrays.direct.uint arrays ;
-IN: io.unix.files.linux
-
-TUPLE: linux-file-system-info < unix-file-system-info
-namelen ;
-
-M: linux new-file-system-info linux-file-system-info new ;
-
-M: linux file-system-statfs ( path -- byte-array )
- "statfs64" <c-object> tuck statfs64 io-error ;
-
-M: linux statfs>file-system-info ( struct -- statfs )
- {
- [ statfs64-f_type >>type ]
- [ statfs64-f_bsize >>block-size ]
- [ statfs64-f_blocks >>blocks ]
- [ statfs64-f_bfree >>blocks-free ]
- [ statfs64-f_bavail >>blocks-available ]
- [ statfs64-f_files >>files ]
- [ statfs64-f_ffree >>files-free ]
- [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs64-f_namelen >>namelen ]
- [ statfs64-f_frsize >>preferred-block-size ]
- ! [ statfs64-f_spare >>spare ]
- } cleave ;
-
-M: linux file-system-statvfs ( path -- byte-array )
- "statvfs64" <c-object> tuck statvfs64 io-error ;
-
-M: linux statvfs>file-system-info ( struct -- statfs )
- {
- [ statvfs64-f_flag >>flags ]
- [ statvfs64-f_namemax >>name-max ]
- } cleave ;
-
-TUPLE: mtab-entry file-system-name mount-point type options
-frequency pass-number ;
-
-: mtab-csv>mtab-entry ( csv -- mtab-entry )
- [ mtab-entry new ] dip
- {
- [ first >>file-system-name ]
- [ second >>mount-point ]
- [ third >>type ]
- [ fourth <string-reader> csv first >>options ]
- [ 4 swap nth >>frequency ]
- [ 5 swap nth >>pass-number ]
- } cleave ;
-
-: parse-mtab ( -- array )
- [
- "/etc/mtab" utf8 <file-reader>
- CHAR: \s delimiter set csv
- ] with-scope
- [ mtab-csv>mtab-entry ] map ;
-
-M: linux file-systems
- parse-mtab [
- [ mount-point>> file-system-info ] keep
- {
- [ file-system-name>> >>device-name ]
- [ mount-point>> >>mount-point ]
- [ type>> >>type ]
- } cleave
- ] map ;
-
-ERROR: file-system-not-found ;
-
-M: linux file-system-info ( path -- )
- normalize-path
- [
- [ new-file-system-info ] dip
- [ file-system-statfs statfs>file-system-info ]
- [ file-system-statvfs statvfs>file-system-info ] bi
- file-system-calculations
- ] keep
-
- parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
- [ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
- {
- [ file-system-name>> >>device-name drop ]
- [ mount-point>> >>mount-point drop ]
- [ type>> >>type ]
- } 2cleave ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.strings combinators
-grouping io.encodings.utf8 io.files kernel math sequences
-system unix io.unix.files specialized-arrays.direct.uint arrays
-unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx ;
-IN: io.unix.files.macosx
-
-TUPLE: macosx-file-system-info < unix-file-system-info
-io-size owner type-id filesystem-subtype ;
-
-M: macosx file-systems ( -- array )
- f <void*> dup 0 getmntinfo64 dup io-error
- [ *void* ] dip
- "statfs64" heap-size [ * memory>byte-array ] keep group
- [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
- ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
-
-M: macosx new-file-system-info macosx-file-system-info new ;
-
-M: macosx file-system-statfs ( normalized-path -- statfs )
- "statfs64" <c-object> tuck statfs64 io-error ;
-
-M: macosx file-system-statvfs ( normalized-path -- statvfs )
- "statvfs" <c-object> tuck statvfs io-error ;
-
-M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
- {
- [ statfs64-f_bsize >>block-size ]
- [ statfs64-f_iosize >>io-size ]
- [ statfs64-f_blocks >>blocks ]
- [ statfs64-f_bfree >>blocks-free ]
- [ statfs64-f_bavail >>blocks-available ]
- [ statfs64-f_files >>files ]
- [ statfs64-f_ffree >>files-free ]
- [ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs64-f_owner >>owner ]
- [ statfs64-f_type >>type-id ]
- [ statfs64-f_flags >>flags ]
- [ statfs64-f_fssubtype >>filesystem-subtype ]
- [ statfs64-f_fstypename utf8 alien>string >>type ]
- [ statfs64-f_mntonname utf8 alien>string >>mount-point ]
- [ statfs64-f_mntfromname utf8 alien>string >>device-name ]
- } cleave ;
-
-M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
- {
- [ statvfs-f_frsize >>preferred-block-size ]
- [ statvfs-f_favail >>files-available ]
- [ statvfs-f_namemax >>name-max ]
- } cleave ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel unix.stat math unix
-combinators system io.backend accessors alien.c-types
-io.encodings.utf8 alien.strings unix.types io.unix.files
-io.files unix.statvfs.netbsd unix.getfsstat.netbsd arrays
-grouping sequences io.encodings.utf8 specialized-arrays.direct.uint ;
-IN: io.unix.files.netbsd
-
-TUPLE: netbsd-file-system-info < unix-file-system-info
-blocks-reserved files-reserved
-owner io-size sync-reads sync-writes async-reads async-writes
-idx mount-from ;
-
-M: netbsd new-file-system-info netbsd-file-system-info new ;
-
-M: netbsd file-system-statvfs
- "statvfs" <c-object> tuck statvfs io-error ;
-
-M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
- {
- [ statvfs-f_flag >>flags ]
- [ statvfs-f_bsize >>block-size ]
- [ statvfs-f_frsize >>preferred-block-size ]
- [ statvfs-f_iosize >>io-size ]
- [ statvfs-f_blocks >>blocks ]
- [ statvfs-f_bfree >>blocks-free ]
- [ statvfs-f_bavail >>blocks-available ]
- [ statvfs-f_bresvd >>blocks-reserved ]
- [ statvfs-f_files >>files ]
- [ statvfs-f_ffree >>files-free ]
- [ statvfs-f_favail >>files-available ]
- [ statvfs-f_fresvd >>files-reserved ]
- [ statvfs-f_syncreads >>sync-reads ]
- [ statvfs-f_syncwrites >>sync-writes ]
- [ statvfs-f_asyncreads >>async-reads ]
- [ statvfs-f_asyncwrites >>async-writes ]
- [ statvfs-f_fsidx 2 <direct-uint-array> >array >>idx ]
- [ statvfs-f_fsid >>id ]
- [ statvfs-f_namemax >>name-max ]
- [ statvfs-f_owner >>owner ]
- ! [ statvfs-f_spare >>spare ]
- [ statvfs-f_fstypename utf8 alien>string >>type ]
- [ statvfs-f_mntonname utf8 alien>string >>mount-point ]
- [ statvfs-f_mntfromname utf8 alien>string >>device-name ]
- } cleave ;
-
-M: netbsd file-systems ( -- array )
- f 0 0 getvfsstat dup io-error
- "statvfs" <c-array> dup dup length 0 getvfsstat io-error
- "statvfs" heap-size group
- [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.strings alien.syntax
-combinators io.backend io.files io.unix.files kernel math
-sequences system unix unix.getfsstat.openbsd grouping
-unix.statfs.openbsd unix.statvfs.openbsd unix.types
-specialized-arrays.direct.uint arrays ;
-IN: io.unix.files.openbsd
-
-TUPLE: freebsd-file-system-info < unix-file-system-info
-io-size sync-writes sync-reads async-writes async-reads
-owner ;
-
-M: openbsd new-file-system-info freebsd-file-system-info new ;
-
-M: openbsd file-system-statfs
- "statfs" <c-object> tuck statfs io-error ;
-
-M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
- {
- [ statfs-f_flags >>flags ]
- [ statfs-f_bsize >>block-size ]
- [ statfs-f_iosize >>io-size ]
- [ statfs-f_blocks >>blocks ]
- [ statfs-f_bfree >>blocks-free ]
- [ statfs-f_bavail >>blocks-available ]
- [ statfs-f_files >>files ]
- [ statfs-f_ffree >>files-free ]
- [ statfs-f_favail >>files-available ]
- [ statfs-f_syncwrites >>sync-writes ]
- [ statfs-f_syncreads >>sync-reads ]
- [ statfs-f_asyncwrites >>async-writes ]
- [ statfs-f_asyncreads >>async-reads ]
- [ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
- [ statfs-f_namemax >>name-max ]
- [ statfs-f_owner >>owner ]
- ! [ statfs-f_spare >>spare ]
- [ statfs-f_fstypename alien>native-string >>type ]
- [ statfs-f_mntonname alien>native-string >>mount-point ]
- [ statfs-f_mntfromname alien>native-string >>device-name ]
- } cleave ;
-
-M: openbsd file-system-statvfs ( normalized-path -- statvfs )
- "statvfs" <c-object> tuck statvfs io-error ;
-
-M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
- {
- [ statvfs-f_frsize >>preferred-block-size ]
- } cleave ;
-
-M: openbsd file-systems ( -- seq )
- f 0 0 getfsstat dup io-error
- "statfs" <c-array> dup dup length 0 getfsstat io-error
- "statfs" heap-size group
- [ statfs-f_mntonname alien>native-string file-system-info ] map ;
+++ /dev/null
-unportable
+++ /dev/null
-Implementation of reading and writing files on Unix-like systems
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.ports io.unix.backend math.bitwise
-unix system io.files.unique ;
-IN: io.unix.files.unique
-
-: open-unique-flags ( -- flags )
- { O_RDWR O_CREAT O_EXCL } flags ;
-
-M: unix touch-unique-file ( path -- )
- open-unique-flags file-mode open-file close-file ;
-
-M: unix temporary-path ( -- path ) "/tmp" ;
+++ /dev/null
-USING: io.unix.bsd io.backend system ;
-
-freebsd set-io-backend
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types combinators io.unix.backend
-kernel math.bitwise sequences struct-arrays unix unix.kqueue
-unix.time assocs ;
-IN: io.unix.kqueue
-
-TUPLE: kqueue-mx < mx events ;
-
-: max-events ( -- n )
- #! We read up to 256 events at a time. This is an arbitrary
- #! constant...
- 256 ; inline
-
-: <kqueue-mx> ( -- mx )
- kqueue-mx new-mx
- kqueue dup io-error >>fd
- max-events "kevent" <struct-array> >>events ;
-
-: make-kevent ( fd filter flags -- event )
- "kevent" <c-object>
- [ set-kevent-flags ] keep
- [ set-kevent-filter ] keep
- [ set-kevent-ident ] keep ;
-
-: register-kevent ( kevent mx -- )
- fd>> swap 1 f 0 f kevent io-error ;
-
-M: kqueue-mx add-input-callback ( thread fd mx -- )
- [ call-next-method ] [
- [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
- register-kevent
- ] 2bi ;
-
-M: kqueue-mx add-output-callback ( thread fd mx -- )
- [ call-next-method ] [
- [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
- register-kevent
- ] 2bi ;
-
-M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
- 2dup reads>> key? [
- [ call-next-method ] [
- [ EVFILT_READ EV_DELETE make-kevent ] dip
- register-kevent
- ] 2bi
- ] [ 2drop f ] if ;
-
-M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
- 2dup writes>> key? [
- [
- [ EVFILT_WRITE EV_DELETE make-kevent ] dip
- register-kevent
- ] [ call-next-method ] 2bi
- ] [ 2drop f ] if ;
-
-: wait-kevent ( mx timespec -- n )
- [
- [ fd>> f 0 ]
- [ events>> [ underlying>> ] [ length ] bi ] bi
- ] dip kevent multiplexer-error ;
-
-: handle-kevent ( mx kevent -- )
- [ kevent-ident swap ] [ kevent-filter ] bi {
- { EVFILT_READ [ input-available ] }
- { EVFILT_WRITE [ output-available ] }
- } case ;
-
-: handle-kevents ( mx n -- )
- [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
-
-M: kqueue-mx wait-for-events ( us mx -- )
- swap dup [ make-timespec ] when
- dupd wait-kevent handle-kevents ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: io.unix.launcher.tests
-USING: io.files tools.test io.launcher arrays io namespaces
-continuations math io.encodings.binary io.encodings.ascii
-accessors kernel sequences io.encodings.utf8 destructors
-io.streams.duplex locals concurrency.promises threads
-unix.process ;
-
-[ ] [
- [ "launcher-test-1" temp-file delete-file ] ignore-errors
-] unit-test
-
-[ ] [
- "touch"
- "launcher-test-1" temp-file
- 2array
- try-process
-] unit-test
-
-[ t ] [ "launcher-test-1" temp-file exists? ] unit-test
-
-[ ] [
- [ "launcher-test-1" temp-file delete-file ] ignore-errors
-] unit-test
-
-[ ] [
- <process>
- "echo Hello" >>command
- "launcher-test-1" temp-file >>stdout
- try-process
-] unit-test
-
-[ "Hello\n" ] [
- "cat"
- "launcher-test-1" temp-file
- 2array
- ascii <process-reader> contents
-] unit-test
-
-[ ] [
- [ "launcher-test-1" temp-file delete-file ] ignore-errors
-] unit-test
-
-[ ] [
- <process>
- "cat" >>command
- +closed+ >>stdin
- "launcher-test-1" temp-file >>stdout
- try-process
-] unit-test
-
-[ f ] [
- "cat"
- "launcher-test-1" temp-file
- 2array
- ascii <process-reader> contents
-] unit-test
-
-[ ] [
- 2 [
- "launcher-test-1" temp-file binary <file-appender> [
- <process>
- swap >>stdout
- "echo Hello" >>command
- try-process
- ] with-disposal
- ] times
-] unit-test
-
-[ "Hello\nHello\n" ] [
- "cat"
- "launcher-test-1" temp-file
- 2array
- ascii <process-reader> contents
-] unit-test
-
-[ t ] [
- <process>
- "env" >>command
- { { "A" "B" } } >>environment
- ascii <process-reader> lines
- "A=B" swap member?
-] unit-test
-
-[ { "A=B" } ] [
- <process>
- "env" >>command
- { { "A" "B" } } >>environment
- +replace-environment+ >>environment-mode
- ascii <process-reader> lines
-] unit-test
-
-[ "hi\n" ] [
- temp-directory [
- [ "aloha" delete-file ] ignore-errors
- <process>
- { "echo" "hi" } >>command
- "aloha" >>stdout
- try-process
- ] with-directory
- temp-directory "aloha" append-path
- utf8 file-contents
-] unit-test
-
-[ "append-test" temp-file delete-file ] ignore-errors
-
-[ "hi\nhi\n" ] [
- 2 [
- <process>
- "echo hi" >>command
- "append-test" temp-file <appender> >>stdout
- try-process
- ] times
- "append-test" temp-file utf8 file-contents
-] unit-test
-
-[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
-
-[ "Hello world.\n" ] [
- "cat" utf8 <process-stream> [
- "Hello world.\n" write
- output-stream get dispose
- input-stream get contents
- ] with-stream
-] unit-test
-
-! Killed processes were exiting with code 0 on FreeBSD
-[ f ] [
- [let | p [ <promise> ]
- s [ <promise> ] |
- [
- "sleep 1000" run-detached
- [ p fulfill ] [ wait-for-process s fulfill ] bi
- ] in-thread
-
- p ?promise handle>> 9 kill drop
- s ?promise 0 =
- ]
-] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces math system sequences
-continuations arrays assocs combinators alien.c-types strings
-threads accessors environment
-io io.backend io.launcher io.ports io.files
-io.files.private io.unix.files io.unix.backend
-io.unix.launcher.parser
-unix unix.process ;
-IN: io.unix.launcher
-
-! Search unix first
-USE: unix
-
-: get-arguments ( process -- seq )
- command>> dup string? [ tokenize-command ] when ;
-
-: assoc>env ( assoc -- env )
- [ "=" glue ] { } assoc>map ;
-
-: setup-priority ( process -- process )
- dup priority>> [
- H{
- { +lowest-priority+ 20 }
- { +low-priority+ 10 }
- { +normal-priority+ 0 }
- { +high-priority+ -10 }
- { +highest-priority+ -20 }
- { +realtime-priority+ -20 }
- } at set-priority
- ] when* ;
-
-: reset-fd ( fd -- )
- [ F_SETFL 0 fcntl io-error ] [ F_SETFD 0 fcntl io-error ] bi ;
-
-: redirect-fd ( oldfd fd -- )
- 2dup = [ 2drop ] [ dup2 io-error ] if ;
-
-: redirect-file ( obj mode fd -- )
- [ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ;
-
-: redirect-file-append ( obj mode fd -- )
- [ drop path>> normalize-path open-append ] dip redirect-fd ;
-
-: redirect-closed ( obj mode fd -- )
- [ drop "/dev/null" ] 2dip redirect-file ;
-
-: redirect ( obj mode fd -- )
- {
- { [ pick not ] [ 3drop ] }
- { [ pick string? ] [ redirect-file ] }
- { [ pick appender? ] [ redirect-file-append ] }
- { [ pick +closed+ eq? ] [ redirect-closed ] }
- { [ pick fd? ] [ [ drop fd>> dup reset-fd ] dip redirect-fd ] }
- [ [ underlying-handle ] 2dip redirect ]
- } cond ;
-
-: ?closed ( obj -- obj' )
- dup +closed+ eq? [ drop "/dev/null" ] when ;
-
-: setup-redirection ( process -- process )
- dup stdin>> ?closed read-flags 0 redirect
- dup stdout>> ?closed write-flags 1 redirect
- dup stderr>> dup +stdout+ eq? [
- drop 1 2 dup2 io-error
- ] [
- ?closed write-flags 2 redirect
- ] if ;
-
-: setup-environment ( process -- process )
- dup pass-environment? [
- dup get-environment set-os-envs
- ] when ;
-
-: spawn-process ( process -- * )
- [ setup-priority ] [ 250 _exit ] recover
- [ setup-redirection ] [ 251 _exit ] recover
- [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover
- [ setup-environment ] [ 253 _exit ] recover
- [ get-arguments exec-args-with-path ] [ 254 _exit ] recover
- 255 _exit ;
-
-M: unix current-process-handle ( -- handle ) getpid ;
-
-M: unix run-process* ( process -- pid )
- [ spawn-process ] curry [ ] with-fork ;
-
-M: unix kill-process* ( pid -- )
- SIGTERM kill io-error ;
-
-: find-process ( handle -- process )
- processes get swap [ nip swap handle>> = ] curry
- assoc-find 2drop ;
-
-TUPLE: signal n ;
-
-: code>status ( code -- obj )
- dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
-
-M: unix wait-for-processes ( -- ? )
- -1 0 <int> tuck WNOHANG waitpid
- dup 0 <= [
- 2drop t
- ] [
- find-process dup
- [ swap *int code>status notify-exit f ] [ 2drop f ] if
- ] if ;
+++ /dev/null
-IN: io.unix.launcher.parser.tests
-USING: io.unix.launcher.parser tools.test ;
-
-[ "" tokenize-command ] must-fail
-[ " " tokenize-command ] must-fail
-[ V{ "a" } ] [ "a" tokenize-command ] unit-test
-[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test
-[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test
-[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test
-[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
-[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
-[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
-[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
-[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
-[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
-[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
-[ "'abc def' \"hey" tokenize-command ] must-fail
-[ "'abc def" tokenize-command ] must-fail
-[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
-
-[
- V{
- "Hello world.app/Contents/MacOS/hello-ui"
- "-i=boot.macosx-ppc.image"
- "-include= math compiler ui"
- "-deploy-vocab=hello-ui"
- "-output-image=Hello world.app/Contents/Resources/hello-ui.image"
- "-no-stack-traces"
- "-no-user-init"
- }
-] [
- "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: peg peg.parsers kernel sequences strings words ;
-IN: io.unix.launcher.parser
-
-! Our command line parser. Supported syntax:
-! foo bar baz -- simple tokens
-! foo\ bar -- escaping the space
-! 'foo bar' -- quotation
-! "foo bar" -- quotation
-: 'escaped-char' ( -- parser )
- "\\" token any-char 2seq [ second ] action ;
-
-: 'quoted-char' ( delimiter -- parser' )
- 'escaped-char'
- swap [ member? not ] curry satisfy
- 2choice ; inline
-
-: 'quoted' ( delimiter -- parser )
- dup 'quoted-char' repeat0 swap dup surrounded-by ;
-
-: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
-
-: 'argument' ( -- parser )
- "\"" 'quoted'
- "'" 'quoted'
- 'unquoted' 3choice
- [ >string ] action ;
-
-PEG: tokenize-command ( command -- ast/f )
- 'argument' " " token repeat1 list-of
- " " token repeat0 tuck pack
- just ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel system namespaces io.backend io.unix.backend
-io.unix.multiplexers io.unix.multiplexers.epoll ;
-IN: io.unix.linux
-
-M: linux init-io ( -- )
- <epoll-mx> mx set-global ;
-
-linux set-io-backend
+++ /dev/null
-IN: io.unix.linux.monitors.tests
-USING: io.monitors tools.test io.files system sequences
-continuations namespaces concurrency.count-downs kernel io
-threads calendar prettyprint destructors io.timeouts ;
-
-! On Linux, a notification on the directory itself would report an invalid
-! path name
-[
- [ ] [ "monitor-test-self" temp-file make-directories ] unit-test
-
- ! Non-recursive
- [ ] [ "monitor-test-self" temp-file f <monitor> "m" set ] unit-test
- [ ] [ 3 seconds "m" get set-timeout ] unit-test
-
- [ ] [ "monitor-test-self" temp-file touch-file ] unit-test
-
- [ t ] [
- "m" get next-change drop
- [ "" = ] [ "monitor-test-self" temp-file = ] bi or
- ] unit-test
-
- [ ] [ "m" get dispose ] unit-test
-
- ! Recursive
- [ ] [ "monitor-test-self" temp-file t <monitor> "m" set ] unit-test
- [ ] [ 3 seconds "m" get set-timeout ] unit-test
-
- [ ] [ "monitor-test-self" temp-file touch-file ] unit-test
-
- [ t ] [
- "m" get next-change drop
- [ "" = ] [ "monitor-test-self" temp-file = ] bi or
- ] unit-test
-
- [ ] [ "m" get dispose ] unit-test
-] with-monitors
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.backend io.monitors io.monitors.recursive
-io.files io.buffers io.monitors io.ports io.timeouts
-io.unix.backend io.encodings.utf8 unix.linux.inotify assocs
-namespaces make threads continuations init math math.bitwise
-sets alien alien.strings alien.c-types vocabs.loader accessors
-system hashtables destructors unix ;
-IN: io.unix.linux.monitors
-
-SYMBOL: watches
-
-SYMBOL: inotify
-
-TUPLE: linux-monitor < monitor wd inotify watches disposed ;
-
-: <linux-monitor> ( wd path mailbox -- monitor )
- linux-monitor new-monitor
- inotify get >>inotify
- watches get >>watches
- swap >>wd ;
-
-: wd>monitor ( wd -- monitor ) watches get at ;
-
-: <inotify> ( -- port/f )
- inotify_init dup 0 < [ drop f ] [ <fd> init-fd <input-port> ] if ;
-
-: inotify-fd ( -- fd ) inotify get handle>> handle-fd ;
-
-: check-existing ( wd -- )
- watches get key? [
- "Cannot open multiple monitors for the same file" throw
- ] when ;
-
-: (add-watch) ( path mask -- wd )
- inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
-
-: add-watch ( path mask mailbox -- monitor )
- [ [ (normalize-path) ] dip [ (add-watch) ] [ drop ] 2bi ] dip
- <linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
-
-: check-inotify ( -- )
- inotify get [
- "Calling <monitor> outside with-monitors" throw
- ] unless ;
-
-M: linux (monitor) ( path recursive? mailbox -- monitor )
- swap [
- <recursive-monitor>
- ] [
- check-inotify
- IN_CHANGE_EVENTS swap add-watch
- ] if ;
-
-M: linux-monitor dispose* ( monitor -- )
- [ [ wd>> ] [ watches>> ] bi delete-at ]
- [
- dup inotify>> disposed>> [ drop ] [
- [ inotify>> handle>> handle-fd ] [ wd>> ] bi
- inotify_rm_watch io-error
- ] if
- ] bi ;
-
-: ignore-flags? ( mask -- ? )
- {
- IN_DELETE_SELF
- IN_MOVE_SELF
- IN_UNMOUNT
- IN_Q_OVERFLOW
- IN_IGNORED
- } flags bitand 0 > ;
-
-: parse-action ( mask -- changed )
- [
- IN_CREATE +add-file+ ?flag
- IN_DELETE +remove-file+ ?flag
- IN_MODIFY +modify-file+ ?flag
- IN_ATTRIB +modify-file+ ?flag
- IN_MOVED_FROM +rename-file-old+ ?flag
- IN_MOVED_TO +rename-file-new+ ?flag
- drop
- ] { } make prune ;
-
-: parse-event-name ( event -- name )
- dup inotify-event-len zero?
- [ drop "" ] [ inotify-event-name utf8 alien>string ] if ;
-
-: parse-file-notify ( buffer -- path changed )
- dup inotify-event-mask ignore-flags? [
- drop f f
- ] [
- [ parse-event-name ] [ inotify-event-mask parse-action ] bi
- ] if ;
-
-: events-exhausted? ( i buffer -- ? )
- fill>> >= ;
-
-: inotify-event@ ( i buffer -- alien )
- ptr>> <displaced-alien> ;
-
-: next-event ( i buffer -- i buffer )
- 2dup inotify-event@
- inotify-event-len "inotify-event" heap-size +
- swap [ + ] dip ;
-
-: parse-file-notifications ( i buffer -- )
- 2dup events-exhausted? [ 2drop ] [
- 2dup inotify-event@ dup inotify-event-wd wd>monitor
- [ parse-file-notify ] dip queue-change
- next-event parse-file-notifications
- ] if ;
-
-: inotify-read-loop ( port -- )
- dup check-disposed
- dup wait-to-read drop
- 0 over buffer>> parse-file-notifications
- 0 over buffer>> buffer-reset
- inotify-read-loop ;
-
-: inotify-read-thread ( port -- )
- [ inotify-read-loop ] curry ignore-errors ;
-
-M: linux init-monitors
- H{ } clone watches set
- <inotify> [
- [ inotify set ]
- [
- [ inotify-read-thread ] curry
- "Linux monitor thread" spawn drop
- ] bi
- ] [
- "Linux kernel version is too old" throw
- ] if* ;
-
-M: linux dispose-monitors
- inotify get dispose ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend system namespaces io.unix.multiplexers
-io.unix.multiplexers.run-loop ;
-IN: io.unix.macosx
-
-M: macosx init-io ( -- )
- <run-loop-mx> mx set-global ;
-
-macosx set-io-backend
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend io.monitors
-core-foundation.fsevents continuations kernel sequences
-namespaces arrays system locals accessors destructors fry ;
-IN: io.unix.macosx.monitors
-
-TUPLE: macosx-monitor < monitor handle ;
-
-: enqueue-notifications ( triples monitor -- )
- '[ first { +modify-file+ } _ queue-change ] each ;
-
-M:: macosx (monitor) ( path recursive? mailbox -- monitor )
- [let | path [ path normalize-path ] |
- path mailbox macosx-monitor new-monitor
- dup [ enqueue-notifications ] curry
- path 1array 0 0 <event-stream> >>handle
- ] ;
-
-M: macosx-monitor dispose
- handle>> dispose ;
-
-macosx set-io-backend
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien io io.files kernel math math.bitwise system unix
-io.unix.backend io.ports io.mmap destructors locals accessors ;
-IN: io.unix.mmap
-
-: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
-
-:: mmap-open ( path length prot flags -- alien fd )
- [
- f length prot flags
- path open-r/w |dispose
- [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
- ] with-destructors ;
-
-M: unix (mapped-file)
- { PROT_READ PROT_WRITE } flags
- { MAP_FILE MAP_SHARED } flags
- mmap-open ;
-
-M: unix close-mapped-file ( mmap -- )
- [ [ address>> ] [ length>> ] bi munmap io-error ]
- [ handle>> close-file ]
- bi ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types kernel destructors bit-arrays
-sequences assocs struct-arrays math namespaces locals fry unix
-unix.linux.epoll unix.time io.ports io.unix.backend
-io.unix.multiplexers ;
-IN: io.unix.multiplexers.epoll
-
-TUPLE: epoll-mx < mx events ;
-
-: max-events ( -- n )
- #! We read up to 256 events at a time. This is an arbitrary
- #! constant...
- 256 ; inline
-
-: <epoll-mx> ( -- mx )
- epoll-mx new-mx
- max-events epoll_create dup io-error >>fd
- max-events "epoll-event" <struct-array> >>events ;
-
-M: epoll-mx dispose fd>> close-file ;
-
-: make-event ( fd events -- event )
- "epoll-event" <c-object>
- [ set-epoll-event-events ] keep
- [ set-epoll-event-fd ] keep ;
-
-:: do-epoll-ctl ( fd mx what events -- )
- mx fd>> what fd fd events make-event epoll_ctl io-error ;
-
-: do-epoll-add ( fd mx events -- )
- EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ;
-
-: do-epoll-del ( fd mx events -- )
- EPOLL_CTL_DEL swap do-epoll-ctl ;
-
-M: epoll-mx add-input-callback ( thread fd mx -- )
- [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ;
-
-M: epoll-mx add-output-callback ( thread fd mx -- )
- [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ;
-
-M: epoll-mx remove-input-callbacks ( fd mx -- seq )
- 2dup reads>> key? [
- [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
- ] [ 2drop f ] if ;
-
-M: epoll-mx remove-output-callbacks ( fd mx -- seq )
- 2dup writes>> key? [
- [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi
- ] [ 2drop f ] if ;
-
-: wait-event ( mx us -- n )
- [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
- epoll_wait multiplexer-error ;
-
-: handle-event ( event mx -- )
- [ epoll-event-fd ] dip
- [ EPOLLIN EPOLLOUT bitor do-epoll-del ]
- [ input-available ] [ output-available ] 2tri ;
-
-: handle-events ( mx n -- )
- [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ;
-
-M: epoll-mx wait-for-events ( us mx -- )
- swap 60000000 or dupd wait-event handle-events ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types combinators destructors
-io.unix.backend kernel math.bitwise sequences struct-arrays unix
-unix.kqueue unix.time assocs io.unix.multiplexers ;
-IN: io.unix.multiplexers.kqueue
-
-TUPLE: kqueue-mx < mx events ;
-
-: max-events ( -- n )
- #! We read up to 256 events at a time. This is an arbitrary
- #! constant...
- 256 ; inline
-
-: <kqueue-mx> ( -- mx )
- kqueue-mx new-mx
- kqueue dup io-error >>fd
- max-events "kevent" <struct-array> >>events ;
-
-M: kqueue-mx dispose fd>> close-file ;
-
-: make-kevent ( fd filter flags -- event )
- "kevent" <c-object>
- [ set-kevent-flags ] keep
- [ set-kevent-filter ] keep
- [ set-kevent-ident ] keep ;
-
-: register-kevent ( kevent mx -- )
- fd>> swap 1 f 0 f kevent io-error ;
-
-M: kqueue-mx add-input-callback ( thread fd mx -- )
- [ call-next-method ] [
- [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
- register-kevent
- ] 2bi ;
-
-M: kqueue-mx add-output-callback ( thread fd mx -- )
- [ call-next-method ] [
- [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
- register-kevent
- ] 2bi ;
-
-M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
- 2dup reads>> key? [
- [ call-next-method ] [
- [ EVFILT_READ EV_DELETE make-kevent ] dip
- register-kevent
- ] 2bi
- ] [ 2drop f ] if ;
-
-M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
- 2dup writes>> key? [
- [
- [ EVFILT_WRITE EV_DELETE make-kevent ] dip
- register-kevent
- ] [ call-next-method ] 2bi
- ] [ 2drop f ] if ;
-
-: wait-kevent ( mx timespec -- n )
- [
- [ fd>> f 0 ]
- [ events>> [ underlying>> ] [ length ] bi ] bi
- ] dip kevent multiplexer-error ;
-
-: handle-kevent ( mx kevent -- )
- [ kevent-ident swap ] [ kevent-filter ] bi {
- { EVFILT_READ [ input-available ] }
- { EVFILT_WRITE [ output-available ] }
- } case ;
-
-: handle-kevents ( mx n -- )
- [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
-
-M: kqueue-mx wait-for-events ( us mx -- )
- swap dup [ make-timespec ] when
- dupd wait-kevent handle-kevents ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs sequences threads ;
-IN: io.unix.multiplexers
-
-TUPLE: mx fd reads writes ;
-
-: new-mx ( class -- obj )
- new
- H{ } clone >>reads
- H{ } clone >>writes ; inline
-
-GENERIC: add-input-callback ( thread fd mx -- )
-
-M: mx add-input-callback reads>> push-at ;
-
-GENERIC: add-output-callback ( thread fd mx -- )
-
-M: mx add-output-callback writes>> push-at ;
-
-GENERIC: remove-input-callbacks ( fd mx -- callbacks )
-
-M: mx remove-input-callbacks reads>> delete-at* drop ;
-
-GENERIC: remove-output-callbacks ( fd mx -- callbacks )
-
-M: mx remove-output-callbacks writes>> delete-at* drop ;
-
-GENERIC: wait-for-events ( ms mx -- )
-
-: input-available ( fd mx -- )
- reads>> delete-at* drop [ resume ] each ;
-
-: output-available ( fd mx -- )
- writes>> delete-at* drop [ resume ] each ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays namespaces math accessors alien locals
-destructors system threads io.unix.multiplexers
-io.unix.multiplexers.kqueue core-foundation
-core-foundation.run-loop ;
-IN: io.unix.multiplexers.run-loop
-
-TUPLE: run-loop-mx kqueue-mx ;
-
-: file-descriptor-callback ( -- callback )
- "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
- "cdecl" [
- 3drop
- 0 mx get kqueue-mx>> wait-for-events
- reset-run-loop
- yield
- ] alien-callback ;
-
-: <run-loop-mx> ( -- mx )
- [
- <kqueue-mx> |dispose
- dup fd>> file-descriptor-callback add-fd-to-run-loop
- run-loop-mx boa
- ] with-destructors ;
-
-M: run-loop-mx add-input-callback kqueue-mx>> add-input-callback ;
-M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ;
-M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ;
-M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ;
-
-M: run-loop-mx wait-for-events ( us mx -- )
- swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel bit-arrays sequences assocs unix
-math namespaces accessors math.order locals unix.time fry
-io.ports io.unix.backend io.unix.multiplexers ;
-IN: io.unix.multiplexers.select
-
-TUPLE: select-mx < mx read-fdset write-fdset ;
-
-! Factor's bit-arrays are an array of bytes, OS X expects
-! FD_SET to be an array of cells, so we have to account for
-! byte order differences on big endian platforms
-: munge ( i -- i' )
- little-endian? [ BIN: 11000 bitxor ] unless ; inline
-
-: <select-mx> ( -- mx )
- select-mx new-mx
- FD_SETSIZE 8 * <bit-array> >>read-fdset
- FD_SETSIZE 8 * <bit-array> >>write-fdset ;
-
-: clear-nth ( n seq -- ? )
- [ nth ] [ [ f ] 2dip set-nth ] 2bi ;
-
-:: check-fd ( fd fdset mx quot -- )
- fd munge fdset clear-nth [ fd mx quot call ] when ; inline
-
-: check-fdset ( fds fdset mx quot -- )
- [ check-fd ] 3curry each ; inline
-
-: init-fdset ( fds fdset -- )
- '[ t swap munge _ set-nth ] each ;
-
-: read-fdset/tasks ( mx -- seq fdset )
- [ reads>> keys ] [ read-fdset>> ] bi ;
-
-: write-fdset/tasks ( mx -- seq fdset )
- [ writes>> keys ] [ write-fdset>> ] bi ;
-
-: max-fd ( assoc -- n )
- dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
-
-: num-fds ( mx -- n )
- [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
-
-: init-fdsets ( mx -- nfds read write except )
- [ num-fds ]
- [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
- [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
- f ;
-
-M:: select-mx wait-for-events ( us mx -- )
- mx
- [ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
- [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
- [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
- tri ;
+++ /dev/null
-unportable
+++ /dev/null
-USING: io.unix.bsd io.backend system ;
-
-netbsd set-io-backend
+++ /dev/null
-unportable
+++ /dev/null
-USING: io.unix.bsd io.backend system ;
-
-openbsd set-io-backend
+++ /dev/null
-unportable
+++ /dev/null
-USING: tools.test io.pipes io.unix.pipes io.encodings.utf8
-io.encodings io namespaces sequences ;
-IN: io.unix.pipes.tests
-
-[ { 0 0 } ] [ { "ls" "grep ." } run-pipeline ] unit-test
-
-[ { 0 f 0 } ] [
- {
- "ls"
- [
- input-stream [ utf8 <decoder> ] change
- output-stream [ utf8 <encoder> ] change
- input-stream get lines reverse [ print ] each f
- ]
- "grep ."
- } run-pipeline
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel unix math sequences qualified
-io.unix.backend io.ports specialized-arrays.int accessors ;
-IN: io.unix.pipes
-QUALIFIED: io.pipes
-
-M: unix io.pipes:(pipe) ( -- pair )
- 2 <int-array>
- [ underlying>> pipe io-error ]
- [ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel io.ports io.unix.backend
-bit-arrays sequences assocs unix math namespaces
-accessors math.order locals unix.time fry ;
-IN: io.unix.select
-
-TUPLE: select-mx < mx read-fdset write-fdset ;
-
-! Factor's bit-arrays are an array of bytes, OS X expects
-! FD_SET to be an array of cells, so we have to account for
-! byte order differences on big endian platforms
-: munge ( i -- i' )
- little-endian? [ BIN: 11000 bitxor ] unless ; inline
-
-: <select-mx> ( -- mx )
- select-mx new-mx
- FD_SETSIZE 8 * <bit-array> >>read-fdset
- FD_SETSIZE 8 * <bit-array> >>write-fdset ;
-
-: clear-nth ( n seq -- ? )
- [ nth ] [ [ f ] 2dip set-nth ] 2bi ;
-
-:: check-fd ( fd fdset mx quot -- )
- fd munge fdset clear-nth [ fd mx quot call ] when ; inline
-
-: check-fdset ( fds fdset mx quot -- )
- [ check-fd ] 3curry each ; inline
-
-: init-fdset ( fds fdset -- )
- '[ t swap munge _ set-nth ] each ;
-
-: read-fdset/tasks ( mx -- seq fdset )
- [ reads>> keys ] [ read-fdset>> ] bi ;
-
-: write-fdset/tasks ( mx -- seq fdset )
- [ writes>> keys ] [ write-fdset>> ] bi ;
-
-: max-fd ( assoc -- n )
- dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
-
-: num-fds ( mx -- n )
- [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
-
-: init-fdsets ( mx -- nfds read write except )
- [ num-fds ]
- [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
- [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
- f ;
-
-M:: select-mx wait-for-events ( us mx -- )
- mx
- [ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
- [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
- [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
- tri ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.sockets.secure kernel ;
-IN: io.unix.sockets.secure.debug
-
-: with-test-context ( quot -- )
- <secure-config>
- "resource:basis/openssl/test/server.pem" >>key-file
- "resource:basis/openssl/test/dh1024.pem" >>dh-file
- "password" >>password
- swap with-secure-context ; inline
+++ /dev/null
-IN: io.sockets.secure.tests
-USING: accessors kernel namespaces io io.sockets
-io.sockets.secure io.encodings.ascii io.streams.duplex
-io.unix.backend classes words destructors threads tools.test
-concurrency.promises byte-arrays locals calendar io.timeouts
-io.unix.sockets.secure.debug ;
-
-\ <secure-config> must-infer
-{ 1 0 } [ [ ] with-secure-context ] must-infer-as
-
-[ ] [ <promise> "port" set ] unit-test
-
-:: server-test ( quot -- )
- [
- [
- "127.0.0.1" 0 <inet4> <secure> ascii <server> [
- dup addr>> addrspec>> port>> "port" get fulfill
- accept [
- quot call
- ] curry with-stream
- ] with-disposal
- ] with-test-context
- ] "SSL server test" spawn drop ;
-
-: client-test ( -- string )
- <secure-config> [
- "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
- ] with-secure-context ;
-
-[ ] [ [ class name>> write ] server-test ] unit-test
-
-[ "secure" ] [ client-test ] unit-test
-
-! Now, see what happens if the server closes the connection prematurely
-[ ] [ <promise> "port" set ] unit-test
-
-[ ] [
- [
- drop
- "hello" write flush
- input-stream get stream>> handle>> f >>connected drop
- ] server-test
-] unit-test
-
-[ client-test ] [ premature-close? ] must-fail-with
-
-! Now, try validating the certificate. This should fail because its
-! actually an invalid certificate
-[ ] [ <promise> "port" set ] unit-test
-
-[ ] [ [ drop "hi" write ] server-test ] unit-test
-
-[
- <secure-config> [
- "localhost" "port" get ?promise <inet> <secure> ascii
- <client> drop dispose
- ] with-secure-context
-] [ certificate-verify-error? ] must-fail-with
-
-! Client-side handshake timeout
-[ ] [ <promise> "port" set ] unit-test
-
-[ ] [
- [
- "127.0.0.1" 0 <inet4> ascii <server> [
- dup addr>> port>> "port" get fulfill
- accept drop 1 minutes sleep dispose
- ] with-disposal
- ] "Silly server" spawn drop
-] unit-test
-
-[
- 1 seconds secure-socket-timeout [
- client-test
- ] with-variable
-] [ io-timeout? ] must-fail-with
-
-! Server-side handshake timeout
-[ ] [ <promise> "port" set ] unit-test
-
-[ ] [
- [
- "127.0.0.1" "port" get ?promise
- <inet4> ascii <client> drop 1 minutes sleep dispose
- ] "Silly client" spawn drop
-] unit-test
-
-[
- 1 seconds secure-socket-timeout [
- [
- "127.0.0.1" 0 <inet4> <secure> ascii <server> [
- dup addr>> addrspec>> port>> "port" get fulfill
- accept drop dup stream-read1 drop dispose
- ] with-disposal
- ] with-test-context
- ] with-variable
-] [ io-timeout? ] must-fail-with
-
-! Client socket shutdown timeout
-
-! Until I sort out two-stage handshaking, I can't do much here
-[
- [ ] [ <promise> "port" set ] unit-test
-
- [ ] [
- [
- [
- "127.0.0.1" 0 <inet4> <secure> ascii <server> [
- dup addr>> addrspec>> port>> "port" get fulfill
- accept drop 1 minutes sleep dispose
- ] with-disposal
- ] with-test-context
- ] "Silly server" spawn drop
- ] unit-test
-
- [
- 1 seconds secure-socket-timeout [
- <secure-config> [
- "127.0.0.1" "port" get ?promise <inet4> <secure>
- ascii <client> drop dispose
- ] with-secure-context
- ] with-variable
- ] [ io-timeout? ] must-fail-with
-
- ! Server socket shutdown timeout
- [ ] [ <promise> "port" set ] unit-test
-
- [ ] [
- [
- [
- "127.0.0.1" "port" get ?promise
- <inet4> <secure> ascii <client> drop 1 minutes sleep dispose
- ] with-test-context
- ] "Silly client" spawn drop
- ] unit-test
-
- [
- 1 seconds secure-socket-timeout [
- [
- "127.0.0.1" 0 <inet4> <secure> ascii <server> [
- dup addr>> addrspec>> port>> "port" get fulfill
- accept drop dispose
- ] with-disposal
- ] with-test-context
- ] with-variable
- ] [ io-timeout? ] must-fail-with
-] drop
+++ /dev/null
-! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors unix byte-arrays kernel sequences
-namespaces math math.order combinators init alien alien.c-types
-alien.strings libc continuations destructors openssl
-openssl.libcrypto openssl.libssl io io.files io.ports
-io.unix.backend io.unix.sockets io.encodings.ascii io.buffers
-io.sockets io.sockets.secure io.sockets.secure.openssl
-io.timeouts system summary fry ;
-IN: io.unix.sockets.secure
-
-M: ssl-handle handle-fd file>> handle-fd ;
-
-: syscall-error ( r -- * )
- ERR_get_error dup zero? [
- drop
- {
- { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
- { 0 [ premature-close ] }
- } case
- ] [ nip (ssl-error) ] if ;
-
-: check-accept-response ( handle r -- event )
- over handle>> over SSL_get_error
- {
- { SSL_ERROR_NONE [ 2drop f ] }
- { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
- { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] }
- { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
- { SSL_ERROR_SYSCALL [ syscall-error ] }
- { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
- { SSL_ERROR_SSL [ (ssl-error) ] }
- } case ;
-
-: do-ssl-accept ( ssl-handle -- )
- dup dup handle>> SSL_accept check-accept-response dup
- [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ;
-
-: maybe-handshake ( ssl-handle -- )
- dup connected>> [ drop ] [
- t >>connected
- [ do-ssl-accept ] with-timeout
- ] if ;
-
-: check-response ( port r -- port r n )
- over handle>> handle>> over SSL_get_error ; inline
-
-! Input ports
-: check-read-response ( port r -- event )
- check-response
- {
- { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
- { SSL_ERROR_ZERO_RETURN [ 2drop f ] }
- { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
- { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
- { SSL_ERROR_SYSCALL [ syscall-error ] }
- { SSL_ERROR_SSL [ (ssl-error) ] }
- } case ;
-
-M: ssl-handle refill
- dup maybe-handshake
- handle>> ! ssl
- over buffer>>
- [ buffer-end ] ! buf
- [ buffer-capacity ] bi ! len
- SSL_read
- check-read-response ;
-
-! Output ports
-: check-write-response ( port r -- event )
- check-response
- {
- { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
- { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
- { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
- { SSL_ERROR_SYSCALL [ syscall-error ] }
- { SSL_ERROR_SSL [ (ssl-error) ] }
- } case ;
-
-M: ssl-handle drain
- dup maybe-handshake
- handle>> ! ssl
- over buffer>>
- [ buffer@ ] ! buf
- [ buffer-length ] bi ! len
- SSL_write
- check-write-response ;
-
-M: ssl-handle cancel-operation
- file>> cancel-operation ;
-
-M: ssl-handle timeout
- drop secure-socket-timeout get ;
-
-! Client sockets
-: <ssl-socket> ( fd -- ssl )
- [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
- [ handle>> swap dup SSL_set_bio ] keep ;
-
-M: secure ((client)) ( addrspec -- handle )
- addrspec>> ((client)) <ssl-socket> ;
-
-M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
-
-M: secure (get-local-address) addrspec>> (get-local-address) ;
-
-: check-connect-response ( ssl-handle r -- event )
- over handle>> over SSL_get_error
- {
- { SSL_ERROR_NONE [ 2drop f ] }
- { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
- { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
- { SSL_ERROR_SYSCALL [ syscall-error ] }
- { SSL_ERROR_SSL [ (ssl-error) ] }
- } case ;
-
-: do-ssl-connect ( ssl-handle -- )
- dup dup handle>> SSL_connect check-connect-response dup
- [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ;
-
-: resume-session ( ssl-handle ssl-session -- )
- [ [ handle>> ] dip SSL_set_session ssl-error ]
- [ drop do-ssl-connect ]
- 2bi ;
-
-: begin-session ( ssl-handle addrspec -- )
- [ drop do-ssl-connect ]
- [ [ handle>> SSL_get1_session ] dip save-session ]
- 2bi ;
-
-: secure-connection ( client-out addrspec -- )
- [ handle>> ] dip
- [
- '[
- _ dup get-session
- [ resume-session ] [ begin-session ] ?if
- ] with-timeout
- ] [ drop t >>connected drop ] 2bi ;
-
-M: secure establish-connection ( client-out remote -- )
- addrspec>> [ establish-connection ] [ secure-connection ] 2bi ;
-
-M: secure (server) addrspec>> (server) ;
-
-M: secure (accept)
- [
- addrspec>> (accept) [ |dispose <ssl-socket> ] dip
- ] with-destructors ;
-
-: check-shutdown-response ( handle r -- event )
- #! We don't do two-step shutdown here because I couldn't
- #! figure out how to do it with non-blocking BIOs. Also, it
- #! seems that SSL_shutdown always returns 0 -- this sounds
- #! like a bug
- over handle>> over SSL_get_error
- {
- { SSL_ERROR_NONE [ 2drop f ] }
- { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
- { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
- { SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] }
- { SSL_ERROR_SSL [ (ssl-error) ] }
- } case ;
-
-: (shutdown) ( handle -- )
- dup dup handle>> SSL_shutdown check-shutdown-response
- dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ;
-
-M: ssl-handle shutdown
- dup connected>> [
- f >>connected [ (shutdown) ] with-timeout
- ] [ drop ] if ;
-
-: check-buffer ( port -- port )
- dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ;
-
-: input/output-ports ( -- input output )
- input-stream output-stream
- [ get underlying-port check-buffer ] bi@
- 2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ;
-
-: make-input/output-secure ( input output -- )
- dup handle>> fd? [ upgrade-on-non-socket ] unless
- [ <ssl-socket> ] change-handle
- handle>> >>handle drop ;
-
-: (send-secure-handshake) ( output -- )
- remote-address get [ upgrade-on-non-socket ] unless*
- secure-connection ;
-
-M: openssl send-secure-handshake
- input/output-ports
- [ make-input/output-secure ] keep
- [ (send-secure-handshake) ] keep
- remote-address get dup inet? [
- host>> swap handle>> check-certificate
- ] [ 2drop ] if ;
-
-M: openssl accept-secure-handshake
- input/output-ports
- make-input/output-secure ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings generic kernel math
-namespaces threads sequences byte-arrays io.ports
-io.binary io.unix.backend io.streams.duplex
-io.backend io.ports io.files io.files.private
-io.encodings.utf8 math.parser continuations libc combinators
-system accessors qualified destructors unix locals init ;
-
-EXCLUDE: io => read write close ;
-EXCLUDE: io.sockets => accept ;
-
-IN: io.unix.sockets
-
-: socket-fd ( domain type -- fd )
- 0 socket dup io-error <fd> init-fd |dispose ;
-
-: set-socket-option ( fd level opt -- )
- [ handle-fd ] 2dip 1 <int> "int" heap-size setsockopt io-error ;
-
-M: unix addrinfo-error ( n -- )
- dup zero? [ drop ] [ gai_strerror throw ] if ;
-
-! Client sockets - TCP and Unix domain
-M: object (get-local-address) ( handle remote -- sockaddr )
- [ handle-fd ] dip empty-sockaddr/size <int>
- [ getsockname io-error ] 2keep drop ;
-
-M: object (get-remote-address) ( handle local -- sockaddr )
- [ handle-fd ] dip empty-sockaddr/size <int>
- [ getpeername io-error ] 2keep drop ;
-
-: init-client-socket ( fd -- )
- SOL_SOCKET SO_OOBINLINE set-socket-option ;
-
-: wait-to-connect ( port -- )
- dup handle>> handle-fd f 0 write
- {
- { [ 0 = ] [ drop ] }
- { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
- { [ err_no EINTR = ] [ wait-to-connect ] }
- [ (io-error) ]
- } cond ;
-
-M: object establish-connection ( client-out remote -- )
- [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
- {
- { [ 0 = ] [ drop ] }
- { [ err_no EINPROGRESS = ] [
- [ +output+ wait-for-port ] [ wait-to-connect ] bi
- ] }
- [ (io-error) ]
- } cond ;
-
-M: object ((client)) ( addrspec -- fd )
- protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
-
-! Server sockets - TCP and Unix domain
-: init-server-socket ( fd -- )
- SOL_SOCKET SO_REUSEADDR set-socket-option ;
-
-: server-socket-fd ( addrspec type -- fd )
- [ dup protocol-family ] dip socket-fd
- dup init-server-socket
- dup handle-fd rot make-sockaddr/size bind io-error ;
-
-M: object (server) ( addrspec -- handle )
- [
- SOCK_STREAM server-socket-fd
- dup handle-fd 128 listen io-error
- ] with-destructors ;
-
-: do-accept ( server addrspec -- fd sockaddr )
- [ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
- [ accept ] 2keep drop ; inline
-
-M: object (accept) ( server addrspec -- fd sockaddr )
- 2dup do-accept
- {
- { [ over 0 >= ] [ [ 2nip <fd> init-fd ] dip ] }
- { [ err_no EINTR = ] [ 2drop (accept) ] }
- { [ err_no EAGAIN = ] [
- 2drop
- [ drop +input+ wait-for-port ]
- [ (accept) ]
- 2bi
- ] }
- [ (io-error) ]
- } cond ;
-
-! Datagram sockets - UDP and Unix domain
-M: unix (datagram)
- [ SOCK_DGRAM server-socket-fd ] with-destructors ;
-
-SYMBOL: receive-buffer
-
-: packet-size 65536 ; inline
-
-[ packet-size malloc receive-buffer set-global ] "io.unix.sockets" add-init-hook
-
-:: do-receive ( port -- packet sockaddr )
- port addr>> empty-sockaddr/size [| sockaddr len |
- port handle>> handle-fd ! s
- receive-buffer get-global ! buf
- packet-size ! nbytes
- 0 ! flags
- sockaddr ! from
- len <int> ! fromlen
- recvfrom dup 0 >= [
- receive-buffer get-global swap memory>byte-array sockaddr
- ] [
- drop f f
- ] if
- ] call ;
-
-M: unix (receive) ( datagram -- packet sockaddr )
- dup do-receive dup [ [ drop ] 2dip ] [
- 2drop [ +input+ wait-for-port ] [ (receive) ] bi
- ] if ;
-
-:: do-send ( packet sockaddr len socket datagram -- )
- socket handle-fd packet dup length 0 sockaddr len sendto
- 0 < [
- err_no EINTR = [
- packet sockaddr len socket datagram do-send
- ] [
- err_no EAGAIN = [
- datagram +output+ wait-for-port
- packet sockaddr len socket datagram do-send
- ] [
- (io-error)
- ] if
- ] if
- ] when ;
-
-M: unix (send) ( packet addrspec datagram -- )
- [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ;
-
-! Unix domain sockets
-M: local protocol-family drop PF_UNIX ;
-
-M: local sockaddr-size drop "sockaddr-un" heap-size ;
-
-M: local empty-sockaddr drop "sockaddr-un" <c-object> ;
-
-M: local make-sockaddr
- path>> (normalize-path)
- dup length 1 + max-un-path > [ "Path too long" throw ] when
- "sockaddr-un" <c-object>
- AF_UNIX over set-sockaddr-un-family
- dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
-
-M: local parse-sockaddr
- drop
- sockaddr-un-path utf8 alien>string <local> ;
+++ /dev/null
-Implementation of TCP/IP and UDP/IP sockets on Unix-like systems
+++ /dev/null
-unportable
+++ /dev/null
-Non-blocking I/O and sockets on Unix-like systems
+++ /dev/null
-unportable
+++ /dev/null
-USING: io.files io.sockets io kernel threads
-namespaces tools.test continuations strings byte-arrays
-sequences prettyprint system io.encodings.binary io.encodings.ascii
-io.streams.duplex destructors make ;
-IN: io.unix.tests
-
-! Unix domain stream sockets
-: socket-server "unix-domain-socket-test" temp-file ;
-
-[
- [ socket-server delete-file ] ignore-errors
-
- socket-server <local>
- ascii <server> [
- accept drop [
- "Hello world" print flush
- readln "XYZ" = "FOO" "BAR" ? print flush
- ] with-stream
- ] with-disposal
-
- socket-server delete-file
-] "Test" spawn drop
-
-yield
-
-[ { "Hello world" "FOO" } ] [
- [
- socket-server <local> ascii [
- readln ,
- "XYZ" print flush
- readln ,
- ] with-client
- ] { } make
-] unit-test
-
-: datagram-server "unix-domain-datagram-test" temp-file ;
-: datagram-client "unix-domain-datagram-test-2" temp-file ;
-
-! Unix domain datagram sockets
-[ datagram-server delete-file ] ignore-errors
-[ datagram-client delete-file ] ignore-errors
-
-[
- [
- datagram-server <local> <datagram> "d" set
-
- "Receive 1" print
-
- "d" get receive [ reverse ] dip
-
- "Send 1" print
- dup .
-
- "d" get send
-
- "Receive 2" print
-
- "d" get receive [ " world" append ] dip
-
- "Send 1" print
- dup .
-
- "d" get send
-
- "d" get dispose
-
- "Done" print
-
- datagram-server delete-file
- ] with-scope
-] "Test" spawn drop
-
-yield
-
-[ datagram-client delete-file ] ignore-errors
-
-datagram-client <local> <datagram>
-"d" set
-
-[ ] [
- "hello" >byte-array
- datagram-server <local>
- "d" get send
-] unit-test
-
-[ "olleh" t ] [
- "d" get receive
- datagram-server <local> =
- [ >string ] dip
-] unit-test
-
-[ ] [
- "hello" >byte-array
- datagram-server <local>
- "d" get send
-] unit-test
-
-[ "hello world" t ] [
- "d" get receive
- datagram-server <local> =
- [ >string ] dip
-] unit-test
-
-[ ] [ "d" get dispose ] unit-test
-
-! Test error behavior
-: another-datagram "unix-domain-datagram-test-3" temp-file ;
-
-[ another-datagram delete-file ] ignore-errors
-
-datagram-client delete-file
-
-[ ] [ datagram-client <local> <datagram> "d" set ] unit-test
-
-[ B{ 1 2 3 } another-datagram <local> "d" get send ] must-fail
-
-[ ] [ "d" get dispose ] unit-test
-
-! See what happens on send/receive after close
-
-[ "d" get receive ] must-fail
-
-[ B{ 1 2 } datagram-server <local> "d" get send ] must-fail
-
-! Invalid parameter tests
-
-[
- image binary [ input-stream get accept ] with-file-reader
-] must-fail
-
-[
- image binary [ input-stream get receive ] with-file-reader
-] must-fail
-
-[
- image binary [
- B{ 1 2 } datagram-server <local>
- input-stream get send
- ] with-file-reader
-] must-fail
+++ /dev/null
-USING: accessors system words sequences vocabs.loader
-io.unix.backend io.unix.files ;
-
-"io.unix." os name>> append require
+++ /dev/null
-Doug Coleman
-Mackenzie Straight
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.binary io.backend io.files io.buffers
-io.encodings.utf16n io.ports io.windows kernel math splitting
-fry alien.strings windows windows.kernel32 windows.time calendar
-combinators math.functions sequences namespaces make words
-symbols system destructors accessors math.bitwise continuations
-windows.errors arrays byte-arrays generalizations ;
-IN: io.windows.files
-
-: open-file ( path access-mode create-mode flags -- handle )
- [
- [ share-mode default-security-attributes ] 2dip
- CreateFile-flags f CreateFile opened-file
- ] with-destructors ;
-
-: open-pipe-r/w ( path -- win32-file )
- { GENERIC_READ GENERIC_WRITE } flags
- OPEN_EXISTING 0 open-file ;
-
-: open-read ( path -- win32-file )
- GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
-
-: open-write ( path -- win32-file )
- GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
-
-: (open-append) ( path -- win32-file )
- GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
-
-: open-existing ( path -- win32-file )
- { GENERIC_READ GENERIC_WRITE } flags
- share-mode
- f
- OPEN_EXISTING
- FILE_FLAG_BACKUP_SEMANTICS
- f CreateFileW dup win32-error=0/f <win32-file> ;
-
-: maybe-create-file ( path -- win32-file ? )
- #! return true if file was just created
- { GENERIC_READ GENERIC_WRITE } flags
- share-mode
- f
- OPEN_ALWAYS
- 0 CreateFile-flags
- f CreateFileW dup win32-error=0/f <win32-file>
- GetLastError ERROR_ALREADY_EXISTS = not ;
-
-: set-file-pointer ( handle length method -- )
- [ dupd d>w/w <uint> ] dip SetFilePointer
- INVALID_SET_FILE_POINTER = [
- CloseHandle "SetFilePointer failed" throw
- ] when drop ;
-
-HOOK: open-append os ( path -- win32-file )
-
-TUPLE: FileArgs
- hFile lpBuffer nNumberOfBytesToRead
- lpNumberOfBytesRet lpOverlapped ;
-
-C: <FileArgs> FileArgs
-
-: make-FileArgs ( port -- <FileArgs> )
- {
- [ handle>> check-disposed ]
- [ handle>> handle>> ]
- [ buffer>> ]
- [ buffer>> buffer-length ]
- [ drop "DWORD" <c-object> ]
- [ FileArgs-overlapped ]
- } cleave <FileArgs> ;
-
-: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
- {
- [ hFile>> ]
- [ lpBuffer>> buffer-end ]
- [ lpBuffer>> buffer-capacity ]
- [ lpNumberOfBytesRet>> ]
- [ lpOverlapped>> ]
- } cleave ;
-
-: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
- {
- [ hFile>> ]
- [ lpBuffer>> buffer@ ]
- [ lpBuffer>> buffer-length ]
- [ lpNumberOfBytesRet>> ]
- [ lpOverlapped>> ]
- } cleave ;
-
-M: windows (file-reader) ( path -- stream )
- open-read <input-port> ;
-
-M: windows (file-writer) ( path -- stream )
- open-write <output-port> ;
-
-M: windows (file-appender) ( path -- stream )
- open-append <output-port> ;
-
-M: windows move-file ( from to -- )
- [ normalize-path ] bi@ MoveFile win32-error=0/f ;
-
-M: windows delete-file ( path -- )
- normalize-path DeleteFile win32-error=0/f ;
-
-M: windows copy-file ( from to -- )
- dup parent-directory make-directories
- [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
-
-M: windows make-directory ( path -- )
- normalize-path
- f CreateDirectory win32-error=0/f ;
-
-M: windows delete-directory ( path -- )
- normalize-path
- RemoveDirectory win32-error=0/f ;
-
-: find-first-file ( path -- WIN32_FIND_DATA handle )
- "WIN32_FIND_DATA" <c-object> tuck
- FindFirstFile
- [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
-
-: find-next-file ( path -- WIN32_FIND_DATA/f )
- "WIN32_FIND_DATA" <c-object> tuck
- FindNextFile 0 = [
- GetLastError ERROR_NO_MORE_FILES = [
- win32-error
- ] unless drop f
- ] when ;
-
-M: windows (directory-entries) ( path -- seq )
- "\\" ?tail drop "\\*" append
- find-first-file [ >directory-entry ] dip
- [
- '[
- [ _ find-next-file dup ]
- [ >directory-entry ]
- [ drop ] produce
- over name>> "." = [ nip ] [ swap prefix ] if
- ]
- ] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ;
-
-SYMBOLS: +read-only+ +hidden+ +system+
-+archive+ +device+ +normal+ +temporary+
-+sparse-file+ +reparse-point+ +compressed+ +offline+
-+not-content-indexed+ +encrypted+ ;
-
-TUPLE: windows-file-info < file-info attributes ;
-
-: win32-file-attribute ( n attr symbol -- )
- rot mask? [ , ] [ drop ] if ;
-
-: win32-file-attributes ( n -- seq )
- [
- {
- [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
- [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
- [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
- [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
- [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
- [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
- [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
- [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
- [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
- [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
- [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
- [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
- [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
- [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
- } cleave
- ] { } make ;
-
-: win32-file-type ( n -- symbol )
- FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
-
-TUPLE: windows-directory-entry < directory-entry attributes ;
-
-M: windows >directory-entry ( byte-array -- directory-entry )
- [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
- tri
- dupd remove windows-directory-entry boa ;
-
-: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
- [ \ windows-file-info new ] dip
- {
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ]
- [
- [ WIN32_FIND_DATA-nFileSizeLow ]
- [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
- ]
- [ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
- [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
- [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
- [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
- } cleave ;
-
-: find-first-file-stat ( path -- WIN32_FIND_DATA )
- "WIN32_FIND_DATA" <c-object> [
- FindFirstFile
- [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
- FindClose win32-error=0/f
- ] keep ;
-
-: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
- [ \ windows-file-info new ] dip
- {
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
- [
- [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
- [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
- ]
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
- [
- BY_HANDLE_FILE_INFORMATION-ftCreationTime
- FILETIME>timestamp >>created
- ]
- [
- BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
- FILETIME>timestamp >>modified
- ]
- [
- BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
- FILETIME>timestamp >>accessed
- ]
- ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
- ! [
- ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
- ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
- ! ]
- } cleave ;
-
-: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
- [
- "BY_HANDLE_FILE_INFORMATION" <c-object>
- [ GetFileInformationByHandle win32-error=0/f ] keep
- ] keep CloseHandle win32-error=0/f ;
-
-: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
- dup
- GENERIC_READ FILE_SHARE_READ f
- OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
- CreateFileW dup INVALID_HANDLE_VALUE = [
- drop find-first-file-stat WIN32_FIND_DATA>file-info
- ] [
- nip
- get-file-information BY_HANDLE_FILE_INFORMATION>file-info
- ] if ;
-
-M: winnt file-info ( path -- info )
- normalize-path get-file-information-stat ;
-
-M: winnt link-info ( path -- info )
- file-info ;
-
-HOOK: root-directory os ( string -- string' )
-
-: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
- MAX_PATH 1+ [ <byte-array> ] keep
- "DWORD" <c-object>
- "DWORD" <c-object>
- "DWORD" <c-object>
- MAX_PATH 1+ [ <byte-array> ] keep
- [ GetVolumeInformation win32-error=0/f ] 7 nkeep
- drop 5 nrot drop
- [ utf16n alien>string ] 4 ndip
- utf16n alien>string ;
-
-: file-system-space ( normalized-path -- available-space total-space free-space )
- "ULARGE_INTEGER" <c-object>
- "ULARGE_INTEGER" <c-object>
- "ULARGE_INTEGER" <c-object>
- [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
-
-: calculate-file-system-info ( file-system-info -- file-system-info' )
- {
- [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
- [ ]
- } cleave ;
-
-TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;
-
-M: winnt file-system-info ( path -- file-system-info )
- normalize-path root-directory
- dup [ volume-information ] [ file-system-space ] bi
- \ win32-file-system-info new
- swap *ulonglong >>free-space
- swap *ulonglong >>total-space
- swap *ulonglong >>available-space
- swap >>type
- swap *uint >>flags
- swap *uint >>max-component
- swap *uint >>device-serial
- swap >>device-name
- swap >>mount-point
- calculate-file-system-info ;
-
-: volume>paths ( string -- array )
- 16384 "ushort" <c-array> tuck dup length
- 0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
- win32-error-string throw
- ] [
- *uint "ushort" heap-size * head
- utf16n alien>string CHAR: \0 split
- ] if ;
-
-: find-first-volume ( -- string handle )
- MAX_PATH 1+ [ <byte-array> ] keep
- dupd
- FindFirstVolume dup win32-error=0/f
- [ utf16n alien>string ] dip ;
-
-: find-next-volume ( handle -- string/f )
- MAX_PATH 1+ [ <byte-array> tuck ] keep
- FindNextVolume 0 = [
- GetLastError ERROR_NO_MORE_FILES =
- [ drop f ] [ win32-error-string throw ] if
- ] [
- utf16n alien>string
- ] if ;
-
-: find-volumes ( -- array )
- find-first-volume
- [
- '[
- [ _ find-next-volume dup ]
- [ ]
- [ drop ] produce
- swap prefix
- ]
- ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
-
-M: winnt file-systems ( -- array )
- find-volumes [ volume>paths ] map
- concat [
- [ file-system-info ]
- [ drop \ file-system-info new swap >>mount-point ] recover
- ] map ;
-
-: file-times ( path -- timestamp timestamp timestamp )
- [
- normalize-path open-existing &dispose handle>>
- "FILETIME" <c-object>
- "FILETIME" <c-object>
- "FILETIME" <c-object>
- [ GetFileTime win32-error=0/f ] 3keep
- [ FILETIME>timestamp >local-time ] tri@
- ] with-destructors ;
-
-: (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
- [ timestamp>FILETIME ] tri@
- SetFileTime win32-error=0/f ;
-
-: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
- #! timestamp order: creation access write
- [
- [
- normalize-path open-existing &dispose handle>>
- ] 3dip (set-file-times)
- ] with-destructors ;
-
-: set-file-create-time ( path timestamp -- )
- f f set-file-times ;
-
-: set-file-access-time ( path timestamp -- )
- [ f ] dip f set-file-times ;
-
-: set-file-write-time ( path timestamp -- )
- [ f f ] dip set-file-times ;
-
-M: winnt touch-file ( path -- )
- [
- normalize-path
- maybe-create-file [ &dispose ] dip
- [ drop ] [ handle>> f now dup (set-file-times) ] if
- ] with-destructors ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-USING: kernel system windows.kernel32 io.windows
-io.windows.files io.ports windows destructors environment
-io.files.unique ;
-IN: io.windows.files.unique
-
-M: windows touch-unique-file ( path -- )
- GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
-
-M: windows temporary-path ( -- path )
- "TEMP" os-env ;
+++ /dev/null
-Doug Coleman
-Slava Pestov
+++ /dev/null
-IN: io.windows.launcher.tests\r
-USING: tools.test io.windows.launcher ;\r
-\r
-[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test\r
-\r
-[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test\r
-\r
-[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test\r
-\r
-[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test\r
+++ /dev/null
-! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays continuations io
-io.windows io.windows.nt.pipes libc io.ports
-windows.types math windows.kernel32
-namespaces make io.launcher kernel sequences windows.errors
-splitting system threads init strings combinators
-io.backend accessors concurrency.flags io.files assocs
-io.files.private windows destructors specialized-arrays.ushort
-specialized-arrays.alien ;
-IN: io.windows.launcher
-
-TUPLE: CreateProcess-args
- lpApplicationName
- lpCommandLine
- lpProcessAttributes
- lpThreadAttributes
- bInheritHandles
- dwCreateFlags
- lpEnvironment
- lpCurrentDirectory
- lpStartupInfo
- lpProcessInformation ;
-
-: default-CreateProcess-args ( -- obj )
- CreateProcess-args new
- "STARTUPINFO" <c-object>
- "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
- "PROCESS_INFORMATION" <c-object> >>lpProcessInformation
- TRUE >>bInheritHandles
- 0 >>dwCreateFlags ;
-
-: call-CreateProcess ( CreateProcess-args -- )
- {
- [ lpApplicationName>> ]
- [ lpCommandLine>> ]
- [ lpProcessAttributes>> ]
- [ lpThreadAttributes>> ]
- [ bInheritHandles>> ]
- [ dwCreateFlags>> ]
- [ lpEnvironment>> ]
- [ lpCurrentDirectory>> ]
- [ lpStartupInfo>> ]
- [ lpProcessInformation>> ]
- } cleave
- CreateProcess win32-error=0/f ;
-
-: count-trailing-backslashes ( str n -- str n )
- [ "\\" ?tail ] dip swap [
- 1+ count-trailing-backslashes
- ] when ;
-
-: fix-trailing-backslashes ( str -- str' )
- 0 count-trailing-backslashes
- 2 * CHAR: \\ <repetition> append ;
-
-: escape-argument ( str -- newstr )
- CHAR: \s over member? [
- fix-trailing-backslashes "\"" dup surround
- ] when ;
-
-: join-arguments ( args -- cmd-line )
- [ escape-argument ] map " " join ;
-
-: lookup-priority ( process -- n )
- priority>> {
- { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
- { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
- { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
- { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
- { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
- { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
- [ drop f ]
- } case ;
-
-: app-name/cmd-line ( process -- app-name cmd-line )
- command>> dup string? [
- " " split1
- ] [
- unclip swap join-arguments
- ] if ;
-
-: cmd-line ( process -- cmd-line )
- command>> dup string? [ join-arguments ] unless ;
-
-: fill-lpApplicationName ( process args -- process args )
- over app-name/cmd-line
- [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ;
-
-: fill-lpCommandLine ( process args -- process args )
- over cmd-line >>lpCommandLine ;
-
-: fill-dwCreateFlags ( process args -- process args )
- 0
- pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
- pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
- pick lookup-priority [ bitor ] when*
- >>dwCreateFlags ;
-
-: fill-lpEnvironment ( process args -- process args )
- over pass-environment? [
- [
- over get-environment
- [ swap % "=" % % "\0" % ] assoc-each
- "\0" %
- ] ushort-array{ } make underlying>>
- >>lpEnvironment
- ] when ;
-
-: fill-startup-info ( process args -- process args )
- STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
-
-HOOK: fill-redirection io-backend ( process args -- )
-
-M: wince fill-redirection 2drop ;
-
-: make-CreateProcess-args ( process -- args )
- default-CreateProcess-args
- os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
- fill-dwCreateFlags
- fill-lpEnvironment
- fill-startup-info
- nip ;
-
-M: windows current-process-handle ( -- handle )
- GetCurrentProcessId ;
-
-M: windows run-process* ( process -- handle )
- [
- current-directory get (normalize-path) cd
-
- dup make-CreateProcess-args
- tuck fill-redirection
- dup call-CreateProcess
- lpProcessInformation>>
- ] with-destructors ;
-
-M: windows kill-process* ( handle -- )
- PROCESS_INFORMATION-hProcess
- 255 TerminateProcess win32-error=0/f ;
-
-: dispose-process ( process-information -- )
- #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
- #! with CloseHandle when they are no longer needed."
- dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
- PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
-
-: exit-code ( process -- n )
- PROCESS_INFORMATION-hProcess
- 0 <ulong> [ GetExitCodeProcess ] keep *ulong
- swap win32-error=0/f ;
-
-: process-exited ( process -- )
- dup handle>> exit-code
- over handle>> dispose-process
- notify-exit ;
-
-M: windows wait-for-processes ( -- ? )
- processes get keys dup
- [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
- [ length ] [ underlying>> ] bi 0 0
- WaitForMultipleObjects
- dup HEX: ffffffff = [ win32-error ] when
- dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: alien alien.c-types arrays destructors generic io.mmap
-io.ports io.windows io.windows.files io.windows.privileges
-kernel libc math math.bitwise namespaces quotations sequences
-windows windows.advapi32 windows.kernel32 io.backend system
-accessors locals ;
-IN: io.windows.mmap
-
-: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
- CreateFileMapping [ win32-error=0/f ] keep <win32-handle> ;
-
-: map-view-of-file ( hFileMappingObject dwDesiredAccess dwFileOffsetHigh dwFileOffsetLow dwNumberOfBytesToMap -- HANDLE )
- MapViewOfFile [ win32-error=0/f ] keep ;
-
-:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
- [let | lo [ length HEX: ffffffff bitand ]
- hi [ length -32 shift HEX: ffffffff bitand ] |
- { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
- path access-mode create-mode 0 open-file |dispose
- dup handle>> f protect hi lo f create-file-mapping |dispose
- dup handle>> access 0 0 0 map-view-of-file
- ] with-privileges
- ] ;
-
-TUPLE: win32-mapped-file file mapping ;
-
-M: win32-mapped-file dispose
- [ file>> dispose ] [ mapping>> dispose ] bi ;
-
-C: <win32-mapped-file> win32-mapped-file
-
-M: windows (mapped-file)
- [
- { GENERIC_WRITE GENERIC_READ } flags
- OPEN_ALWAYS
- { PAGE_READWRITE SEC_COMMIT } flags
- FILE_MAP_ALL_ACCESS mmap-open
- -rot <win32-mapped-file>
- ] with-destructors ;
-
-M: windows close-mapped-file ( mapped-file -- )
- [
- [ handle>> &dispose drop ]
- [ address>> UnmapViewOfFile win32-error=0/f ] bi
- ] with-destructors ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
-Mackenzie Straight
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-USING: alien alien.c-types arrays assocs combinators
-continuations destructors io io.backend io.ports io.timeouts
-io.windows io.windows.files io.files io.buffers io.streams.c
-libc kernel math namespaces sequences threads windows
-windows.errors windows.kernel32 strings splitting qualified
-ascii system accessors locals ;
-QUALIFIED: windows.winsock
-IN: io.windows.nt.backend
-
-! Global variable with assoc mapping overlapped to threads
-SYMBOL: pending-overlapped
-
-TUPLE: io-callback port thread ;
-
-C: <io-callback> io-callback
-
-: (make-overlapped) ( -- overlapped-ext )
- "OVERLAPPED" malloc-object &free ;
-
-: make-overlapped ( port -- overlapped-ext )
- [ (make-overlapped) ] dip
- handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
-
-: <completion-port> ( handle existing -- handle )
- f 1 CreateIoCompletionPort dup win32-error=0/f ;
-
-SYMBOL: master-completion-port
-
-: <master-completion-port> ( -- handle )
- INVALID_HANDLE_VALUE f <completion-port> ;
-
-M: winnt add-completion ( win32-handle -- )
- handle>> master-completion-port get-global <completion-port> drop ;
-
-: eof? ( error -- ? )
- [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
-
-: twiddle-thumbs ( overlapped port -- bytes-transferred )
- [
- drop
- [ pending-overlapped get-global set-at ] curry "I/O" suspend
- {
- { [ dup integer? ] [ ] }
- { [ dup array? ] [
- first dup eof?
- [ drop 0 ] [ (win32-error-string) throw ] if
- ] }
- } cond
- ] with-timeout ;
-
-:: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
- master-completion-port get-global
- 0 <int> [ ! bytes
- f <void*> ! key
- f <void*> [ ! overlapped
- us [ 1000 /i ] [ INFINITE ] if* ! timeout
- GetQueuedCompletionStatus zero?
- ] keep *void*
- ] keep *int spin ;
-
-: resume-callback ( result overlapped -- )
- pending-overlapped get-global delete-at* drop resume-with ;
-
-: handle-overlapped ( us -- ? )
- wait-for-overlapped [
- dup [
- [ drop GetLastError 1array ] dip resume-callback t
- ] [ 2drop f ] if
- ] [ resume-callback t ] if ;
-
-M: win32-handle cancel-operation
- [ check-disposed ] [ handle>> CancelIo drop ] bi ;
-
-M: winnt io-multiplex ( us -- )
- handle-overlapped [ 0 io-multiplex ] when ;
-
-M: winnt init-io ( -- )
- <master-completion-port> master-completion-port set-global
- H{ } clone pending-overlapped set-global
- windows.winsock:init-winsock ;
-
-: file-error? ( n -- eof? )
- zero? [
- GetLastError {
- { [ dup expected-io-error? ] [ drop f ] }
- { [ dup eof? ] [ drop t ] }
- [ (win32-error-string) throw ]
- } cond
- ] [ f ] if ;
-
-: wait-for-file ( FileArgs n port -- n )
- swap file-error?
- [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
-
-: update-file-ptr ( n port -- )
- handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
-
-: finish-write ( n port -- )
- [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
-
-M: winnt (wait-to-write)
- [
- [ make-FileArgs dup setup-write WriteFile ]
- [ wait-for-file ]
- [ finish-write ]
- tri
- ] with-destructors ;
-
-: finish-read ( n port -- )
- [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
-
-M: winnt (wait-to-read) ( port -- )
- [
- [ make-FileArgs dup setup-read ReadFile ]
- [ wait-for-file ]
- [ finish-read ]
- tri
- ] with-destructors ;
-
-M: winnt (init-stdio) init-c-stdio ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-USING: io.files kernel tools.test io.backend
-io.windows.nt.files splitting sequences ;
-IN: io.windows.nt.files.tests
-
-[ f ] [ "\\foo" absolute-path? ] unit-test
-[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
-[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test
-[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test
-[ t ] [ "c:\\foo" absolute-path? ] unit-test
-[ t ] [ "c:" absolute-path? ] unit-test
-[ t ] [ "c:\\" absolute-path? ] unit-test
-[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test
-
-[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
-! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
-[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
-[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
-[ "c:" ] [ "c:" parent-directory ] unit-test
-[ "Z:" ] [ "Z:" parent-directory ] unit-test
-
-[ f ] [ "" root-directory? ] unit-test
-[ t ] [ "\\" root-directory? ] unit-test
-[ t ] [ "\\\\" root-directory? ] unit-test
-[ t ] [ "/" root-directory? ] unit-test
-[ t ] [ "//" root-directory? ] unit-test
-[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test
-[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test
-[ f ] [ "c:\\foo" root-directory? ] unit-test
-[ f ] [ "." root-directory? ] unit-test
-[ f ] [ ".." root-directory? ] unit-test
-[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test
-[ t ] [ "\\\\?\\c:" root-directory? ] unit-test
-[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test
-
-[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
-
-[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
- "C:\\builds\\factor\\12345\\"
- "..\\log.txt" append-path normalize-path
-] unit-test
-
-[ "\\\\?\\C:\\builds\\" ] [
- "C:\\builds\\factor\\12345\\"
- "..\\.." append-path normalize-path
-] unit-test
-
-[ "\\\\?\\C:\\builds\\" ] [
- "C:\\builds\\factor\\12345\\"
- "..\\.." append-path normalize-path
-] unit-test
-
-[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
-[ t ] [ "" resource-path 2 tail exists? ] unit-test
+++ /dev/null
-USING: continuations destructors io.buffers io.files io.backend
-io.timeouts io.ports io.files.private io.windows
-io.windows.files io.windows.nt.backend io.encodings.utf16n
-windows windows.kernel32 kernel libc math threads system
-environment alien.c-types alien.arrays alien.strings sequences
-combinators combinators.short-circuit ascii splitting alien
-strings assocs namespaces make accessors tr ;
-IN: io.windows.nt.files
-
-M: winnt cwd
- MAX_UNICODE_PATH dup "ushort" <c-array>
- [ GetCurrentDirectory win32-error=0/f ] keep
- utf16n alien>string ;
-
-M: winnt cd
- SetCurrentDirectory win32-error=0/f ;
-
-: unicode-prefix ( -- seq )
- "\\\\?\\" ; inline
-
-M: winnt root-directory? ( path -- ? )
- {
- { [ dup empty? ] [ drop f ] }
- { [ dup [ path-separator? ] all? ] [ drop t ] }
- { [ dup trim-right-separators { [ length 2 = ]
- [ second CHAR: : = ] } 1&& ] [ drop t ] }
- { [ dup unicode-prefix head? ]
- [ trim-right-separators length unicode-prefix length 2 + = ] }
- [ drop f ]
- } cond ;
-
-ERROR: not-absolute-path ;
-
-M: winnt root-directory ( string -- string' )
- unicode-prefix ?head drop
- dup {
- [ length 2 >= ]
- [ second CHAR: : = ]
- [ first Letter? ]
- } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
-
-: prepend-prefix ( string -- string' )
- dup unicode-prefix head? [
- unicode-prefix prepend
- ] unless ;
-
-TR: normalize-separators "/" "\\" ;
-
-M: winnt normalize-path ( string -- string' )
- (normalize-path)
- normalize-separators
- prepend-prefix ;
-
-M: winnt CreateFile-flags ( DWORD -- DWORD )
- FILE_FLAG_OVERLAPPED bitor ;
-
-M: winnt FileArgs-overlapped ( port -- overlapped )
- make-overlapped ;
-
-M: winnt open-append
- [ dup file-info size>> ] [ drop 0 ] recover
- [ (open-append) ] dip >>ptr ;
-
-M: winnt home "USERPROFILE" os-env ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-USING: io.launcher tools.test calendar accessors environment
-namespaces kernel system arrays io io.files io.encodings.ascii
-sequences parser assocs hashtables math continuations eval ;
-IN: io.windows.launcher.nt.tests
-
-[ ] [
- <process>
- "notepad" >>command
- 1/2 seconds >>timeout
- "notepad" set
-] unit-test
-
-[ f ] [ "notepad" get process-running? ] unit-test
-
-[ f ] [ "notepad" get process-started? ] unit-test
-
-[ ] [ "notepad" [ run-detached ] change ] unit-test
-
-[ "notepad" get wait-for-process ] must-fail
-
-[ t ] [ "notepad" get killed>> ] unit-test
-
-[ f ] [ "notepad" get process-running? ] unit-test
-
-[ ] [
- <process>
- vm "-quiet" "-run=hello-world" 3array >>command
- "out.txt" temp-file >>stdout
- try-process
-] unit-test
-
-[ "Hello world" ] [
- "out.txt" temp-file ascii file-lines first
-] unit-test
-
-[ ] [
- <process>
- vm "-run=listener" 2array >>command
- +closed+ >>stdin
- try-process
-] unit-test
-
-[ ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "stderr.factor" 3array >>command
- "out.txt" temp-file >>stdout
- "err.txt" temp-file >>stderr
- try-process
- ] with-directory
-] unit-test
-
-[ "output" ] [
- "out.txt" temp-file ascii file-lines first
-] unit-test
-
-[ "error" ] [
- "err.txt" temp-file ascii file-lines first
-] unit-test
-
-[ ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "stderr.factor" 3array >>command
- "out.txt" temp-file >>stdout
- +stdout+ >>stderr
- try-process
- ] with-directory
-] unit-test
-
-[ "outputerror" ] [
- "out.txt" temp-file ascii file-lines first
-] unit-test
-
-[ "output" ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "stderr.factor" 3array >>command
- "err2.txt" temp-file >>stderr
- ascii <process-reader> lines first
- ] with-directory
-] unit-test
-
-[ "error" ] [
- "err2.txt" temp-file ascii file-lines first
-] unit-test
-
-[ t ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "env.factor" 3array >>command
- ascii <process-reader> contents
- ] with-directory eval
-
- os-envs =
-] unit-test
-
-[ t ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "env.factor" 3array >>command
- +replace-environment+ >>environment-mode
- os-envs >>environment
- ascii <process-reader> contents
- ] with-directory eval
-
- os-envs =
-] unit-test
-
-[ "B" ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "env.factor" 3array >>command
- { { "A" "B" } } >>environment
- ascii <process-reader> contents
- ] with-directory eval
-
- "A" swap at
-] unit-test
-
-[ f ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "env.factor" 3array >>command
- { { "USERPROFILE" "XXX" } } >>environment
- +prepend-environment+ >>environment-mode
- ascii <process-reader> contents
- ] with-directory eval
-
- "USERPROFILE" swap at "XXX" =
-] unit-test
-
-2 [
- [ ] [
- <process>
- "cmd.exe /c dir" >>command
- "dir.txt" temp-file >>stdout
- try-process
- ] unit-test
-
- [ ] [ "dir.txt" temp-file delete-file ] unit-test
-] times
-
-[ "append-test" temp-file delete-file ] ignore-errors
-
-[ "Hello appender\r\nHello appender\r\n" ] [
- 2 [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "append.factor" 3array >>command
- "append-test" temp-file <appender> >>stdout
- try-process
- ] with-directory
- ] times
-
- "append-test" temp-file ascii file-contents
-] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays continuations destructors io
-io.windows libc io.ports io.pipes windows.types math
-windows.kernel32 windows namespaces make io.launcher kernel
-sequences windows.errors assocs splitting system strings
-io.windows.launcher io.windows.files io.backend io.files
-io.files.private combinators shuffle accessors locals ;
-IN: io.windows.nt.launcher
-
-: duplicate-handle ( handle -- handle' )
- GetCurrentProcess ! source process
- swap ! handle
- GetCurrentProcess ! target process
- f <void*> [ ! target handle
- DUPLICATE_SAME_ACCESS ! desired access
- TRUE ! inherit handle
- DUPLICATE_CLOSE_SOURCE ! options
- DuplicateHandle win32-error=0/f
- ] keep *void* ;
-
-! /dev/null simulation
-: null-input ( -- pipe )
- (pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
-
-: null-output ( -- pipe )
- (pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
-
-: null-pipe ( mode -- pipe )
- {
- { GENERIC_READ [ null-input ] }
- { GENERIC_WRITE [ null-output ] }
- } case ;
-
-! The below code is based on the example given in
-! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
-
-: redirect-default ( obj access-mode create-mode -- handle )
- 3drop f ;
-
-: redirect-closed ( obj access-mode create-mode -- handle )
- drop nip null-pipe ;
-
-:: redirect-file ( path access-mode create-mode -- handle )
- path normalize-path
- access-mode
- share-mode
- default-security-attributes
- create-mode
- FILE_ATTRIBUTE_NORMAL ! flags and attributes
- f ! template file
- CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
-
-: redirect-append ( path access-mode create-mode -- handle )
- [ path>> ] 2dip
- drop OPEN_ALWAYS
- redirect-file
- dup 0 FILE_END set-file-pointer ;
-
-: redirect-handle ( handle access-mode create-mode -- handle )
- 2drop handle>> duplicate-handle ;
-
-: redirect-stream ( stream access-mode create-mode -- handle )
- [ underlying-handle handle>> ] 2dip redirect-handle ;
-
-: redirect ( obj access-mode create-mode -- handle )
- {
- { [ pick not ] [ redirect-default ] }
- { [ pick +closed+ eq? ] [ redirect-closed ] }
- { [ pick string? ] [ redirect-file ] }
- { [ pick appender? ] [ redirect-append ] }
- { [ pick win32-file? ] [ redirect-handle ] }
- [ redirect-stream ]
- } cond
- dup [ dup t set-inherit ] when ;
-
-: redirect-stdout ( process args -- handle )
- drop
- stdout>>
- GENERIC_WRITE
- CREATE_ALWAYS
- redirect
- STD_OUTPUT_HANDLE GetStdHandle or ;
-
-: redirect-stderr ( process args -- handle )
- over stderr>> +stdout+ eq? [
- nip
- lpStartupInfo>> STARTUPINFO-hStdOutput
- ] [
- drop
- stderr>>
- GENERIC_WRITE
- CREATE_ALWAYS
- redirect
- STD_ERROR_HANDLE GetStdHandle or
- ] if ;
-
-: redirect-stdin ( process args -- handle )
- drop
- stdin>>
- GENERIC_READ
- OPEN_EXISTING
- redirect
- STD_INPUT_HANDLE GetStdHandle or ;
-
-M: winnt fill-redirection ( process args -- )
- [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
- [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
- [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
- 2drop ;
+++ /dev/null
-unportable
+++ /dev/null
-USE: io\r
-"Hello appender" print\r
+++ /dev/null
-USE: system
-USE: prettyprint
-USE: environment
-os-envs .
+++ /dev/null
-USE: io\r
-USE: namespaces\r
-\r
-"output" write flush\r
-"error" error-stream get stream-write error-stream get stream-flush\r
+++ /dev/null
-Doug Coleman
+++ /dev/null
-IN: io.windows.nt.monitors.tests\r
-USING: io.windows.nt.monitors tools.test ;\r
-\r
-\ fill-queue-thread must-infer\r
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings libc destructors locals
-kernel math assocs namespaces make continuations sequences
-hashtables sorting arrays combinators math.bitwise strings
-system accessors threads splitting io.backend io.windows
-io.windows.nt.backend io.windows.nt.files io.monitors io.ports
-io.buffers io.files io.timeouts io.encodings.string
-io.encodings.utf16n io windows windows.kernel32 windows.types ;
-IN: io.windows.nt.monitors
-
-: open-directory ( path -- handle )
- normalize-path
- FILE_LIST_DIRECTORY
- share-mode
- f
- OPEN_EXISTING
- { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
- f
- CreateFile opened-file ;
-
-TUPLE: win32-monitor-port < input-port recursive ;
-
-TUPLE: win32-monitor < monitor port ;
-
-: begin-reading-changes ( port -- overlapped )
- {
- [ handle>> handle>> ]
- [ buffer>> ptr>> ]
- [ buffer>> size>> ]
- [ recursive>> 1 0 ? ]
- } cleave
- FILE_NOTIFY_CHANGE_ALL
- 0 <uint>
- (make-overlapped)
- [ f ReadDirectoryChangesW win32-error=0/f ] keep ;
-
-: read-changes ( port -- bytes-transferred )
- [
- [ begin-reading-changes ] [ twiddle-thumbs ] bi
- ] with-destructors ;
-
-: parse-action ( action -- changed )
- {
- { FILE_ACTION_ADDED [ +add-file+ ] }
- { FILE_ACTION_REMOVED [ +remove-file+ ] }
- { FILE_ACTION_MODIFIED [ +modify-file+ ] }
- { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] }
- { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] }
- [ drop +modify-file+ ]
- } case 1array ;
-
-: memory>u16-string ( alien len -- string )
- memory>byte-array utf16n decode ;
-
-: parse-notify-record ( buffer -- path changed )
- [
- [ FILE_NOTIFY_INFORMATION-FileName ]
- [ FILE_NOTIFY_INFORMATION-FileNameLength ]
- bi memory>u16-string
- ]
- [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
-
-: (file-notify-records) ( buffer -- buffer )
- dup ,
- dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
- [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
- (file-notify-records)
- ] unless ;
-
-: file-notify-records ( buffer -- seq )
- [ (file-notify-records) drop ] { } make ;
-
-:: parse-notify-records ( monitor buffer -- )
- buffer file-notify-records [
- parse-notify-record
- [ monitor path>> prepend-path normalize-path ] dip
- monitor queue-change
- ] each ;
-
-: fill-queue ( monitor -- )
- dup port>> dup check-disposed
- [ buffer>> ptr>> ] [ read-changes zero? ] bi
- [ 2dup parse-notify-records ] unless
- 2drop ;
-
-: (fill-queue-thread) ( monitor -- )
- dup fill-queue (fill-queue-thread) ;
-
-: fill-queue-thread ( monitor -- )
- [ dup fill-queue (fill-queue-thread) ]
- [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ;
-
-M:: winnt (monitor) ( path recursive? mailbox -- monitor )
- [
- path normalize-path mailbox win32-monitor new-monitor
- path open-directory \ win32-monitor-port <buffered-port>
- recursive? >>recursive
- >>port
- dup [ fill-queue-thread ] curry
- "Windows monitor thread" spawn drop
- ] with-destructors ;
-
-M: win32-monitor dispose
- port>> dispose ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman,
-! Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: vocabs.loader io.windows io.windows.nt.backend
-io.windows.nt.files io.windows.files io.backend system ;
-
-winnt set-io-backend
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays destructors io io.windows libc
-windows.types math.bitwise windows.kernel32 windows namespaces
-make kernel sequences windows.errors assocs math.parser system
-random combinators accessors io.pipes io.ports ;
-IN: io.windows.nt.pipes
-
-! This code is based on
-! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
-
-: create-named-pipe ( name -- handle )
- { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags
- PIPE_TYPE_BYTE
- 1
- 4096
- 4096
- 0
- default-security-attributes
- CreateNamedPipe opened-file ;
-
-: open-other-end ( name -- handle )
- GENERIC_WRITE
- { FILE_SHARE_READ FILE_SHARE_WRITE } flags
- default-security-attributes
- OPEN_EXISTING
- FILE_FLAG_OVERLAPPED
- f
- CreateFile opened-file ;
-
-: unique-pipe-name ( -- string )
- [
- "\\\\.\\pipe\\factor-" %
- pipe counter #
- "-" %
- 32 random-bits #
- "-" %
- micros #
- ] "" make ;
-
-M: winnt (pipe) ( -- pipe )
- [
- unique-pipe-name
- [ create-named-pipe ] [ open-other-end ] bi
- pipe boa
- ] with-destructors ;
+++ /dev/null
-unportable
+++ /dev/null
-USING: alien alien.c-types alien.syntax arrays continuations\r
-destructors generic io.mmap io.ports io.windows io.windows.files\r
-kernel libc math math.bitwise namespaces quotations sequences windows\r
-windows.advapi32 windows.kernel32 io.backend system accessors\r
-io.windows.privileges ;\r
-IN: io.windows.nt.privileges\r
-\r
-TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES\r
-\r
-! Security tokens\r
-! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/\r
-\r
-: (open-process-token) ( handle -- handle )\r
- { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>\r
- [ OpenProcessToken win32-error=0/f ] keep *void* ;\r
-\r
-: open-process-token ( -- handle )\r
- #! remember to CloseHandle\r
- GetCurrentProcess (open-process-token) ;\r
-\r
-: with-process-token ( quot -- )\r
- #! quot: ( token-handle -- token-handle )\r
- [ open-process-token ] dip\r
- [ keep ] curry\r
- [ CloseHandle drop ] [ ] cleanup ; inline\r
-\r
-: lookup-privilege ( string -- luid )\r
- [ f ] dip "LUID" <c-object>\r
- [ LookupPrivilegeValue win32-error=0/f ] keep ;\r
-\r
-: make-token-privileges ( name ? -- obj )\r
- "TOKEN_PRIVILEGES" <c-object>\r
- 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep\r
- "LUID_AND_ATTRIBUTES" malloc-array &free\r
- over set-TOKEN_PRIVILEGES-Privileges\r
-\r
- swap [\r
- SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges\r
- set-LUID_AND_ATTRIBUTES-Attributes\r
- ] when\r
-\r
- [ lookup-privilege ] dip\r
- [\r
- TOKEN_PRIVILEGES-Privileges\r
- set-LUID_AND_ATTRIBUTES-Luid\r
- ] keep ;\r
-\r
-M: winnt set-privilege ( name ? -- )\r
- [\r
- -rot 0 -rot make-token-privileges\r
- dup length f f AdjustTokenPrivileges win32-error=0/f\r
- ] with-process-token ;\r
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-USING: alien alien.accessors alien.c-types byte-arrays
-continuations destructors io.ports io.timeouts io.sockets
-io.sockets io namespaces io.streams.duplex io.windows
-io.windows.sockets io.windows.nt.backend windows.winsock kernel
-libc math sequences threads system combinators accessors ;
-IN: io.windows.nt.sockets
-
-: malloc-int ( object -- object )
- "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
-
-M: winnt WSASocket-flags ( -- DWORD )
- WSA_FLAG_OVERLAPPED ;
-
-: get-ConnectEx-ptr ( socket -- void* )
- SIO_GET_EXTENSION_FUNCTION_POINTER
- WSAID_CONNECTEX
- "GUID" heap-size
- "void*" <c-object>
- [
- "void*" heap-size
- "DWORD" <c-object>
- f
- f
- WSAIoctl SOCKET_ERROR = [
- winsock-error-string throw
- ] when
- ] keep *void* ;
-
-TUPLE: ConnectEx-args port
- s name namelen lpSendBuffer dwSendDataLength
- lpdwBytesSent lpOverlapped ptr ;
-
-: wait-for-socket ( args -- n )
- [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
-
-: <ConnectEx-args> ( sockaddr size -- ConnectEx )
- ConnectEx-args new
- swap >>namelen
- swap >>name
- f >>lpSendBuffer
- 0 >>dwSendDataLength
- f >>lpdwBytesSent
- (make-overlapped) >>lpOverlapped ; inline
-
-: call-ConnectEx ( ConnectEx -- )
- {
- [ s>> ]
- [ name>> ]
- [ namelen>> ]
- [ lpSendBuffer>> ]
- [ dwSendDataLength>> ]
- [ lpdwBytesSent>> ]
- [ lpOverlapped>> ]
- [ ptr>> ]
- } cleave
- "int"
- { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
- "stdcall" alien-indirect drop
- winsock-error-string [ throw ] when* ; inline
-
-M: object establish-connection ( client-out remote -- )
- make-sockaddr/size <ConnectEx-args>
- swap >>port
- dup port>> handle>> handle>> >>s
- dup s>> get-ConnectEx-ptr >>ptr
- dup call-ConnectEx
- wait-for-socket drop ;
-
-TUPLE: AcceptEx-args port
- sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
- dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
-
-: init-accept-buffer ( addr AcceptEx -- )
- swap sockaddr-size 16 +
- [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
- dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
- drop ; inline
-
-: <AcceptEx-args> ( server addr -- AcceptEx )
- AcceptEx-args new
- 2dup init-accept-buffer
- swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
- over handle>> handle>> >>sListenSocket
- swap >>port
- 0 >>dwReceiveDataLength
- f >>lpdwBytesReceived
- (make-overlapped) >>lpOverlapped ; inline
-
-: call-AcceptEx ( AcceptEx -- )
- {
- [ sListenSocket>> ]
- [ sAcceptSocket>> ]
- [ lpOutputBuffer>> ]
- [ dwReceiveDataLength>> ]
- [ dwLocalAddressLength>> ]
- [ dwRemoteAddressLength>> ]
- [ lpdwBytesReceived>> ]
- [ lpOverlapped>> ]
- } cleave AcceptEx drop
- winsock-error-string [ throw ] when* ; inline
-
-: extract-remote-address ( AcceptEx -- sockaddr )
- {
- [ lpOutputBuffer>> ]
- [ dwReceiveDataLength>> ]
- [ dwLocalAddressLength>> ]
- [ dwRemoteAddressLength>> ]
- } cleave
- f <void*>
- 0 <int>
- f <void*>
- [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
-
-M: object (accept) ( server addr -- handle sockaddr )
- [
- <AcceptEx-args>
- {
- [ call-AcceptEx ]
- [ wait-for-socket drop ]
- [ sAcceptSocket>> <win32-socket> ]
- [ extract-remote-address ]
- } cleave
- ] with-destructors ;
-
-TUPLE: WSARecvFrom-args port
- s lpBuffers dwBufferCount lpNumberOfBytesRecvd
- lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
-
-: make-receive-buffer ( -- WSABUF )
- "WSABUF" malloc-object &free
- default-buffer-size get over set-WSABUF-len
- default-buffer-size get malloc &free over set-WSABUF-buf ; inline
-
-: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
- WSARecvFrom-args new
- swap >>port
- dup port>> handle>> handle>> >>s
- dup port>> addr>> sockaddr-size
- [ malloc &free >>lpFrom ]
- [ malloc-int &free >>lpFromLen ] bi
- make-receive-buffer >>lpBuffers
- 1 >>dwBufferCount
- 0 malloc-int &free >>lpFlags
- 0 malloc-int &free >>lpNumberOfBytesRecvd
- (make-overlapped) >>lpOverlapped ; inline
-
-: call-WSARecvFrom ( WSARecvFrom -- )
- {
- [ s>> ]
- [ lpBuffers>> ]
- [ dwBufferCount>> ]
- [ lpNumberOfBytesRecvd>> ]
- [ lpFlags>> ]
- [ lpFrom>> ]
- [ lpFromLen>> ]
- [ lpOverlapped>> ]
- [ lpCompletionRoutine>> ]
- } cleave WSARecvFrom socket-error* ; inline
-
-: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
- [ lpBuffers>> WSABUF-buf swap memory>byte-array ]
- [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
-
-M: winnt (receive) ( datagram -- packet addrspec )
- [
- <WSARecvFrom-args>
- [ call-WSARecvFrom ]
- [ wait-for-socket ]
- [ parse-WSARecvFrom ]
- tri
- ] with-destructors ;
-
-TUPLE: WSASendTo-args port
- s lpBuffers dwBufferCount lpNumberOfBytesSent
- dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
-
-: make-send-buffer ( packet -- WSABUF )
- "WSABUF" malloc-object &free
- [ [ malloc-byte-array &free ] dip set-WSABUF-buf ]
- [ [ length ] dip set-WSABUF-len ]
- [ nip ]
- 2tri ; inline
-
-: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
- WSASendTo-args new
- swap >>port
- dup port>> handle>> handle>> >>s
- swap make-sockaddr/size
- [ malloc-byte-array &free ] dip
- [ >>lpTo ] [ >>iToLen ] bi*
- swap make-send-buffer >>lpBuffers
- 1 >>dwBufferCount
- 0 >>dwFlags
- 0 <uint> >>lpNumberOfBytesSent
- (make-overlapped) >>lpOverlapped ; inline
-
-: call-WSASendTo ( WSASendTo -- )
- {
- [ s>> ]
- [ lpBuffers>> ]
- [ dwBufferCount>> ]
- [ lpNumberOfBytesSent>> ]
- [ dwFlags>> ]
- [ lpTo>> ]
- [ iToLen>> ]
- [ lpOverlapped>> ]
- [ lpCompletionRoutine>> ]
- } cleave WSASendTo socket-error* ; inline
-
-M: winnt (send) ( packet addrspec datagram -- )
- [
- <WSASendTo-args>
- [ call-WSASendTo ]
- [ wait-for-socket drop ]
- bi
- ] with-destructors ;
+++ /dev/null
-unportable
+++ /dev/null
-Microsoft Windows XP/Vista native I/O implementation
+++ /dev/null
-unportable
+++ /dev/null
-USING: io.backend kernel continuations sequences\r
-system vocabs.loader combinators ;\r
-IN: io.windows.privileges\r
-\r
-HOOK: set-privilege io-backend ( name ? -- ) inline\r
-\r
-: with-privileges ( seq quot -- )\r
- over [ [ t set-privilege ] each ] curry compose\r
- swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline\r
-\r
-{\r
- { [ os winnt? ] [ "io.windows.nt.privileges" require ] }\r
- { [ os wince? ] [ "io.windows.ce.privileges" require ] }\r
-} cond\r
+++ /dev/null
-unportable
+++ /dev/null
-USING: kernel accessors io.sockets io.windows io.backend\r
-windows.winsock system destructors alien.c-types ;\r
-IN: io.windows.sockets\r
-\r
-HOOK: WSASocket-flags io-backend ( -- DWORD )\r
-\r
-TUPLE: win32-socket < win32-file ;\r
-\r
-: <win32-socket> ( handle -- win32-socket )\r
- win32-socket new-win32-handle ;\r
-\r
-M: win32-socket dispose ( stream -- )\r
- handle>> closesocket drop ;\r
-\r
-: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
- [ empty-sockaddr/size ] [ protocol-family ] bi\r
- pick set-sockaddr-in-family ;\r
-\r
-: opened-socket ( handle -- win32-socket )\r
- <win32-socket> |dispose dup add-completion ;\r
-\r
-: open-socket ( addrspec type -- win32-socket )\r
- [ protocol-family ] dip\r
- 0 f 0 WSASocket-flags WSASocket\r
- dup socket-error\r
- opened-socket ;\r
-\r
-M: object (get-local-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
- [ getsockname socket-error ] 2keep drop ;\r
-\r
-M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
- [ getpeername socket-error ] 2keep drop ;\r
-\r
-: bind-socket ( win32-socket sockaddr len -- )\r
- [ handle>> ] 2dip bind socket-error ;\r
-\r
-M: object ((client)) ( addrspec -- handle )\r
- [ SOCK_STREAM open-socket ] keep\r
- [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
-\r
-: server-socket ( addrspec type -- fd )\r
- [ open-socket ] [ drop ] 2bi\r
- [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
-\r
-! http://support.microsoft.com/kb/127144\r
-! NOTE: Possibly tweak this because of SYN flood attacks\r
-: listen-backlog ( -- n ) HEX: 7fffffff ; inline\r
-\r
-M: object (server) ( addrspec -- handle )\r
- [\r
- SOCK_STREAM server-socket\r
- dup handle>> listen-backlog listen winsock-return-check\r
- ] with-destructors ;\r
-\r
-M: windows (datagram) ( addrspec -- handle )\r
- [ SOCK_DGRAM server-socket ] with-destructors ;\r
-\r
-M: windows addrinfo-error ( n -- )\r
- winsock-return-check ;\r
+++ /dev/null
-unportable
+++ /dev/null
-Microsoft Windows native I/O implementation
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays destructors io io.backend
-io.buffers io.files io.ports io.binary io.timeouts
-windows.errors strings kernel math namespaces sequences windows
-windows.kernel32 windows.shell32 windows.types windows.winsock
-splitting continuations math.bitwise system accessors ;
-IN: io.windows
-
-: set-inherit ( handle ? -- )
- [ HANDLE_FLAG_INHERIT ] dip
- >BOOLEAN SetHandleInformation win32-error=0/f ;
-
-TUPLE: win32-handle handle disposed ;
-
-: new-win32-handle ( handle class -- win32-handle )
- new swap [ >>handle ] [ f set-inherit ] bi ;
-
-: <win32-handle> ( handle -- win32-handle )
- win32-handle new-win32-handle ;
-
-M: win32-handle dispose* ( handle -- )
- handle>> CloseHandle drop ;
-
-TUPLE: win32-file < win32-handle ptr ;
-
-: <win32-file> ( handle -- win32-file )
- win32-file new-win32-handle ;
-
-M: win32-file dispose
- dup disposed>> [ drop ] [
- [ cancel-operation ] [ call-next-method ] bi
- ] if ;
-
-HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
-HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
-HOOK: add-completion io-backend ( port -- )
-
-: opened-file ( handle -- win32-file )
- dup invalid-handle?
- <win32-file> |dispose
- dup add-completion ;
-
-: share-mode ( -- fixnum )
- {
- FILE_SHARE_READ
- FILE_SHARE_WRITE
- FILE_SHARE_DELETE
- } flags ; foldable
-
-: default-security-attributes ( -- obj )
- "SECURITY_ATTRIBUTES" <c-object>
- "SECURITY_ATTRIBUTES" heap-size
- over set-SECURITY_ATTRIBUTES-nLength ;
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: lcs html.elements kernel qualified ;
+USING: lcs html.elements kernel ;
FROM: accessors => item>> ;
FROM: io => write ;
FROM: sequences => each if-empty ;
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors prettyprint fry
-sets ;
+sets vocabs.parser ;
IN: listener
GENERIC: stream-read-quot ( stream -- quot/f )
USING: slots.private ;
IN: locals.backend
-: local-value 2 slot ; inline
+: local-value ( box -- value ) 2 slot ; inline
-: set-local-value 2 set-slot ; inline
+: set-local-value ( value box -- ) 2 set-slot ; inline
USING: accessors arrays combinators effects.parser
generic.parser kernel lexer locals.errors
locals.rewrite.closures locals.types make namespaces parser
-quotations sequences splitting words ;
+quotations sequences splitting words vocabs.parser ;
IN: locals.parser
: make-local ( name -- word )
! See http://factorcode.org/license.txt for BSD license.\r
USING: logging.analysis logging.server logging smtp kernel\r
io.files io.streams.string namespaces make alarms assocs\r
-io.encodings.utf8 accessors calendar sequences qualified ;\r
+io.encodings.utf8 accessors calendar sequences ;\r
QUALIFIED: io.sockets\r
IN: logging.insomniac\r
\r
words kernel arrays shuffle tools.annotations\r
prettyprint.config prettyprint debugger io.streams.string\r
splitting continuations effects generalizations parser strings\r
-quotations fry symbols accessors ;\r
+quotations fry accessors ;\r
IN: logging\r
\r
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: namespaces kernel io calendar sequences io.files\r
-io.sockets continuations destructors prettyprint assocs\r
-math.parser words debugger math combinators\r
-concurrency.messaging threads arrays init math.ranges strings\r
-calendar.format io.encodings.utf8 ;\r
+USING: namespaces kernel io io.files io.pathnames io.directories\r
+io.sockets io.encodings.utf8\r
+calendar calendar.format sequences continuations destructors\r
+prettyprint assocs math.parser words debugger math combinators\r
+concurrency.messaging threads arrays init math.ranges strings ;\r
IN: logging.server\r
\r
: log-root ( -- string )\r
\ byte-bit-count
256 [
0 swap [ [ 1+ ] when ] each-bit
-] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] define-inline
+] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
+(( byte -- table )) define-declared
+
+\ byte-bit-count make-inline
>>
GENERIC# ^n 1 ( z w -- z^w )
-: (^n) 1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
+: (^n) ( z w -- z^w )
+ 1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
M: integer ^n
[ factor-2s ] dip [ (^n) ] keep rot * shift ;
"Rectangles are constructed by calling " { $link <rect> } " and " { $link <extent-rect> } "."
} ;
-HELP: <rect> ( loc dim -- rect )
+HELP: <rect>
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } }
{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ;
{ rect-bounds rect-extent } related-words
-HELP: <extent-rect> ( loc ext -- rect )
+HELP: <extent-rect>
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } }
{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ;
$nl
"Intervals are created by calling " { $link [a,b] } ", " { $link (a,b) } ", " { $link [a,b) } ", " { $link (a,b] } " or " { $link [a,a] } "." } ;
-HELP: <interval> ( from to -- interval )
+HELP: <interval>
{ $values { "from" "a " { $snippet "{ point included? }" } " pair" } { "to" "a " { $snippet "{ point included? }" } " pair" } { "interval" interval } }
{ $description "Creates a new interval. Usually it is more convenient to create intervals using one of the following words instead:"
{ $list
TUPLE: interval { from read-only } { to read-only } ;
-: <interval> ( from to -- int )
+: <interval> ( from to -- interval )
2dup [ first ] bi@ {
{ [ 2dup > ] [ 2drop 2drop empty-interval ] }
{ [ 2dup = ] [
<PRIVATE
-: ** conjugate * ; inline
+: ** ( x y -- z ) conjugate * ; inline
: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
INSTANCE: range immutable-sequence
-: twiddle 2dup > -1 1 ? ; inline
+: twiddle ( a b -- a b step ) 2dup > -1 1 ? ; inline
-: (a, dup [ + ] curry 2dip ; inline
+: (a, ( a b step -- a' b' step ) dup [ + ] curry 2dip ; inline
-: ,b) dup [ - ] curry dip ; inline
+: ,b) ( a b step -- a' b' step ) dup [ - ] curry dip ; inline
: [a,b] ( a b -- range ) twiddle <range> ; inline
USING: accessors checksums checksums.md5 io io.encodings.ascii
-io.encodings.binary io.files io.streams.byte-array
-io.streams.string kernel make mime.multipart
-mime.multipart.private multiline sequences strings tools.test ;
+io.encodings.binary io.files io.files.temp io.files.info
+io.streams.byte-array io.streams.string kernel make
+mime.multipart mime.multipart.private multiline sequences
+strings tools.test ;
IN: mime.multipart.tests
[ { "a" } ] [
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.encodings.ascii assocs sequences splitting
-kernel namespaces fry memoize ;
+USING: io.pathnames io.files io.encodings.ascii assocs sequences
+splitting kernel namespaces fry memoize ;
IN: mime.types
MEMO: mime-db ( -- seq )
$nl
"Mirrors are created by calling " { $link <mirror> } " or " { $link make-mirror } "." } ;
-HELP: <mirror> ( object -- mirror )
+HELP: <mirror>
{ $values { "object" object } { "mirror" mirror } }
{ $description "Creates a " { $link mirror } " reflecting an object." }
{ $examples
: STRING:
CREATE-WORD
- parse-here 1quotation define-inline ; parsing
+ parse-here 1quotation
+ (( -- string )) define-inline ; parsing
<PRIVATE
: (parse-multiline-string) ( start-index end-text -- end-index )
: nibble BIN: 1111 ; inline
-: nibbles>bytes 1 + 2/ ; inline
+: nibbles>bytes ( m -- n ) 1 + 2/ ; inline
: byte/nibble ( n -- shift n' )
[ 1 bitand 2 shift ] [ -1 shift ] bi ; inline
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs ;
+IN: opengl.capabilities
+
+HELP: gl-version
+{ $values { "version" "The version string from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
+
+HELP: gl-vendor-version
+{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
+
+HELP: has-gl-version?
+{ $values { "version" "A version string" } { "?" "A boolean value" } }
+{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
+
+HELP: require-gl-version
+{ $values { "version" "A version string" } }
+{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ;
+
+HELP: glsl-version
+{ $values { "version" "The GLSL version string from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
+
+HELP: glsl-vendor-version
+{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
+
+HELP: has-glsl-version?
+{ $values { "version" "A version string" } { "?" "A boolean value" } }
+{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
+
+HELP: require-glsl-version
+{ $values { "version" "A version string" } }
+{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ;
+
+HELP: gl-extensions
+{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } }
+{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ;
+
+HELP: has-gl-extensions?
+{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
+{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
+
+HELP: has-gl-version-or-extensions?
+{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }
+{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
+
+HELP: require-gl-extensions
+{ $values { "extensions" "A sequence of extension name strings" } }
+{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
+
+HELP: require-gl-version-or-extensions
+{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
+{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
+
+{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words
+
+ABOUT: "gl-utilities"
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces make sequences splitting opengl.gl
+continuations math.parser math arrays sets math.order ;
+IN: opengl.capabilities
+
+: (require-gl) ( thing require-quot make-error-quot -- )
+ -rot dupd call
+ [ 2drop ]
+ [ swap " " make throw ]
+ if ; inline
+
+: gl-extensions ( -- seq )
+ GL_EXTENSIONS glGetString " " split ;
+: has-gl-extensions? ( extensions -- ? )
+ gl-extensions swap [ over member? ] all? nip ;
+: (make-gl-extensions-error) ( required-extensions -- )
+ gl-extensions diff
+ "Required OpenGL extensions not supported:\n" %
+ [ " " % % "\n" % ] each ;
+: require-gl-extensions ( extensions -- )
+ [ has-gl-extensions? ]
+ [ (make-gl-extensions-error) ]
+ (require-gl) ;
+
+: version-seq ( version-string -- version-seq )
+ "." split [ string>number ] map ;
+
+: version-before? ( version1 version2 -- ? )
+ swap version-seq swap version-seq before=? ;
+
+: (gl-version) ( -- version vendor )
+ GL_VERSION glGetString " " split1 ;
+: gl-version ( -- version )
+ (gl-version) drop ;
+: gl-vendor-version ( -- version )
+ (gl-version) nip ;
+: has-gl-version? ( version -- ? )
+ gl-version version-before? ;
+: (make-gl-version-error) ( required-version -- )
+ "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
+: require-gl-version ( version -- )
+ [ has-gl-version? ]
+ [ (make-gl-version-error) ]
+ (require-gl) ;
+
+: (glsl-version) ( -- version vendor )
+ GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ;
+: glsl-version ( -- version )
+ (glsl-version) drop ;
+: glsl-vendor-version ( -- version )
+ (glsl-version) nip ;
+: has-glsl-version? ( version -- ? )
+ glsl-version version-before? ;
+: require-glsl-version ( version -- )
+ [ has-glsl-version? ]
+ [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
+ (require-gl) ;
+
+: has-gl-version-or-extensions? ( version extensions -- ? )
+ has-gl-extensions? swap has-gl-version? or ;
+
+: require-gl-version-or-extensions ( version extensions -- )
+ 2array [ first2 has-gl-version-or-extensions? ] [
+ dup first (make-gl-version-error) "\n" %
+ second (make-gl-extensions-error) "\n" %
+ ] (require-gl) ;
--- /dev/null
+Testing for OpenGL versions and extensions
\ No newline at end of file
--- /dev/null
+opengl
+bindings
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs ;
+IN: opengl.framebuffers
+
+HELP: gen-framebuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
+
+HELP: gen-renderbuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
+
+HELP: delete-framebuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
+
+HELP: delete-renderbuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
+
+{ gen-framebuffer delete-framebuffer } related-words
+{ gen-renderbuffer delete-renderbuffer } related-words
+
+HELP: framebuffer-incomplete?
+{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
+
+HELP: check-framebuffer
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
+
+HELP: with-framebuffer
+{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
+{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
+
+ABOUT: "gl-utilities"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: opengl opengl.gl combinators continuations kernel
+alien.c-types ;
+IN: opengl.framebuffers
+
+: gen-framebuffer ( -- id )
+ [ glGenFramebuffersEXT ] (gen-gl-object) ;
+: gen-renderbuffer ( -- id )
+ [ glGenRenderbuffersEXT ] (gen-gl-object) ;
+
+: delete-framebuffer ( id -- )
+ [ glDeleteFramebuffersEXT ] (delete-gl-object) ;
+: delete-renderbuffer ( id -- )
+ [ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
+
+: framebuffer-incomplete? ( -- status/f )
+ GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
+ dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
+
+: framebuffer-error ( status -- * )
+ {
+ { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
+ { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
+ [ drop gl-error "unknown framebuffer error" ]
+ } case throw ;
+
+: check-framebuffer ( -- )
+ framebuffer-incomplete? [ framebuffer-error ] when* ;
+
+: with-framebuffer ( id quot -- )
+ GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
+ [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
+
+: framebuffer-attachment ( attachment -- id )
+ GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
+ 0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
--- /dev/null
+Rendering to offscreen textures using the GL_EXT_framebuffer_object extension
\ No newline at end of file
--- /dev/null
+opengl
+bindings
USING: alien alien.syntax alien.parser combinators
kernel parser sequences system words namespaces hashtables init
-math arrays assocs continuations lexer fry locals ;
+math arrays assocs continuations lexer fry locals vocabs.parser ;
IN: opengl.gl.extensions
ERROR: unknown-gl-platform ;
! Constants
! Boolean values
-: GL_FALSE HEX: 0 ; inline
-: GL_TRUE HEX: 1 ; inline
+CONSTANT: GL_FALSE HEX: 0
+CONSTANT: GL_TRUE HEX: 1
! Data types
-: GL_BYTE HEX: 1400 ; inline
-: GL_UNSIGNED_BYTE HEX: 1401 ; inline
-: GL_SHORT HEX: 1402 ; inline
-: GL_UNSIGNED_SHORT HEX: 1403 ; inline
-: GL_INT HEX: 1404 ; inline
-: GL_UNSIGNED_INT HEX: 1405 ; inline
-: GL_FLOAT HEX: 1406 ; inline
-: GL_2_BYTES HEX: 1407 ; inline
-: GL_3_BYTES HEX: 1408 ; inline
-: GL_4_BYTES HEX: 1409 ; inline
-: GL_DOUBLE HEX: 140A ; inline
+CONSTANT: GL_BYTE HEX: 1400
+CONSTANT: GL_UNSIGNED_BYTE HEX: 1401
+CONSTANT: GL_SHORT HEX: 1402
+CONSTANT: GL_UNSIGNED_SHORT HEX: 1403
+CONSTANT: GL_INT HEX: 1404
+CONSTANT: GL_UNSIGNED_INT HEX: 1405
+CONSTANT: GL_FLOAT HEX: 1406
+CONSTANT: GL_2_BYTES HEX: 1407
+CONSTANT: GL_3_BYTES HEX: 1408
+CONSTANT: GL_4_BYTES HEX: 1409
+CONSTANT: GL_DOUBLE HEX: 140A
! Primitives
-: GL_POINTS HEX: 0000 ; inline
-: GL_LINES HEX: 0001 ; inline
-: GL_LINE_LOOP HEX: 0002 ; inline
-: GL_LINE_STRIP HEX: 0003 ; inline
-: GL_TRIANGLES HEX: 0004 ; inline
-: GL_TRIANGLE_STRIP HEX: 0005 ; inline
-: GL_TRIANGLE_FAN HEX: 0006 ; inline
-: GL_QUADS HEX: 0007 ; inline
-: GL_QUAD_STRIP HEX: 0008 ; inline
-: GL_POLYGON HEX: 0009 ; inline
+CONSTANT: GL_POINTS HEX: 0000
+CONSTANT: GL_LINES HEX: 0001
+CONSTANT: GL_LINE_LOOP HEX: 0002
+CONSTANT: GL_LINE_STRIP HEX: 0003
+CONSTANT: GL_TRIANGLES HEX: 0004
+CONSTANT: GL_TRIANGLE_STRIP HEX: 0005
+CONSTANT: GL_TRIANGLE_FAN HEX: 0006
+CONSTANT: GL_QUADS HEX: 0007
+CONSTANT: GL_QUAD_STRIP HEX: 0008
+CONSTANT: GL_POLYGON HEX: 0009
! Vertex arrays
-: GL_VERTEX_ARRAY HEX: 8074 ; inline
-: GL_NORMAL_ARRAY HEX: 8075 ; inline
-: GL_COLOR_ARRAY HEX: 8076 ; inline
-: GL_INDEX_ARRAY HEX: 8077 ; inline
-: GL_TEXTURE_COORD_ARRAY HEX: 8078 ; inline
-: GL_EDGE_FLAG_ARRAY HEX: 8079 ; inline
-: GL_VERTEX_ARRAY_SIZE HEX: 807A ; inline
-: GL_VERTEX_ARRAY_TYPE HEX: 807B ; inline
-: GL_VERTEX_ARRAY_STRIDE HEX: 807C ; inline
-: GL_NORMAL_ARRAY_TYPE HEX: 807E ; inline
-: GL_NORMAL_ARRAY_STRIDE HEX: 807F ; inline
-: GL_COLOR_ARRAY_SIZE HEX: 8081 ; inline
-: GL_COLOR_ARRAY_TYPE HEX: 8082 ; inline
-: GL_COLOR_ARRAY_STRIDE HEX: 8083 ; inline
-: GL_INDEX_ARRAY_TYPE HEX: 8085 ; inline
-: GL_INDEX_ARRAY_STRIDE HEX: 8086 ; inline
-: GL_TEXTURE_COORD_ARRAY_SIZE HEX: 8088 ; inline
-: GL_TEXTURE_COORD_ARRAY_TYPE HEX: 8089 ; inline
-: GL_TEXTURE_COORD_ARRAY_STRIDE HEX: 808A ; inline
-: GL_EDGE_FLAG_ARRAY_STRIDE HEX: 808C ; inline
-: GL_VERTEX_ARRAY_POINTER HEX: 808E ; inline
-: GL_NORMAL_ARRAY_POINTER HEX: 808F ; inline
-: GL_COLOR_ARRAY_POINTER HEX: 8090 ; inline
-: GL_INDEX_ARRAY_POINTER HEX: 8091 ; inline
-: GL_TEXTURE_COORD_ARRAY_POINTER HEX: 8092 ; inline
-: GL_EDGE_FLAG_ARRAY_POINTER HEX: 8093 ; inline
-: GL_V2F HEX: 2A20 ; inline
-: GL_V3F HEX: 2A21 ; inline
-: GL_C4UB_V2F HEX: 2A22 ; inline
-: GL_C4UB_V3F HEX: 2A23 ; inline
-: GL_C3F_V3F HEX: 2A24 ; inline
-: GL_N3F_V3F HEX: 2A25 ; inline
-: GL_C4F_N3F_V3F HEX: 2A26 ; inline
-: GL_T2F_V3F HEX: 2A27 ; inline
-: GL_T4F_V4F HEX: 2A28 ; inline
-: GL_T2F_C4UB_V3F HEX: 2A29 ; inline
-: GL_T2F_C3F_V3F HEX: 2A2A ; inline
-: GL_T2F_N3F_V3F HEX: 2A2B ; inline
-: GL_T2F_C4F_N3F_V3F HEX: 2A2C ; inline
-: GL_T4F_C4F_N3F_V4F HEX: 2A2D ; inline
+CONSTANT: GL_VERTEX_ARRAY HEX: 8074
+CONSTANT: GL_NORMAL_ARRAY HEX: 8075
+CONSTANT: GL_COLOR_ARRAY HEX: 8076
+CONSTANT: GL_INDEX_ARRAY HEX: 8077
+CONSTANT: GL_TEXTURE_COORD_ARRAY HEX: 8078
+CONSTANT: GL_EDGE_FLAG_ARRAY HEX: 8079
+CONSTANT: GL_VERTEX_ARRAY_SIZE HEX: 807A
+CONSTANT: GL_VERTEX_ARRAY_TYPE HEX: 807B
+CONSTANT: GL_VERTEX_ARRAY_STRIDE HEX: 807C
+CONSTANT: GL_NORMAL_ARRAY_TYPE HEX: 807E
+CONSTANT: GL_NORMAL_ARRAY_STRIDE HEX: 807F
+CONSTANT: GL_COLOR_ARRAY_SIZE HEX: 8081
+CONSTANT: GL_COLOR_ARRAY_TYPE HEX: 8082
+CONSTANT: GL_COLOR_ARRAY_STRIDE HEX: 8083
+CONSTANT: GL_INDEX_ARRAY_TYPE HEX: 8085
+CONSTANT: GL_INDEX_ARRAY_STRIDE HEX: 8086
+CONSTANT: GL_TEXTURE_COORD_ARRAY_SIZE HEX: 8088
+CONSTANT: GL_TEXTURE_COORD_ARRAY_TYPE HEX: 8089
+CONSTANT: GL_TEXTURE_COORD_ARRAY_STRIDE HEX: 808A
+CONSTANT: GL_EDGE_FLAG_ARRAY_STRIDE HEX: 808C
+CONSTANT: GL_VERTEX_ARRAY_POINTER HEX: 808E
+CONSTANT: GL_NORMAL_ARRAY_POINTER HEX: 808F
+CONSTANT: GL_COLOR_ARRAY_POINTER HEX: 8090
+CONSTANT: GL_INDEX_ARRAY_POINTER HEX: 8091
+CONSTANT: GL_TEXTURE_COORD_ARRAY_POINTER HEX: 8092
+CONSTANT: GL_EDGE_FLAG_ARRAY_POINTER HEX: 8093
+CONSTANT: GL_V2F HEX: 2A20
+CONSTANT: GL_V3F HEX: 2A21
+CONSTANT: GL_C4UB_V2F HEX: 2A22
+CONSTANT: GL_C4UB_V3F HEX: 2A23
+CONSTANT: GL_C3F_V3F HEX: 2A24
+CONSTANT: GL_N3F_V3F HEX: 2A25
+CONSTANT: GL_C4F_N3F_V3F HEX: 2A26
+CONSTANT: GL_T2F_V3F HEX: 2A27
+CONSTANT: GL_T4F_V4F HEX: 2A28
+CONSTANT: GL_T2F_C4UB_V3F HEX: 2A29
+CONSTANT: GL_T2F_C3F_V3F HEX: 2A2A
+CONSTANT: GL_T2F_N3F_V3F HEX: 2A2B
+CONSTANT: GL_T2F_C4F_N3F_V3F HEX: 2A2C
+CONSTANT: GL_T4F_C4F_N3F_V4F HEX: 2A2D
! Matrix mode
-: GL_MATRIX_MODE HEX: 0BA0 ; inline
-: GL_MODELVIEW HEX: 1700 ; inline
-: GL_PROJECTION HEX: 1701 ; inline
-: GL_TEXTURE HEX: 1702 ; inline
+CONSTANT: GL_MATRIX_MODE HEX: 0BA0
+CONSTANT: GL_MODELVIEW HEX: 1700
+CONSTANT: GL_PROJECTION HEX: 1701
+CONSTANT: GL_TEXTURE HEX: 1702
! Points
-: GL_POINT_SMOOTH HEX: 0B10 ; inline
-: GL_POINT_SIZE HEX: 0B11 ; inline
-: GL_POINT_SIZE_GRANULARITY HEX: 0B13 ; inline
-: GL_POINT_SIZE_RANGE HEX: 0B12 ; inline
+CONSTANT: GL_POINT_SMOOTH HEX: 0B10
+CONSTANT: GL_POINT_SIZE HEX: 0B11
+CONSTANT: GL_POINT_SIZE_GRANULARITY HEX: 0B13
+CONSTANT: GL_POINT_SIZE_RANGE HEX: 0B12
! Lines
-: GL_LINE_SMOOTH HEX: 0B20 ; inline
-: GL_LINE_STIPPLE HEX: 0B24 ; inline
-: GL_LINE_STIPPLE_PATTERN HEX: 0B25 ; inline
-: GL_LINE_STIPPLE_REPEAT HEX: 0B26 ; inline
-: GL_LINE_WIDTH HEX: 0B21 ; inline
-: GL_LINE_WIDTH_GRANULARITY HEX: 0B23 ; inline
-: GL_LINE_WIDTH_RANGE HEX: 0B22 ; inline
+CONSTANT: GL_LINE_SMOOTH HEX: 0B20
+CONSTANT: GL_LINE_STIPPLE HEX: 0B24
+CONSTANT: GL_LINE_STIPPLE_PATTERN HEX: 0B25
+CONSTANT: GL_LINE_STIPPLE_REPEAT HEX: 0B26
+CONSTANT: GL_LINE_WIDTH HEX: 0B21
+CONSTANT: GL_LINE_WIDTH_GRANULARITY HEX: 0B23
+CONSTANT: GL_LINE_WIDTH_RANGE HEX: 0B22
! Polygons
-: GL_POINT HEX: 1B00 ; inline
-: GL_LINE HEX: 1B01 ; inline
-: GL_FILL HEX: 1B02 ; inline
-: GL_CW HEX: 0900 ; inline
-: GL_CCW HEX: 0901 ; inline
-: GL_FRONT HEX: 0404 ; inline
-: GL_BACK HEX: 0405 ; inline
-: GL_POLYGON_MODE HEX: 0B40 ; inline
-: GL_POLYGON_SMOOTH HEX: 0B41 ; inline
-: GL_POLYGON_STIPPLE HEX: 0B42 ; inline
-: GL_EDGE_FLAG HEX: 0B43 ; inline
-: GL_CULL_FACE HEX: 0B44 ; inline
-: GL_CULL_FACE_MODE HEX: 0B45 ; inline
-: GL_FRONT_FACE HEX: 0B46 ; inline
-: GL_POLYGON_OFFSET_FACTOR HEX: 8038 ; inline
-: GL_POLYGON_OFFSET_UNITS HEX: 2A00 ; inline
-: GL_POLYGON_OFFSET_POINT HEX: 2A01 ; inline
-: GL_POLYGON_OFFSET_LINE HEX: 2A02 ; inline
-: GL_POLYGON_OFFSET_FILL HEX: 8037 ; inline
+CONSTANT: GL_POINT HEX: 1B00
+CONSTANT: GL_LINE HEX: 1B01
+CONSTANT: GL_FILL HEX: 1B02
+CONSTANT: GL_CW HEX: 0900
+CONSTANT: GL_CCW HEX: 0901
+CONSTANT: GL_FRONT HEX: 0404
+CONSTANT: GL_BACK HEX: 0405
+CONSTANT: GL_POLYGON_MODE HEX: 0B40
+CONSTANT: GL_POLYGON_SMOOTH HEX: 0B41
+CONSTANT: GL_POLYGON_STIPPLE HEX: 0B42
+CONSTANT: GL_EDGE_FLAG HEX: 0B43
+CONSTANT: GL_CULL_FACE HEX: 0B44
+CONSTANT: GL_CULL_FACE_MODE HEX: 0B45
+CONSTANT: GL_FRONT_FACE HEX: 0B46
+CONSTANT: GL_POLYGON_OFFSET_FACTOR HEX: 8038
+CONSTANT: GL_POLYGON_OFFSET_UNITS HEX: 2A00
+CONSTANT: GL_POLYGON_OFFSET_POINT HEX: 2A01
+CONSTANT: GL_POLYGON_OFFSET_LINE HEX: 2A02
+CONSTANT: GL_POLYGON_OFFSET_FILL HEX: 8037
! Display Lists
-: GL_COMPILE HEX: 1300 ; inline
-: GL_COMPILE_AND_EXECUTE HEX: 1301 ; inline
-: GL_LIST_BASE HEX: 0B32 ; inline
-: GL_LIST_INDEX HEX: 0B33 ; inline
-: GL_LIST_MODE HEX: 0B30 ; inline
+CONSTANT: GL_COMPILE HEX: 1300
+CONSTANT: GL_COMPILE_AND_EXECUTE HEX: 1301
+CONSTANT: GL_LIST_BASE HEX: 0B32
+CONSTANT: GL_LIST_INDEX HEX: 0B33
+CONSTANT: GL_LIST_MODE HEX: 0B30
! Depth buffer
-: GL_NEVER HEX: 0200 ; inline
-: GL_LESS HEX: 0201 ; inline
-: GL_EQUAL HEX: 0202 ; inline
-: GL_LEQUAL HEX: 0203 ; inline
-: GL_GREATER HEX: 0204 ; inline
-: GL_NOTEQUAL HEX: 0205 ; inline
-: GL_GEQUAL HEX: 0206 ; inline
-: GL_ALWAYS HEX: 0207 ; inline
-: GL_DEPTH_TEST HEX: 0B71 ; inline
-: GL_DEPTH_BITS HEX: 0D56 ; inline
-: GL_DEPTH_CLEAR_VALUE HEX: 0B73 ; inline
-: GL_DEPTH_FUNC HEX: 0B74 ; inline
-: GL_DEPTH_RANGE HEX: 0B70 ; inline
-: GL_DEPTH_WRITEMASK HEX: 0B72 ; inline
-: GL_DEPTH_COMPONENT HEX: 1902 ; inline
+CONSTANT: GL_NEVER HEX: 0200
+CONSTANT: GL_LESS HEX: 0201
+CONSTANT: GL_EQUAL HEX: 0202
+CONSTANT: GL_LEQUAL HEX: 0203
+CONSTANT: GL_GREATER HEX: 0204
+CONSTANT: GL_NOTEQUAL HEX: 0205
+CONSTANT: GL_GEQUAL HEX: 0206
+CONSTANT: GL_ALWAYS HEX: 0207
+CONSTANT: GL_DEPTH_TEST HEX: 0B71
+CONSTANT: GL_DEPTH_BITS HEX: 0D56
+CONSTANT: GL_DEPTH_CLEAR_VALUE HEX: 0B73
+CONSTANT: GL_DEPTH_FUNC HEX: 0B74
+CONSTANT: GL_DEPTH_RANGE HEX: 0B70
+CONSTANT: GL_DEPTH_WRITEMASK HEX: 0B72
+CONSTANT: GL_DEPTH_COMPONENT HEX: 1902
! Lighting
-: GL_LIGHTING HEX: 0B50 ; inline
-: GL_LIGHT0 HEX: 4000 ; inline
-: GL_LIGHT1 HEX: 4001 ; inline
-: GL_LIGHT2 HEX: 4002 ; inline
-: GL_LIGHT3 HEX: 4003 ; inline
-: GL_LIGHT4 HEX: 4004 ; inline
-: GL_LIGHT5 HEX: 4005 ; inline
-: GL_LIGHT6 HEX: 4006 ; inline
-: GL_LIGHT7 HEX: 4007 ; inline
-: GL_SPOT_EXPONENT HEX: 1205 ; inline
-: GL_SPOT_CUTOFF HEX: 1206 ; inline
-: GL_CONSTANT_ATTENUATION HEX: 1207 ; inline
-: GL_LINEAR_ATTENUATION HEX: 1208 ; inline
-: GL_QUADRATIC_ATTENUATION HEX: 1209 ; inline
-: GL_AMBIENT HEX: 1200 ; inline
-: GL_DIFFUSE HEX: 1201 ; inline
-: GL_SPECULAR HEX: 1202 ; inline
-: GL_SHININESS HEX: 1601 ; inline
-: GL_EMISSION HEX: 1600 ; inline
-: GL_POSITION HEX: 1203 ; inline
-: GL_SPOT_DIRECTION HEX: 1204 ; inline
-: GL_AMBIENT_AND_DIFFUSE HEX: 1602 ; inline
-: GL_COLOR_INDEXES HEX: 1603 ; inline
-: GL_LIGHT_MODEL_TWO_SIDE HEX: 0B52 ; inline
-: GL_LIGHT_MODEL_LOCAL_VIEWER HEX: 0B51 ; inline
-: GL_LIGHT_MODEL_AMBIENT HEX: 0B53 ; inline
-: GL_FRONT_AND_BACK HEX: 0408 ; inline
-: GL_SHADE_MODEL HEX: 0B54 ; inline
-: GL_FLAT HEX: 1D00 ; inline
-: GL_SMOOTH HEX: 1D01 ; inline
-: GL_COLOR_MATERIAL HEX: 0B57 ; inline
-: GL_COLOR_MATERIAL_FACE HEX: 0B55 ; inline
-: GL_COLOR_MATERIAL_PARAMETER HEX: 0B56 ; inline
-: GL_NORMALIZE HEX: 0BA1 ; inline
+CONSTANT: GL_LIGHTING HEX: 0B50
+CONSTANT: GL_LIGHT0 HEX: 4000
+CONSTANT: GL_LIGHT1 HEX: 4001
+CONSTANT: GL_LIGHT2 HEX: 4002
+CONSTANT: GL_LIGHT3 HEX: 4003
+CONSTANT: GL_LIGHT4 HEX: 4004
+CONSTANT: GL_LIGHT5 HEX: 4005
+CONSTANT: GL_LIGHT6 HEX: 4006
+CONSTANT: GL_LIGHT7 HEX: 4007
+CONSTANT: GL_SPOT_EXPONENT HEX: 1205
+CONSTANT: GL_SPOT_CUTOFF HEX: 1206
+CONSTANT: GL_CONSTANT_ATTENUATION HEX: 1207
+CONSTANT: GL_LINEAR_ATTENUATION HEX: 1208
+CONSTANT: GL_QUADRATIC_ATTENUATION HEX: 1209
+CONSTANT: GL_AMBIENT HEX: 1200
+CONSTANT: GL_DIFFUSE HEX: 1201
+CONSTANT: GL_SPECULAR HEX: 1202
+CONSTANT: GL_SHININESS HEX: 1601
+CONSTANT: GL_EMISSION HEX: 1600
+CONSTANT: GL_POSITION HEX: 1203
+CONSTANT: GL_SPOT_DIRECTION HEX: 1204
+CONSTANT: GL_AMBIENT_AND_DIFFUSE HEX: 1602
+CONSTANT: GL_COLOR_INDEXES HEX: 1603
+CONSTANT: GL_LIGHT_MODEL_TWO_SIDE HEX: 0B52
+CONSTANT: GL_LIGHT_MODEL_LOCAL_VIEWER HEX: 0B51
+CONSTANT: GL_LIGHT_MODEL_AMBIENT HEX: 0B53
+CONSTANT: GL_FRONT_AND_BACK HEX: 0408
+CONSTANT: GL_SHADE_MODEL HEX: 0B54
+CONSTANT: GL_FLAT HEX: 1D00
+CONSTANT: GL_SMOOTH HEX: 1D01
+CONSTANT: GL_COLOR_MATERIAL HEX: 0B57
+CONSTANT: GL_COLOR_MATERIAL_FACE HEX: 0B55
+CONSTANT: GL_COLOR_MATERIAL_PARAMETER HEX: 0B56
+CONSTANT: GL_NORMALIZE HEX: 0BA1
! User clipping planes
-: GL_CLIP_PLANE0 HEX: 3000 ; inline
-: GL_CLIP_PLANE1 HEX: 3001 ; inline
-: GL_CLIP_PLANE2 HEX: 3002 ; inline
-: GL_CLIP_PLANE3 HEX: 3003 ; inline
-: GL_CLIP_PLANE4 HEX: 3004 ; inline
-: GL_CLIP_PLANE5 HEX: 3005 ; inline
+CONSTANT: GL_CLIP_PLANE0 HEX: 3000
+CONSTANT: GL_CLIP_PLANE1 HEX: 3001
+CONSTANT: GL_CLIP_PLANE2 HEX: 3002
+CONSTANT: GL_CLIP_PLANE3 HEX: 3003
+CONSTANT: GL_CLIP_PLANE4 HEX: 3004
+CONSTANT: GL_CLIP_PLANE5 HEX: 3005
! Accumulation buffer
-: GL_ACCUM_RED_BITS HEX: 0D58 ; inline
-: GL_ACCUM_GREEN_BITS HEX: 0D59 ; inline
-: GL_ACCUM_BLUE_BITS HEX: 0D5A ; inline
-: GL_ACCUM_ALPHA_BITS HEX: 0D5B ; inline
-: GL_ACCUM_CLEAR_VALUE HEX: 0B80 ; inline
-: GL_ACCUM HEX: 0100 ; inline
-: GL_ADD HEX: 0104 ; inline
-: GL_LOAD HEX: 0101 ; inline
-: GL_MULT HEX: 0103 ; inline
-: GL_RETURN HEX: 0102 ; inline
+CONSTANT: GL_ACCUM_RED_BITS HEX: 0D58
+CONSTANT: GL_ACCUM_GREEN_BITS HEX: 0D59
+CONSTANT: GL_ACCUM_BLUE_BITS HEX: 0D5A
+CONSTANT: GL_ACCUM_ALPHA_BITS HEX: 0D5B
+CONSTANT: GL_ACCUM_CLEAR_VALUE HEX: 0B80
+CONSTANT: GL_ACCUM HEX: 0100
+CONSTANT: GL_ADD HEX: 0104
+CONSTANT: GL_LOAD HEX: 0101
+CONSTANT: GL_MULT HEX: 0103
+CONSTANT: GL_RETURN HEX: 0102
! Alpha testing
-: GL_ALPHA_TEST HEX: 0BC0 ; inline
-: GL_ALPHA_TEST_REF HEX: 0BC2 ; inline
-: GL_ALPHA_TEST_FUNC HEX: 0BC1 ; inline
+CONSTANT: GL_ALPHA_TEST HEX: 0BC0
+CONSTANT: GL_ALPHA_TEST_REF HEX: 0BC2
+CONSTANT: GL_ALPHA_TEST_FUNC HEX: 0BC1
! Blending
-: GL_BLEND HEX: 0BE2 ; inline
-: GL_BLEND_SRC HEX: 0BE1 ; inline
-: GL_BLEND_DST HEX: 0BE0 ; inline
-: GL_ZERO HEX: 0 ; inline
-: GL_ONE HEX: 1 ; inline
-: GL_SRC_COLOR HEX: 0300 ; inline
-: GL_ONE_MINUS_SRC_COLOR HEX: 0301 ; inline
-: GL_SRC_ALPHA HEX: 0302 ; inline
-: GL_ONE_MINUS_SRC_ALPHA HEX: 0303 ; inline
-: GL_DST_ALPHA HEX: 0304 ; inline
-: GL_ONE_MINUS_DST_ALPHA HEX: 0305 ; inline
-: GL_DST_COLOR HEX: 0306 ; inline
-: GL_ONE_MINUS_DST_COLOR HEX: 0307 ; inline
-: GL_SRC_ALPHA_SATURATE HEX: 0308 ; inline
+CONSTANT: GL_BLEND HEX: 0BE2
+CONSTANT: GL_BLEND_SRC HEX: 0BE1
+CONSTANT: GL_BLEND_DST HEX: 0BE0
+CONSTANT: GL_ZERO HEX: 0
+CONSTANT: GL_ONE HEX: 1
+CONSTANT: GL_SRC_COLOR HEX: 0300
+CONSTANT: GL_ONE_MINUS_SRC_COLOR HEX: 0301
+CONSTANT: GL_SRC_ALPHA HEX: 0302
+CONSTANT: GL_ONE_MINUS_SRC_ALPHA HEX: 0303
+CONSTANT: GL_DST_ALPHA HEX: 0304
+CONSTANT: GL_ONE_MINUS_DST_ALPHA HEX: 0305
+CONSTANT: GL_DST_COLOR HEX: 0306
+CONSTANT: GL_ONE_MINUS_DST_COLOR HEX: 0307
+CONSTANT: GL_SRC_ALPHA_SATURATE HEX: 0308
! Render Mode
-: GL_FEEDBACK HEX: 1C01 ; inline
-: GL_RENDER HEX: 1C00 ; inline
-: GL_SELECT HEX: 1C02 ; inline
+CONSTANT: GL_FEEDBACK HEX: 1C01
+CONSTANT: GL_RENDER HEX: 1C00
+CONSTANT: GL_SELECT HEX: 1C02
! Feedback
-: GL_2D HEX: 0600 ; inline
-: GL_3D HEX: 0601 ; inline
-: GL_3D_COLOR HEX: 0602 ; inline
-: GL_3D_COLOR_TEXTURE HEX: 0603 ; inline
-: GL_4D_COLOR_TEXTURE HEX: 0604 ; inline
-: GL_POINT_TOKEN HEX: 0701 ; inline
-: GL_LINE_TOKEN HEX: 0702 ; inline
-: GL_LINE_RESET_TOKEN HEX: 0707 ; inline
-: GL_POLYGON_TOKEN HEX: 0703 ; inline
-: GL_BITMAP_TOKEN HEX: 0704 ; inline
-: GL_DRAW_PIXEL_TOKEN HEX: 0705 ; inline
-: GL_COPY_PIXEL_TOKEN HEX: 0706 ; inline
-: GL_PASS_THROUGH_TOKEN HEX: 0700 ; inline
-: GL_FEEDBACK_BUFFER_POINTER HEX: 0DF0 ; inline
-: GL_FEEDBACK_BUFFER_SIZE HEX: 0DF1 ; inline
-: GL_FEEDBACK_BUFFER_TYPE HEX: 0DF2 ; inline
+CONSTANT: GL_2D HEX: 0600
+CONSTANT: GL_3D HEX: 0601
+CONSTANT: GL_3D_COLOR HEX: 0602
+CONSTANT: GL_3D_COLOR_TEXTURE HEX: 0603
+CONSTANT: GL_4D_COLOR_TEXTURE HEX: 0604
+CONSTANT: GL_POINT_TOKEN HEX: 0701
+CONSTANT: GL_LINE_TOKEN HEX: 0702
+CONSTANT: GL_LINE_RESET_TOKEN HEX: 0707
+CONSTANT: GL_POLYGON_TOKEN HEX: 0703
+CONSTANT: GL_BITMAP_TOKEN HEX: 0704
+CONSTANT: GL_DRAW_PIXEL_TOKEN HEX: 0705
+CONSTANT: GL_COPY_PIXEL_TOKEN HEX: 0706
+CONSTANT: GL_PASS_THROUGH_TOKEN HEX: 0700
+CONSTANT: GL_FEEDBACK_BUFFER_POINTER HEX: 0DF0
+CONSTANT: GL_FEEDBACK_BUFFER_SIZE HEX: 0DF1
+CONSTANT: GL_FEEDBACK_BUFFER_TYPE HEX: 0DF2
! Selection
-: GL_SELECTION_BUFFER_POINTER HEX: 0DF3 ; inline
-: GL_SELECTION_BUFFER_SIZE HEX: 0DF4 ; inline
+CONSTANT: GL_SELECTION_BUFFER_POINTER HEX: 0DF3
+CONSTANT: GL_SELECTION_BUFFER_SIZE HEX: 0DF4
! Fog
-: GL_FOG HEX: 0B60 ; inline
-: GL_FOG_MODE HEX: 0B65 ; inline
-: GL_FOG_DENSITY HEX: 0B62 ; inline
-: GL_FOG_COLOR HEX: 0B66 ; inline
-: GL_FOG_INDEX HEX: 0B61 ; inline
-: GL_FOG_START HEX: 0B63 ; inline
-: GL_FOG_END HEX: 0B64 ; inline
-: GL_LINEAR HEX: 2601 ; inline
-: GL_EXP HEX: 0800 ; inline
-: GL_EXP2 HEX: 0801 ; inline
+CONSTANT: GL_FOG HEX: 0B60
+CONSTANT: GL_FOG_MODE HEX: 0B65
+CONSTANT: GL_FOG_DENSITY HEX: 0B62
+CONSTANT: GL_FOG_COLOR HEX: 0B66
+CONSTANT: GL_FOG_INDEX HEX: 0B61
+CONSTANT: GL_FOG_START HEX: 0B63
+CONSTANT: GL_FOG_END HEX: 0B64
+CONSTANT: GL_LINEAR HEX: 2601
+CONSTANT: GL_EXP HEX: 0800
+CONSTANT: GL_EXP2 HEX: 0801
! Logic Ops
-: GL_LOGIC_OP HEX: 0BF1 ; inline
-: GL_INDEX_LOGIC_OP HEX: 0BF1 ; inline
-: GL_COLOR_LOGIC_OP HEX: 0BF2 ; inline
-: GL_LOGIC_OP_MODE HEX: 0BF0 ; inline
-: GL_CLEAR HEX: 1500 ; inline
-: GL_SET HEX: 150F ; inline
-: GL_COPY HEX: 1503 ; inline
-: GL_COPY_INVERTED HEX: 150C ; inline
-: GL_NOOP HEX: 1505 ; inline
-: GL_INVERT HEX: 150A ; inline
-: GL_AND HEX: 1501 ; inline
-: GL_NAND HEX: 150E ; inline
-: GL_OR HEX: 1507 ; inline
-: GL_NOR HEX: 1508 ; inline
-: GL_XOR HEX: 1506 ; inline
-: GL_EQUIV HEX: 1509 ; inline
-: GL_AND_REVERSE HEX: 1502 ; inline
-: GL_AND_INVERTED HEX: 1504 ; inline
-: GL_OR_REVERSE HEX: 150B ; inline
-: GL_OR_INVERTED HEX: 150D ; inline
+CONSTANT: GL_LOGIC_OP HEX: 0BF1
+CONSTANT: GL_INDEX_LOGIC_OP HEX: 0BF1
+CONSTANT: GL_COLOR_LOGIC_OP HEX: 0BF2
+CONSTANT: GL_LOGIC_OP_MODE HEX: 0BF0
+CONSTANT: GL_CLEAR HEX: 1500
+CONSTANT: GL_SET HEX: 150F
+CONSTANT: GL_COPY HEX: 1503
+CONSTANT: GL_COPY_INVERTED HEX: 150C
+CONSTANT: GL_NOOP HEX: 1505
+CONSTANT: GL_INVERT HEX: 150A
+CONSTANT: GL_AND HEX: 1501
+CONSTANT: GL_NAND HEX: 150E
+CONSTANT: GL_OR HEX: 1507
+CONSTANT: GL_NOR HEX: 1508
+CONSTANT: GL_XOR HEX: 1506
+CONSTANT: GL_EQUIV HEX: 1509
+CONSTANT: GL_AND_REVERSE HEX: 1502
+CONSTANT: GL_AND_INVERTED HEX: 1504
+CONSTANT: GL_OR_REVERSE HEX: 150B
+CONSTANT: GL_OR_INVERTED HEX: 150D
! Stencil
-: GL_STENCIL_TEST HEX: 0B90 ; inline
-: GL_STENCIL_WRITEMASK HEX: 0B98 ; inline
-: GL_STENCIL_BITS HEX: 0D57 ; inline
-: GL_STENCIL_FUNC HEX: 0B92 ; inline
-: GL_STENCIL_VALUE_MASK HEX: 0B93 ; inline
-: GL_STENCIL_REF HEX: 0B97 ; inline
-: GL_STENCIL_FAIL HEX: 0B94 ; inline
-: GL_STENCIL_PASS_DEPTH_PASS HEX: 0B96 ; inline
-: GL_STENCIL_PASS_DEPTH_FAIL HEX: 0B95 ; inline
-: GL_STENCIL_CLEAR_VALUE HEX: 0B91 ; inline
-: GL_STENCIL_INDEX HEX: 1901 ; inline
-: GL_KEEP HEX: 1E00 ; inline
-: GL_REPLACE HEX: 1E01 ; inline
-: GL_INCR HEX: 1E02 ; inline
-: GL_DECR HEX: 1E03 ; inline
+CONSTANT: GL_STENCIL_TEST HEX: 0B90
+CONSTANT: GL_STENCIL_WRITEMASK HEX: 0B98
+CONSTANT: GL_STENCIL_BITS HEX: 0D57
+CONSTANT: GL_STENCIL_FUNC HEX: 0B92
+CONSTANT: GL_STENCIL_VALUE_MASK HEX: 0B93
+CONSTANT: GL_STENCIL_REF HEX: 0B97
+CONSTANT: GL_STENCIL_FAIL HEX: 0B94
+CONSTANT: GL_STENCIL_PASS_DEPTH_PASS HEX: 0B96
+CONSTANT: GL_STENCIL_PASS_DEPTH_FAIL HEX: 0B95
+CONSTANT: GL_STENCIL_CLEAR_VALUE HEX: 0B91
+CONSTANT: GL_STENCIL_INDEX HEX: 1901
+CONSTANT: GL_KEEP HEX: 1E00
+CONSTANT: GL_REPLACE HEX: 1E01
+CONSTANT: GL_INCR HEX: 1E02
+CONSTANT: GL_DECR HEX: 1E03
! Buffers, Pixel Drawing/Reading
-: GL_NONE HEX: 0 ; inline
-: GL_LEFT HEX: 0406 ; inline
-: GL_RIGHT HEX: 0407 ; inline
-! defined elsewhere
-! GL_FRONT HEX: 0404
-! GL_BACK HEX: 0405
-! GL_FRONT_AND_BACK HEX: 0408
-: GL_FRONT_LEFT HEX: 0400 ; inline
-: GL_FRONT_RIGHT HEX: 0401 ; inline
-: GL_BACK_LEFT HEX: 0402 ; inline
-: GL_BACK_RIGHT HEX: 0403 ; inline
-: GL_AUX0 HEX: 0409 ; inline
-: GL_AUX1 HEX: 040A ; inline
-: GL_AUX2 HEX: 040B ; inline
-: GL_AUX3 HEX: 040C ; inline
-: GL_COLOR_INDEX HEX: 1900 ; inline
-: GL_RED HEX: 1903 ; inline
-: GL_GREEN HEX: 1904 ; inline
-: GL_BLUE HEX: 1905 ; inline
-: GL_ALPHA HEX: 1906 ; inline
-: GL_LUMINANCE HEX: 1909 ; inline
-: GL_LUMINANCE_ALPHA HEX: 190A ; inline
-: GL_ALPHA_BITS HEX: 0D55 ; inline
-: GL_RED_BITS HEX: 0D52 ; inline
-: GL_GREEN_BITS HEX: 0D53 ; inline
-: GL_BLUE_BITS HEX: 0D54 ; inline
-: GL_INDEX_BITS HEX: 0D51 ; inline
-: GL_SUBPIXEL_BITS HEX: 0D50 ; inline
-: GL_AUX_BUFFERS HEX: 0C00 ; inline
-: GL_READ_BUFFER HEX: 0C02 ; inline
-: GL_DRAW_BUFFER HEX: 0C01 ; inline
-: GL_DOUBLEBUFFER HEX: 0C32 ; inline
-: GL_STEREO HEX: 0C33 ; inline
-: GL_BITMAP HEX: 1A00 ; inline
-: GL_COLOR HEX: 1800 ; inline
-: GL_DEPTH HEX: 1801 ; inline
-: GL_STENCIL HEX: 1802 ; inline
-: GL_DITHER HEX: 0BD0 ; inline
-: GL_RGB HEX: 1907 ; inline
-: GL_RGBA HEX: 1908 ; inline
+CONSTANT: GL_NONE HEX: 0
+CONSTANT: GL_LEFT HEX: 0406
+CONSTANT: GL_RIGHT HEX: 0407
+
+CONSTANT: GL_FRONT_RIGHT HEX: 0401
+CONSTANT: GL_BACK_LEFT HEX: 0402
+CONSTANT: GL_BACK_RIGHT HEX: 0403
+CONSTANT: GL_AUX0 HEX: 0409
+CONSTANT: GL_AUX1 HEX: 040A
+CONSTANT: GL_AUX2 HEX: 040B
+CONSTANT: GL_AUX3 HEX: 040C
+CONSTANT: GL_COLOR_INDEX HEX: 1900
+CONSTANT: GL_RED HEX: 1903
+CONSTANT: GL_GREEN HEX: 1904
+CONSTANT: GL_BLUE HEX: 1905
+CONSTANT: GL_ALPHA HEX: 1906
+CONSTANT: GL_LUMINANCE HEX: 1909
+CONSTANT: GL_LUMINANCE_ALPHA HEX: 190A
+CONSTANT: GL_ALPHA_BITS HEX: 0D55
+CONSTANT: GL_RED_BITS HEX: 0D52
+CONSTANT: GL_GREEN_BITS HEX: 0D53
+CONSTANT: GL_BLUE_BITS HEX: 0D54
+CONSTANT: GL_INDEX_BITS HEX: 0D51
+CONSTANT: GL_SUBPIXEL_BITS HEX: 0D50
+CONSTANT: GL_AUX_BUFFERS HEX: 0C00
+CONSTANT: GL_READ_BUFFER HEX: 0C02
+CONSTANT: GL_DRAW_BUFFER HEX: 0C01
+CONSTANT: GL_DOUBLEBUFFER HEX: 0C32
+CONSTANT: GL_STEREO HEX: 0C33
+CONSTANT: GL_BITMAP HEX: 1A00
+CONSTANT: GL_COLOR HEX: 1800
+CONSTANT: GL_DEPTH HEX: 1801
+CONSTANT: GL_STENCIL HEX: 1802
+CONSTANT: GL_DITHER HEX: 0BD0
+CONSTANT: GL_RGB HEX: 1907
+CONSTANT: GL_RGBA HEX: 1908
! Implementation limits
-: GL_MAX_LIST_NESTING HEX: 0B31 ; inline
-: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35 ; inline
-: GL_MAX_MODELVIEW_STACK_DEPTH HEX: 0D36 ; inline
-: GL_MAX_NAME_STACK_DEPTH HEX: 0D37 ; inline
-: GL_MAX_PROJECTION_STACK_DEPTH HEX: 0D38 ; inline
-: GL_MAX_TEXTURE_STACK_DEPTH HEX: 0D39 ; inline
-: GL_MAX_EVAL_ORDER HEX: 0D30 ; inline
-: GL_MAX_LIGHTS HEX: 0D31 ; inline
-: GL_MAX_CLIP_PLANES HEX: 0D32 ; inline
-: GL_MAX_TEXTURE_SIZE HEX: 0D33 ; inline
-: GL_MAX_PIXEL_MAP_TABLE HEX: 0D34 ; inline
-: GL_MAX_VIEWPORT_DIMS HEX: 0D3A ; inline
-: GL_MAX_CLIENT_ATTRIB_STACK_DEPTH HEX: 0D3B ; inline
+CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31
+CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35
+CONSTANT: GL_MAX_MODELVIEW_STACK_DEPTH HEX: 0D36
+CONSTANT: GL_MAX_NAME_STACK_DEPTH HEX: 0D37
+CONSTANT: GL_MAX_PROJECTION_STACK_DEPTH HEX: 0D38
+CONSTANT: GL_MAX_TEXTURE_STACK_DEPTH HEX: 0D39
+CONSTANT: GL_MAX_EVAL_ORDER HEX: 0D30
+CONSTANT: GL_MAX_LIGHTS HEX: 0D31
+CONSTANT: GL_MAX_CLIP_PLANES HEX: 0D32
+CONSTANT: GL_MAX_TEXTURE_SIZE HEX: 0D33
+CONSTANT: GL_MAX_PIXEL_MAP_TABLE HEX: 0D34
+CONSTANT: GL_MAX_VIEWPORT_DIMS HEX: 0D3A
+CONSTANT: GL_MAX_CLIENT_ATTRIB_STACK_DEPTH HEX: 0D3B
! Gets
-: GL_ATTRIB_STACK_DEPTH HEX: 0BB0 ; inline
-: GL_CLIENT_ATTRIB_STACK_DEPTH HEX: 0BB1 ; inline
-: GL_COLOR_CLEAR_VALUE HEX: 0C22 ; inline
-: GL_COLOR_WRITEMASK HEX: 0C23 ; inline
-: GL_CURRENT_INDEX HEX: 0B01 ; inline
-: GL_CURRENT_COLOR HEX: 0B00 ; inline
-: GL_CURRENT_NORMAL HEX: 0B02 ; inline
-: GL_CURRENT_RASTER_COLOR HEX: 0B04 ; inline
-: GL_CURRENT_RASTER_DISTANCE HEX: 0B09 ; inline
-: GL_CURRENT_RASTER_INDEX HEX: 0B05 ; inline
-: GL_CURRENT_RASTER_POSITION HEX: 0B07 ; inline
-: GL_CURRENT_RASTER_TEXTURE_COORDS HEX: 0B06 ; inline
-: GL_CURRENT_RASTER_POSITION_VALID HEX: 0B08 ; inline
-: GL_CURRENT_TEXTURE_COORDS HEX: 0B03 ; inline
-: GL_INDEX_CLEAR_VALUE HEX: 0C20 ; inline
-: GL_INDEX_MODE HEX: 0C30 ; inline
-: GL_INDEX_WRITEMASK HEX: 0C21 ; inline
-: GL_MODELVIEW_MATRIX HEX: 0BA6 ; inline
-: GL_MODELVIEW_STACK_DEPTH HEX: 0BA3 ; inline
-: GL_NAME_STACK_DEPTH HEX: 0D70 ; inline
-: GL_PROJECTION_MATRIX HEX: 0BA7 ; inline
-: GL_PROJECTION_STACK_DEPTH HEX: 0BA4 ; inline
-: GL_RENDER_MODE HEX: 0C40 ; inline
-: GL_RGBA_MODE HEX: 0C31 ; inline
-: GL_TEXTURE_MATRIX HEX: 0BA8 ; inline
-: GL_TEXTURE_STACK_DEPTH HEX: 0BA5 ; inline
-: GL_VIEWPORT HEX: 0BA2 ; inline
+CONSTANT: GL_ATTRIB_STACK_DEPTH HEX: 0BB0
+CONSTANT: GL_CLIENT_ATTRIB_STACK_DEPTH HEX: 0BB1
+CONSTANT: GL_COLOR_CLEAR_VALUE HEX: 0C22
+CONSTANT: GL_COLOR_WRITEMASK HEX: 0C23
+CONSTANT: GL_CURRENT_INDEX HEX: 0B01
+CONSTANT: GL_CURRENT_COLOR HEX: 0B00
+CONSTANT: GL_CURRENT_NORMAL HEX: 0B02
+CONSTANT: GL_CURRENT_RASTER_COLOR HEX: 0B04
+CONSTANT: GL_CURRENT_RASTER_DISTANCE HEX: 0B09
+CONSTANT: GL_CURRENT_RASTER_INDEX HEX: 0B05
+CONSTANT: GL_CURRENT_RASTER_POSITION HEX: 0B07
+CONSTANT: GL_CURRENT_RASTER_TEXTURE_COORDS HEX: 0B06
+CONSTANT: GL_CURRENT_RASTER_POSITION_VALID HEX: 0B08
+CONSTANT: GL_CURRENT_TEXTURE_COORDS HEX: 0B03
+CONSTANT: GL_INDEX_CLEAR_VALUE HEX: 0C20
+CONSTANT: GL_INDEX_MODE HEX: 0C30
+CONSTANT: GL_INDEX_WRITEMASK HEX: 0C21
+CONSTANT: GL_MODELVIEW_MATRIX HEX: 0BA6
+CONSTANT: GL_MODELVIEW_STACK_DEPTH HEX: 0BA3
+CONSTANT: GL_NAME_STACK_DEPTH HEX: 0D70
+CONSTANT: GL_PROJECTION_MATRIX HEX: 0BA7
+CONSTANT: GL_PROJECTION_STACK_DEPTH HEX: 0BA4
+CONSTANT: GL_RENDER_MODE HEX: 0C40
+CONSTANT: GL_RGBA_MODE HEX: 0C31
+CONSTANT: GL_TEXTURE_MATRIX HEX: 0BA8
+CONSTANT: GL_TEXTURE_STACK_DEPTH HEX: 0BA5
+CONSTANT: GL_VIEWPORT HEX: 0BA2
! Evaluators inline
-: GL_AUTO_NORMAL HEX: 0D80 ; inline
-: GL_MAP1_COLOR_4 HEX: 0D90 ; inline
-: GL_MAP1_INDEX HEX: 0D91 ; inline
-: GL_MAP1_NORMAL HEX: 0D92 ; inline
-: GL_MAP1_TEXTURE_COORD_1 HEX: 0D93 ; inline
-: GL_MAP1_TEXTURE_COORD_2 HEX: 0D94 ; inline
-: GL_MAP1_TEXTURE_COORD_3 HEX: 0D95 ; inline
-: GL_MAP1_TEXTURE_COORD_4 HEX: 0D96 ; inline
-: GL_MAP1_VERTEX_3 HEX: 0D97 ; inline
-: GL_MAP1_VERTEX_4 HEX: 0D98 ; inline
-: GL_MAP2_COLOR_4 HEX: 0DB0 ; inline
-: GL_MAP2_INDEX HEX: 0DB1 ; inline
-: GL_MAP2_NORMAL HEX: 0DB2 ; inline
-: GL_MAP2_TEXTURE_COORD_1 HEX: 0DB3 ; inline
-: GL_MAP2_TEXTURE_COORD_2 HEX: 0DB4 ; inline
-: GL_MAP2_TEXTURE_COORD_3 HEX: 0DB5 ; inline
-: GL_MAP2_TEXTURE_COORD_4 HEX: 0DB6 ; inline
-: GL_MAP2_VERTEX_3 HEX: 0DB7 ; inline
-: GL_MAP2_VERTEX_4 HEX: 0DB8 ; inline
-: GL_MAP1_GRID_DOMAIN HEX: 0DD0 ; inline
-: GL_MAP1_GRID_SEGMENTS HEX: 0DD1 ; inline
-: GL_MAP2_GRID_DOMAIN HEX: 0DD2 ; inline
-: GL_MAP2_GRID_SEGMENTS HEX: 0DD3 ; inline
-: GL_COEFF HEX: 0A00 ; inline
-: GL_DOMAIN HEX: 0A02 ; inline
-: GL_ORDER HEX: 0A01 ; inline
+CONSTANT: GL_AUTO_NORMAL HEX: 0D80
+CONSTANT: GL_MAP1_COLOR_4 HEX: 0D90
+CONSTANT: GL_MAP1_INDEX HEX: 0D91
+CONSTANT: GL_MAP1_NORMAL HEX: 0D92
+CONSTANT: GL_MAP1_TEXTURE_COORD_1 HEX: 0D93
+CONSTANT: GL_MAP1_TEXTURE_COORD_2 HEX: 0D94
+CONSTANT: GL_MAP1_TEXTURE_COORD_3 HEX: 0D95
+CONSTANT: GL_MAP1_TEXTURE_COORD_4 HEX: 0D96
+CONSTANT: GL_MAP1_VERTEX_3 HEX: 0D97
+CONSTANT: GL_MAP1_VERTEX_4 HEX: 0D98
+CONSTANT: GL_MAP2_COLOR_4 HEX: 0DB0
+CONSTANT: GL_MAP2_INDEX HEX: 0DB1
+CONSTANT: GL_MAP2_NORMAL HEX: 0DB2
+CONSTANT: GL_MAP2_TEXTURE_COORD_1 HEX: 0DB3
+CONSTANT: GL_MAP2_TEXTURE_COORD_2 HEX: 0DB4
+CONSTANT: GL_MAP2_TEXTURE_COORD_3 HEX: 0DB5
+CONSTANT: GL_MAP2_TEXTURE_COORD_4 HEX: 0DB6
+CONSTANT: GL_MAP2_VERTEX_3 HEX: 0DB7
+CONSTANT: GL_MAP2_VERTEX_4 HEX: 0DB8
+CONSTANT: GL_MAP1_GRID_DOMAIN HEX: 0DD0
+CONSTANT: GL_MAP1_GRID_SEGMENTS HEX: 0DD1
+CONSTANT: GL_MAP2_GRID_DOMAIN HEX: 0DD2
+CONSTANT: GL_MAP2_GRID_SEGMENTS HEX: 0DD3
+CONSTANT: GL_COEFF HEX: 0A00
+CONSTANT: GL_DOMAIN HEX: 0A02
+CONSTANT: GL_ORDER HEX: 0A01
! Hints inline
-: GL_FOG_HINT HEX: 0C54 ; inline
-: GL_LINE_SMOOTH_HINT HEX: 0C52 ; inline
-: GL_PERSPECTIVE_CORRECTION_HINT HEX: 0C50 ; inline
-: GL_POINT_SMOOTH_HINT HEX: 0C51 ; inline
-: GL_POLYGON_SMOOTH_HINT HEX: 0C53 ; inline
-: GL_DONT_CARE HEX: 1100 ; inline
-: GL_FASTEST HEX: 1101 ; inline
-: GL_NICEST HEX: 1102 ; inline
+CONSTANT: GL_FOG_HINT HEX: 0C54
+CONSTANT: GL_LINE_SMOOTH_HINT HEX: 0C52
+CONSTANT: GL_PERSPECTIVE_CORRECTION_HINT HEX: 0C50
+CONSTANT: GL_POINT_SMOOTH_HINT HEX: 0C51
+CONSTANT: GL_POLYGON_SMOOTH_HINT HEX: 0C53
+CONSTANT: GL_DONT_CARE HEX: 1100
+CONSTANT: GL_FASTEST HEX: 1101
+CONSTANT: GL_NICEST HEX: 1102
! Scissor box inline
-: GL_SCISSOR_TEST HEX: 0C11 ; inline
-: GL_SCISSOR_BOX HEX: 0C10 ; inline
+CONSTANT: GL_SCISSOR_TEST HEX: 0C11
+CONSTANT: GL_SCISSOR_BOX HEX: 0C10
! Pixel Mode / Transfer inline
-: GL_MAP_COLOR HEX: 0D10 ; inline
-: GL_MAP_STENCIL HEX: 0D11 ; inline
-: GL_INDEX_SHIFT HEX: 0D12 ; inline
-: GL_INDEX_OFFSET HEX: 0D13 ; inline
-: GL_RED_SCALE HEX: 0D14 ; inline
-: GL_RED_BIAS HEX: 0D15 ; inline
-: GL_GREEN_SCALE HEX: 0D18 ; inline
-: GL_GREEN_BIAS HEX: 0D19 ; inline
-: GL_BLUE_SCALE HEX: 0D1A ; inline
-: GL_BLUE_BIAS HEX: 0D1B ; inline
-: GL_ALPHA_SCALE HEX: 0D1C ; inline
-: GL_ALPHA_BIAS HEX: 0D1D ; inline
-: GL_DEPTH_SCALE HEX: 0D1E ; inline
-: GL_DEPTH_BIAS HEX: 0D1F ; inline
-: GL_PIXEL_MAP_S_TO_S_SIZE HEX: 0CB1 ; inline
-: GL_PIXEL_MAP_I_TO_I_SIZE HEX: 0CB0 ; inline
-: GL_PIXEL_MAP_I_TO_R_SIZE HEX: 0CB2 ; inline
-: GL_PIXEL_MAP_I_TO_G_SIZE HEX: 0CB3 ; inline
-: GL_PIXEL_MAP_I_TO_B_SIZE HEX: 0CB4 ; inline
-: GL_PIXEL_MAP_I_TO_A_SIZE HEX: 0CB5 ; inline
-: GL_PIXEL_MAP_R_TO_R_SIZE HEX: 0CB6 ; inline
-: GL_PIXEL_MAP_G_TO_G_SIZE HEX: 0CB7 ; inline
-: GL_PIXEL_MAP_B_TO_B_SIZE HEX: 0CB8 ; inline
-: GL_PIXEL_MAP_A_TO_A_SIZE HEX: 0CB9 ; inline
-: GL_PIXEL_MAP_S_TO_S HEX: 0C71 ; inline
-: GL_PIXEL_MAP_I_TO_I HEX: 0C70 ; inline
-: GL_PIXEL_MAP_I_TO_R HEX: 0C72 ; inline
-: GL_PIXEL_MAP_I_TO_G HEX: 0C73 ; inline
-: GL_PIXEL_MAP_I_TO_B HEX: 0C74 ; inline
-: GL_PIXEL_MAP_I_TO_A HEX: 0C75 ; inline
-: GL_PIXEL_MAP_R_TO_R HEX: 0C76 ; inline
-: GL_PIXEL_MAP_G_TO_G HEX: 0C77 ; inline
-: GL_PIXEL_MAP_B_TO_B HEX: 0C78 ; inline
-: GL_PIXEL_MAP_A_TO_A HEX: 0C79 ; inline
-: GL_PACK_ALIGNMENT HEX: 0D05 ; inline
-: GL_PACK_LSB_FIRST HEX: 0D01 ; inline
-: GL_PACK_ROW_LENGTH HEX: 0D02 ; inline
-: GL_PACK_SKIP_PIXELS HEX: 0D04 ; inline
-: GL_PACK_SKIP_ROWS HEX: 0D03 ; inline
-: GL_PACK_SWAP_BYTES HEX: 0D00 ; inline
-: GL_UNPACK_ALIGNMENT HEX: 0CF5 ; inline
-: GL_UNPACK_LSB_FIRST HEX: 0CF1 ; inline
-: GL_UNPACK_ROW_LENGTH HEX: 0CF2 ; inline
-: GL_UNPACK_SKIP_PIXELS HEX: 0CF4 ; inline
-: GL_UNPACK_SKIP_ROWS HEX: 0CF3 ; inline
-: GL_UNPACK_SWAP_BYTES HEX: 0CF0 ; inline
-: GL_ZOOM_X HEX: 0D16 ; inline
-: GL_ZOOM_Y HEX: 0D17 ; inline
+CONSTANT: GL_MAP_COLOR HEX: 0D10
+CONSTANT: GL_MAP_STENCIL HEX: 0D11
+CONSTANT: GL_INDEX_SHIFT HEX: 0D12
+CONSTANT: GL_INDEX_OFFSET HEX: 0D13
+CONSTANT: GL_RED_SCALE HEX: 0D14
+CONSTANT: GL_RED_BIAS HEX: 0D15
+CONSTANT: GL_GREEN_SCALE HEX: 0D18
+CONSTANT: GL_GREEN_BIAS HEX: 0D19
+CONSTANT: GL_BLUE_SCALE HEX: 0D1A
+CONSTANT: GL_BLUE_BIAS HEX: 0D1B
+CONSTANT: GL_ALPHA_SCALE HEX: 0D1C
+CONSTANT: GL_ALPHA_BIAS HEX: 0D1D
+CONSTANT: GL_DEPTH_SCALE HEX: 0D1E
+CONSTANT: GL_DEPTH_BIAS HEX: 0D1F
+CONSTANT: GL_PIXEL_MAP_S_TO_S_SIZE HEX: 0CB1
+CONSTANT: GL_PIXEL_MAP_I_TO_I_SIZE HEX: 0CB0
+CONSTANT: GL_PIXEL_MAP_I_TO_R_SIZE HEX: 0CB2
+CONSTANT: GL_PIXEL_MAP_I_TO_G_SIZE HEX: 0CB3
+CONSTANT: GL_PIXEL_MAP_I_TO_B_SIZE HEX: 0CB4
+CONSTANT: GL_PIXEL_MAP_I_TO_A_SIZE HEX: 0CB5
+CONSTANT: GL_PIXEL_MAP_R_TO_R_SIZE HEX: 0CB6
+CONSTANT: GL_PIXEL_MAP_G_TO_G_SIZE HEX: 0CB7
+CONSTANT: GL_PIXEL_MAP_B_TO_B_SIZE HEX: 0CB8
+CONSTANT: GL_PIXEL_MAP_A_TO_A_SIZE HEX: 0CB9
+CONSTANT: GL_PIXEL_MAP_S_TO_S HEX: 0C71
+CONSTANT: GL_PIXEL_MAP_I_TO_I HEX: 0C70
+CONSTANT: GL_PIXEL_MAP_I_TO_R HEX: 0C72
+CONSTANT: GL_PIXEL_MAP_I_TO_G HEX: 0C73
+CONSTANT: GL_PIXEL_MAP_I_TO_B HEX: 0C74
+CONSTANT: GL_PIXEL_MAP_I_TO_A HEX: 0C75
+CONSTANT: GL_PIXEL_MAP_R_TO_R HEX: 0C76
+CONSTANT: GL_PIXEL_MAP_G_TO_G HEX: 0C77
+CONSTANT: GL_PIXEL_MAP_B_TO_B HEX: 0C78
+CONSTANT: GL_PIXEL_MAP_A_TO_A HEX: 0C79
+CONSTANT: GL_PACK_ALIGNMENT HEX: 0D05
+CONSTANT: GL_PACK_LSB_FIRST HEX: 0D01
+CONSTANT: GL_PACK_ROW_LENGTH HEX: 0D02
+CONSTANT: GL_PACK_SKIP_PIXELS HEX: 0D04
+CONSTANT: GL_PACK_SKIP_ROWS HEX: 0D03
+CONSTANT: GL_PACK_SWAP_BYTES HEX: 0D00
+CONSTANT: GL_UNPACK_ALIGNMENT HEX: 0CF5
+CONSTANT: GL_UNPACK_LSB_FIRST HEX: 0CF1
+CONSTANT: GL_UNPACK_ROW_LENGTH HEX: 0CF2
+CONSTANT: GL_UNPACK_SKIP_PIXELS HEX: 0CF4
+CONSTANT: GL_UNPACK_SKIP_ROWS HEX: 0CF3
+CONSTANT: GL_UNPACK_SWAP_BYTES HEX: 0CF0
+CONSTANT: GL_ZOOM_X HEX: 0D16
+CONSTANT: GL_ZOOM_Y HEX: 0D17
! Texture mapping inline
-: GL_TEXTURE_ENV HEX: 2300 ; inline
-: GL_TEXTURE_ENV_MODE HEX: 2200 ; inline
-: GL_TEXTURE_1D HEX: 0DE0 ; inline
-: GL_TEXTURE_2D HEX: 0DE1 ; inline
-: GL_TEXTURE_WRAP_S HEX: 2802 ; inline
-: GL_TEXTURE_WRAP_T HEX: 2803 ; inline
-: GL_TEXTURE_MAG_FILTER HEX: 2800 ; inline
-: GL_TEXTURE_MIN_FILTER HEX: 2801 ; inline
-: GL_TEXTURE_ENV_COLOR HEX: 2201 ; inline
-: GL_TEXTURE_GEN_S HEX: 0C60 ; inline
-: GL_TEXTURE_GEN_T HEX: 0C61 ; inline
-: GL_TEXTURE_GEN_MODE HEX: 2500 ; inline
-: GL_TEXTURE_BORDER_COLOR HEX: 1004 ; inline
-: GL_TEXTURE_WIDTH HEX: 1000 ; inline
-: GL_TEXTURE_HEIGHT HEX: 1001 ; inline
-: GL_TEXTURE_BORDER HEX: 1005 ; inline
-: GL_TEXTURE_COMPONENTS HEX: 1003 ; inline
-: GL_TEXTURE_RED_SIZE HEX: 805C ; inline
-: GL_TEXTURE_GREEN_SIZE HEX: 805D ; inline
-: GL_TEXTURE_BLUE_SIZE HEX: 805E ; inline
-: GL_TEXTURE_ALPHA_SIZE HEX: 805F ; inline
-: GL_TEXTURE_LUMINANCE_SIZE HEX: 8060 ; inline
-: GL_TEXTURE_INTENSITY_SIZE HEX: 8061 ; inline
-: GL_NEAREST_MIPMAP_NEAREST HEX: 2700 ; inline
-: GL_NEAREST_MIPMAP_LINEAR HEX: 2702 ; inline
-: GL_LINEAR_MIPMAP_NEAREST HEX: 2701 ; inline
-: GL_LINEAR_MIPMAP_LINEAR HEX: 2703 ; inline
-: GL_OBJECT_LINEAR HEX: 2401 ; inline
-: GL_OBJECT_PLANE HEX: 2501 ; inline
-: GL_EYE_LINEAR HEX: 2400 ; inline
-: GL_EYE_PLANE HEX: 2502 ; inline
-: GL_SPHERE_MAP HEX: 2402 ; inline
-: GL_DECAL HEX: 2101 ; inline
-: GL_MODULATE HEX: 2100 ; inline
-: GL_NEAREST HEX: 2600 ; inline
-: GL_REPEAT HEX: 2901 ; inline
-: GL_CLAMP HEX: 2900 ; inline
-: GL_S HEX: 2000 ; inline
-: GL_T HEX: 2001 ; inline
-: GL_R HEX: 2002 ; inline
-: GL_Q HEX: 2003 ; inline
-: GL_TEXTURE_GEN_R HEX: 0C62 ; inline
-: GL_TEXTURE_GEN_Q HEX: 0C63 ; inline
+CONSTANT: GL_TEXTURE_ENV HEX: 2300
+CONSTANT: GL_TEXTURE_ENV_MODE HEX: 2200
+CONSTANT: GL_TEXTURE_1D HEX: 0DE0
+CONSTANT: GL_TEXTURE_2D HEX: 0DE1
+CONSTANT: GL_TEXTURE_WRAP_S HEX: 2802
+CONSTANT: GL_TEXTURE_WRAP_T HEX: 2803
+CONSTANT: GL_TEXTURE_MAG_FILTER HEX: 2800
+CONSTANT: GL_TEXTURE_MIN_FILTER HEX: 2801
+CONSTANT: GL_TEXTURE_ENV_COLOR HEX: 2201
+CONSTANT: GL_TEXTURE_GEN_S HEX: 0C60
+CONSTANT: GL_TEXTURE_GEN_T HEX: 0C61
+CONSTANT: GL_TEXTURE_GEN_MODE HEX: 2500
+CONSTANT: GL_TEXTURE_BORDER_COLOR HEX: 1004
+CONSTANT: GL_TEXTURE_WIDTH HEX: 1000
+CONSTANT: GL_TEXTURE_HEIGHT HEX: 1001
+CONSTANT: GL_TEXTURE_BORDER HEX: 1005
+CONSTANT: GL_TEXTURE_COMPONENTS HEX: 1003
+CONSTANT: GL_TEXTURE_RED_SIZE HEX: 805C
+CONSTANT: GL_TEXTURE_GREEN_SIZE HEX: 805D
+CONSTANT: GL_TEXTURE_BLUE_SIZE HEX: 805E
+CONSTANT: GL_TEXTURE_ALPHA_SIZE HEX: 805F
+CONSTANT: GL_TEXTURE_LUMINANCE_SIZE HEX: 8060
+CONSTANT: GL_TEXTURE_INTENSITY_SIZE HEX: 8061
+CONSTANT: GL_NEAREST_MIPMAP_NEAREST HEX: 2700
+CONSTANT: GL_NEAREST_MIPMAP_LINEAR HEX: 2702
+CONSTANT: GL_LINEAR_MIPMAP_NEAREST HEX: 2701
+CONSTANT: GL_LINEAR_MIPMAP_LINEAR HEX: 2703
+CONSTANT: GL_OBJECT_LINEAR HEX: 2401
+CONSTANT: GL_OBJECT_PLANE HEX: 2501
+CONSTANT: GL_EYE_LINEAR HEX: 2400
+CONSTANT: GL_EYE_PLANE HEX: 2502
+CONSTANT: GL_SPHERE_MAP HEX: 2402
+CONSTANT: GL_DECAL HEX: 2101
+CONSTANT: GL_MODULATE HEX: 2100
+CONSTANT: GL_NEAREST HEX: 2600
+CONSTANT: GL_REPEAT HEX: 2901
+CONSTANT: GL_CLAMP HEX: 2900
+CONSTANT: GL_S HEX: 2000
+CONSTANT: GL_T HEX: 2001
+CONSTANT: GL_R HEX: 2002
+CONSTANT: GL_Q HEX: 2003
+CONSTANT: GL_TEXTURE_GEN_R HEX: 0C62
+CONSTANT: GL_TEXTURE_GEN_Q HEX: 0C63
! Utility inline
-: GL_VENDOR HEX: 1F00 ; inline
-: GL_RENDERER HEX: 1F01 ; inline
-: GL_VERSION HEX: 1F02 ; inline
-: GL_EXTENSIONS HEX: 1F03 ; inline
+CONSTANT: GL_VENDOR HEX: 1F00
+CONSTANT: GL_RENDERER HEX: 1F01
+CONSTANT: GL_VERSION HEX: 1F02
+CONSTANT: GL_EXTENSIONS HEX: 1F03
! Errors inline
-: GL_NO_ERROR HEX: 0 ; inline
-: GL_INVALID_VALUE HEX: 0501 ; inline
-: GL_INVALID_ENUM HEX: 0500 ; inline
-: GL_INVALID_OPERATION HEX: 0502 ; inline
-: GL_STACK_OVERFLOW HEX: 0503 ; inline
-: GL_STACK_UNDERFLOW HEX: 0504 ; inline
-: GL_OUT_OF_MEMORY HEX: 0505 ; inline
+CONSTANT: GL_NO_ERROR HEX: 0
+CONSTANT: GL_INVALID_VALUE HEX: 0501
+CONSTANT: GL_INVALID_ENUM HEX: 0500
+CONSTANT: GL_INVALID_OPERATION HEX: 0502
+CONSTANT: GL_STACK_OVERFLOW HEX: 0503
+CONSTANT: GL_STACK_UNDERFLOW HEX: 0504
+CONSTANT: GL_OUT_OF_MEMORY HEX: 0505
! glPush/PopAttrib bits
-: GL_CURRENT_BIT HEX: 00000001 ; inline
-: GL_POINT_BIT HEX: 00000002 ; inline
-: GL_LINE_BIT HEX: 00000004 ; inline
-: GL_POLYGON_BIT HEX: 00000008 ; inline
-: GL_POLYGON_STIPPLE_BIT HEX: 00000010 ; inline
-: GL_PIXEL_MODE_BIT HEX: 00000020 ; inline
-: GL_LIGHTING_BIT HEX: 00000040 ; inline
-: GL_FOG_BIT HEX: 00000080 ; inline
-: GL_DEPTH_BUFFER_BIT HEX: 00000100 ; inline
-: GL_ACCUM_BUFFER_BIT HEX: 00000200 ; inline
-: GL_STENCIL_BUFFER_BIT HEX: 00000400 ; inline
-: GL_VIEWPORT_BIT HEX: 00000800 ; inline
-: GL_TRANSFORM_BIT HEX: 00001000 ; inline
-: GL_ENABLE_BIT HEX: 00002000 ; inline
-: GL_COLOR_BUFFER_BIT HEX: 00004000 ; inline
-: GL_HINT_BIT HEX: 00008000 ; inline
-: GL_EVAL_BIT HEX: 00010000 ; inline
-: GL_LIST_BIT HEX: 00020000 ; inline
-: GL_TEXTURE_BIT HEX: 00040000 ; inline
-: GL_SCISSOR_BIT HEX: 00080000 ; inline
-: GL_ALL_ATTRIB_BITS HEX: 000FFFFF ; inline
+CONSTANT: GL_CURRENT_BIT HEX: 00000001
+CONSTANT: GL_POINT_BIT HEX: 00000002
+CONSTANT: GL_LINE_BIT HEX: 00000004
+CONSTANT: GL_POLYGON_BIT HEX: 00000008
+CONSTANT: GL_POLYGON_STIPPLE_BIT HEX: 00000010
+CONSTANT: GL_PIXEL_MODE_BIT HEX: 00000020
+CONSTANT: GL_LIGHTING_BIT HEX: 00000040
+CONSTANT: GL_FOG_BIT HEX: 00000080
+CONSTANT: GL_DEPTH_BUFFER_BIT HEX: 00000100
+CONSTANT: GL_ACCUM_BUFFER_BIT HEX: 00000200
+CONSTANT: GL_STENCIL_BUFFER_BIT HEX: 00000400
+CONSTANT: GL_VIEWPORT_BIT HEX: 00000800
+CONSTANT: GL_TRANSFORM_BIT HEX: 00001000
+CONSTANT: GL_ENABLE_BIT HEX: 00002000
+CONSTANT: GL_COLOR_BUFFER_BIT HEX: 00004000
+CONSTANT: GL_HINT_BIT HEX: 00008000
+CONSTANT: GL_EVAL_BIT HEX: 00010000
+CONSTANT: GL_LIST_BIT HEX: 00020000
+CONSTANT: GL_TEXTURE_BIT HEX: 00040000
+CONSTANT: GL_SCISSOR_BIT HEX: 00080000
+CONSTANT: GL_ALL_ATTRIB_BITS HEX: 000FFFFF
! OpenGL 1.1
-: GL_PROXY_TEXTURE_1D HEX: 8063 ; inline
-: GL_PROXY_TEXTURE_2D HEX: 8064 ; inline
-: GL_TEXTURE_PRIORITY HEX: 8066 ; inline
-: GL_TEXTURE_RESIDENT HEX: 8067 ; inline
-: GL_TEXTURE_BINDING_1D HEX: 8068 ; inline
-: GL_TEXTURE_BINDING_2D HEX: 8069 ; inline
-: GL_TEXTURE_INTERNAL_FORMAT HEX: 1003 ; inline
-: GL_ALPHA4 HEX: 803B ; inline
-: GL_ALPHA8 HEX: 803C ; inline
-: GL_ALPHA12 HEX: 803D ; inline
-: GL_ALPHA16 HEX: 803E ; inline
-: GL_LUMINANCE4 HEX: 803F ; inline
-: GL_LUMINANCE8 HEX: 8040 ; inline
-: GL_LUMINANCE12 HEX: 8041 ; inline
-: GL_LUMINANCE16 HEX: 8042 ; inline
-: GL_LUMINANCE4_ALPHA4 HEX: 8043 ; inline
-: GL_LUMINANCE6_ALPHA2 HEX: 8044 ; inline
-: GL_LUMINANCE8_ALPHA8 HEX: 8045 ; inline
-: GL_LUMINANCE12_ALPHA4 HEX: 8046 ; inline
-: GL_LUMINANCE12_ALPHA12 HEX: 8047 ; inline
-: GL_LUMINANCE16_ALPHA16 HEX: 8048 ; inline
-: GL_INTENSITY HEX: 8049 ; inline
-: GL_INTENSITY4 HEX: 804A ; inline
-: GL_INTENSITY8 HEX: 804B ; inline
-: GL_INTENSITY12 HEX: 804C ; inline
-: GL_INTENSITY16 HEX: 804D ; inline
-: GL_R3_G3_B2 HEX: 2A10 ; inline
-: GL_RGB4 HEX: 804F ; inline
-: GL_RGB5 HEX: 8050 ; inline
-: GL_RGB8 HEX: 8051 ; inline
-: GL_RGB10 HEX: 8052 ; inline
-: GL_RGB12 HEX: 8053 ; inline
-: GL_RGB16 HEX: 8054 ; inline
-: GL_RGBA2 HEX: 8055 ; inline
-: GL_RGBA4 HEX: 8056 ; inline
-: GL_RGB5_A1 HEX: 8057 ; inline
-: GL_RGBA8 HEX: 8058 ; inline
-: GL_RGB10_A2 HEX: 8059 ; inline
-: GL_RGBA12 HEX: 805A ; inline
-: GL_RGBA16 HEX: 805B ; inline
-: GL_CLIENT_PIXEL_STORE_BIT HEX: 00000001 ; inline
-: GL_CLIENT_VERTEX_ARRAY_BIT HEX: 00000002 ; inline
-: GL_ALL_CLIENT_ATTRIB_BITS HEX: FFFFFFFF ; inline
-: GL_CLIENT_ALL_ATTRIB_BITS HEX: FFFFFFFF ; inline
+CONSTANT: GL_PROXY_TEXTURE_1D HEX: 8063
+CONSTANT: GL_PROXY_TEXTURE_2D HEX: 8064
+CONSTANT: GL_TEXTURE_PRIORITY HEX: 8066
+CONSTANT: GL_TEXTURE_RESIDENT HEX: 8067
+CONSTANT: GL_TEXTURE_BINDING_1D HEX: 8068
+CONSTANT: GL_TEXTURE_BINDING_2D HEX: 8069
+CONSTANT: GL_TEXTURE_INTERNAL_FORMAT HEX: 1003
+CONSTANT: GL_ALPHA4 HEX: 803B
+CONSTANT: GL_ALPHA8 HEX: 803C
+CONSTANT: GL_ALPHA12 HEX: 803D
+CONSTANT: GL_ALPHA16 HEX: 803E
+CONSTANT: GL_LUMINANCE4 HEX: 803F
+CONSTANT: GL_LUMINANCE8 HEX: 8040
+CONSTANT: GL_LUMINANCE12 HEX: 8041
+CONSTANT: GL_LUMINANCE16 HEX: 8042
+CONSTANT: GL_LUMINANCE4_ALPHA4 HEX: 8043
+CONSTANT: GL_LUMINANCE6_ALPHA2 HEX: 8044
+CONSTANT: GL_LUMINANCE8_ALPHA8 HEX: 8045
+CONSTANT: GL_LUMINANCE12_ALPHA4 HEX: 8046
+CONSTANT: GL_LUMINANCE12_ALPHA12 HEX: 8047
+CONSTANT: GL_LUMINANCE16_ALPHA16 HEX: 8048
+CONSTANT: GL_INTENSITY HEX: 8049
+CONSTANT: GL_INTENSITY4 HEX: 804A
+CONSTANT: GL_INTENSITY8 HEX: 804B
+CONSTANT: GL_INTENSITY12 HEX: 804C
+CONSTANT: GL_INTENSITY16 HEX: 804D
+CONSTANT: GL_R3_G3_B2 HEX: 2A10
+CONSTANT: GL_RGB4 HEX: 804F
+CONSTANT: GL_RGB5 HEX: 8050
+CONSTANT: GL_RGB8 HEX: 8051
+CONSTANT: GL_RGB10 HEX: 8052
+CONSTANT: GL_RGB12 HEX: 8053
+CONSTANT: GL_RGB16 HEX: 8054
+CONSTANT: GL_RGBA2 HEX: 8055
+CONSTANT: GL_RGBA4 HEX: 8056
+CONSTANT: GL_RGB5_A1 HEX: 8057
+CONSTANT: GL_RGBA8 HEX: 8058
+CONSTANT: GL_RGB10_A2 HEX: 8059
+CONSTANT: GL_RGBA12 HEX: 805A
+CONSTANT: GL_RGBA16 HEX: 805B
+CONSTANT: GL_CLIENT_PIXEL_STORE_BIT HEX: 00000001
+CONSTANT: GL_CLIENT_VERTEX_ARRAY_BIT HEX: 00000002
+CONSTANT: GL_ALL_CLIENT_ATTRIB_BITS HEX: FFFFFFFF
+CONSTANT: GL_CLIENT_ALL_ATTRIB_BITS HEX: FFFFFFFF
LIBRARY: gl
! OpenGL 1.2
-: GL_SMOOTH_POINT_SIZE_RANGE HEX: 0B12 ; inline
-: GL_SMOOTH_POINT_SIZE_GRANULARITY HEX: 0B13 ; inline
-: GL_SMOOTH_LINE_WIDTH_RANGE HEX: 0B22 ; inline
-: GL_SMOOTH_LINE_WIDTH_GRANULARITY HEX: 0B23 ; inline
-: GL_UNSIGNED_BYTE_3_3_2 HEX: 8032 ; inline
-: GL_UNSIGNED_SHORT_4_4_4_4 HEX: 8033 ; inline
-: GL_UNSIGNED_SHORT_5_5_5_1 HEX: 8034 ; inline
-: GL_UNSIGNED_INT_8_8_8_8 HEX: 8035 ; inline
-: GL_UNSIGNED_INT_10_10_10_2 HEX: 8036 ; inline
-: GL_RESCALE_NORMAL HEX: 803A ; inline
-: GL_TEXTURE_BINDING_3D HEX: 806A ; inline
-: GL_PACK_SKIP_IMAGES HEX: 806B ; inline
-: GL_PACK_IMAGE_HEIGHT HEX: 806C ; inline
-: GL_UNPACK_SKIP_IMAGES HEX: 806D ; inline
-: GL_UNPACK_IMAGE_HEIGHT HEX: 806E ; inline
-: GL_TEXTURE_3D HEX: 806F ; inline
-: GL_PROXY_TEXTURE_3D HEX: 8070 ; inline
-: GL_TEXTURE_DEPTH HEX: 8071 ; inline
-: GL_TEXTURE_WRAP_R HEX: 8072 ; inline
-: GL_MAX_3D_TEXTURE_SIZE HEX: 8073 ; inline
-: GL_BGR HEX: 80E0 ; inline
-: GL_BGRA HEX: 80E1 ; inline
-: GL_MAX_ELEMENTS_VERTICES HEX: 80E8 ; inline
-: GL_MAX_ELEMENTS_INDICES HEX: 80E9 ; inline
-: GL_CLAMP_TO_EDGE HEX: 812F ; inline
-: GL_TEXTURE_MIN_LOD HEX: 813A ; inline
-: GL_TEXTURE_MAX_LOD HEX: 813B ; inline
-: GL_TEXTURE_BASE_LEVEL HEX: 813C ; inline
-: GL_TEXTURE_MAX_LEVEL HEX: 813D ; inline
-: GL_LIGHT_MODEL_COLOR_CONTROL HEX: 81F8 ; inline
-: GL_SINGLE_COLOR HEX: 81F9 ; inline
-: GL_SEPARATE_SPECULAR_COLOR HEX: 81FA ; inline
-: GL_UNSIGNED_BYTE_2_3_3_REV HEX: 8362 ; inline
-: GL_UNSIGNED_SHORT_5_6_5 HEX: 8363 ; inline
-: GL_UNSIGNED_SHORT_5_6_5_REV HEX: 8364 ; inline
-: GL_UNSIGNED_SHORT_4_4_4_4_REV HEX: 8365 ; inline
-: GL_UNSIGNED_SHORT_1_5_5_5_REV HEX: 8366 ; inline
-: GL_UNSIGNED_INT_8_8_8_8_REV HEX: 8367 ; inline
-: GL_UNSIGNED_INT_2_10_10_10_REV HEX: 8368 ; inline
-: GL_ALIASED_POINT_SIZE_RANGE HEX: 846D ; inline
-: GL_ALIASED_LINE_WIDTH_RANGE HEX: 846E ; inline
+CONSTANT: GL_SMOOTH_POINT_SIZE_RANGE HEX: 0B12
+CONSTANT: GL_SMOOTH_POINT_SIZE_GRANULARITY HEX: 0B13
+CONSTANT: GL_SMOOTH_LINE_WIDTH_RANGE HEX: 0B22
+CONSTANT: GL_SMOOTH_LINE_WIDTH_GRANULARITY HEX: 0B23
+CONSTANT: GL_UNSIGNED_BYTE_3_3_2 HEX: 8032
+CONSTANT: GL_UNSIGNED_SHORT_4_4_4_4 HEX: 8033
+CONSTANT: GL_UNSIGNED_SHORT_5_5_5_1 HEX: 8034
+CONSTANT: GL_UNSIGNED_INT_8_8_8_8 HEX: 8035
+CONSTANT: GL_UNSIGNED_INT_10_10_10_2 HEX: 8036
+CONSTANT: GL_RESCALE_NORMAL HEX: 803A
+CONSTANT: GL_TEXTURE_BINDING_3D HEX: 806A
+CONSTANT: GL_PACK_SKIP_IMAGES HEX: 806B
+CONSTANT: GL_PACK_IMAGE_HEIGHT HEX: 806C
+CONSTANT: GL_UNPACK_SKIP_IMAGES HEX: 806D
+CONSTANT: GL_UNPACK_IMAGE_HEIGHT HEX: 806E
+CONSTANT: GL_TEXTURE_3D HEX: 806F
+CONSTANT: GL_PROXY_TEXTURE_3D HEX: 8070
+CONSTANT: GL_TEXTURE_DEPTH HEX: 8071
+CONSTANT: GL_TEXTURE_WRAP_R HEX: 8072
+CONSTANT: GL_MAX_3D_TEXTURE_SIZE HEX: 8073
+CONSTANT: GL_BGR HEX: 80E0
+CONSTANT: GL_BGRA HEX: 80E1
+CONSTANT: GL_MAX_ELEMENTS_VERTICES HEX: 80E8
+CONSTANT: GL_MAX_ELEMENTS_INDICES HEX: 80E9
+CONSTANT: GL_CLAMP_TO_EDGE HEX: 812F
+CONSTANT: GL_TEXTURE_MIN_LOD HEX: 813A
+CONSTANT: GL_TEXTURE_MAX_LOD HEX: 813B
+CONSTANT: GL_TEXTURE_BASE_LEVEL HEX: 813C
+CONSTANT: GL_TEXTURE_MAX_LEVEL HEX: 813D
+CONSTANT: GL_LIGHT_MODEL_COLOR_CONTROL HEX: 81F8
+CONSTANT: GL_SINGLE_COLOR HEX: 81F9
+CONSTANT: GL_SEPARATE_SPECULAR_COLOR HEX: 81FA
+CONSTANT: GL_UNSIGNED_BYTE_2_3_3_REV HEX: 8362
+CONSTANT: GL_UNSIGNED_SHORT_5_6_5 HEX: 8363
+CONSTANT: GL_UNSIGNED_SHORT_5_6_5_REV HEX: 8364
+CONSTANT: GL_UNSIGNED_SHORT_4_4_4_4_REV HEX: 8365
+CONSTANT: GL_UNSIGNED_SHORT_1_5_5_5_REV HEX: 8366
+CONSTANT: GL_UNSIGNED_INT_8_8_8_8_REV HEX: 8367
+CONSTANT: GL_UNSIGNED_INT_2_10_10_10_REV HEX: 8368
+CONSTANT: GL_ALIASED_POINT_SIZE_RANGE HEX: 846D
+CONSTANT: GL_ALIASED_LINE_WIDTH_RANGE HEX: 846E
GL-FUNCTION: void glCopyTexSubImage3D { glCopyTexSubImage3DEXT } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLint x, GLint y, GLsizei width, GLsizei height ) ;
GL-FUNCTION: void glDrawRangeElements { glDrawRangeElementsEXT } ( GLenum mode, GLuint start, GLuint end, GLsizei count, GLenum type, GLvoid* indices ) ;
! OpenGL 1.3
-: GL_MULTISAMPLE HEX: 809D ; inline
-: GL_SAMPLE_ALPHA_TO_COVERAGE HEX: 809E ; inline
-: GL_SAMPLE_ALPHA_TO_ONE HEX: 809F ; inline
-: GL_SAMPLE_COVERAGE HEX: 80A0 ; inline
-: GL_SAMPLE_BUFFERS HEX: 80A8 ; inline
-: GL_SAMPLES HEX: 80A9 ; inline
-: GL_SAMPLE_COVERAGE_VALUE HEX: 80AA ; inline
-: GL_SAMPLE_COVERAGE_INVERT HEX: 80AB ; inline
-: GL_CLAMP_TO_BORDER HEX: 812D ; inline
-: GL_TEXTURE0 HEX: 84C0 ; inline
-: GL_TEXTURE1 HEX: 84C1 ; inline
-: GL_TEXTURE2 HEX: 84C2 ; inline
-: GL_TEXTURE3 HEX: 84C3 ; inline
-: GL_TEXTURE4 HEX: 84C4 ; inline
-: GL_TEXTURE5 HEX: 84C5 ; inline
-: GL_TEXTURE6 HEX: 84C6 ; inline
-: GL_TEXTURE7 HEX: 84C7 ; inline
-: GL_TEXTURE8 HEX: 84C8 ; inline
-: GL_TEXTURE9 HEX: 84C9 ; inline
-: GL_TEXTURE10 HEX: 84CA ; inline
-: GL_TEXTURE11 HEX: 84CB ; inline
-: GL_TEXTURE12 HEX: 84CC ; inline
-: GL_TEXTURE13 HEX: 84CD ; inline
-: GL_TEXTURE14 HEX: 84CE ; inline
-: GL_TEXTURE15 HEX: 84CF ; inline
-: GL_TEXTURE16 HEX: 84D0 ; inline
-: GL_TEXTURE17 HEX: 84D1 ; inline
-: GL_TEXTURE18 HEX: 84D2 ; inline
-: GL_TEXTURE19 HEX: 84D3 ; inline
-: GL_TEXTURE20 HEX: 84D4 ; inline
-: GL_TEXTURE21 HEX: 84D5 ; inline
-: GL_TEXTURE22 HEX: 84D6 ; inline
-: GL_TEXTURE23 HEX: 84D7 ; inline
-: GL_TEXTURE24 HEX: 84D8 ; inline
-: GL_TEXTURE25 HEX: 84D9 ; inline
-: GL_TEXTURE26 HEX: 84DA ; inline
-: GL_TEXTURE27 HEX: 84DB ; inline
-: GL_TEXTURE28 HEX: 84DC ; inline
-: GL_TEXTURE29 HEX: 84DD ; inline
-: GL_TEXTURE30 HEX: 84DE ; inline
-: GL_TEXTURE31 HEX: 84DF ; inline
-: GL_ACTIVE_TEXTURE HEX: 84E0 ; inline
-: GL_CLIENT_ACTIVE_TEXTURE HEX: 84E1 ; inline
-: GL_MAX_TEXTURE_UNITS HEX: 84E2 ; inline
-: GL_TRANSPOSE_MODELVIEW_MATRIX HEX: 84E3 ; inline
-: GL_TRANSPOSE_PROJECTION_MATRIX HEX: 84E4 ; inline
-: GL_TRANSPOSE_TEXTURE_MATRIX HEX: 84E5 ; inline
-: GL_TRANSPOSE_COLOR_MATRIX HEX: 84E6 ; inline
-: GL_SUBTRACT HEX: 84E7 ; inline
-: GL_COMPRESSED_ALPHA HEX: 84E9 ; inline
-: GL_COMPRESSED_LUMINANCE HEX: 84EA ; inline
-: GL_COMPRESSED_LUMINANCE_ALPHA HEX: 84EB ; inline
-: GL_COMPRESSED_INTENSITY HEX: 84EC ; inline
-: GL_COMPRESSED_RGB HEX: 84ED ; inline
-: GL_COMPRESSED_RGBA HEX: 84EE ; inline
-: GL_TEXTURE_COMPRESSION_HINT HEX: 84EF ; inline
-: GL_NORMAL_MAP HEX: 8511 ; inline
-: GL_REFLECTION_MAP HEX: 8512 ; inline
-: GL_TEXTURE_CUBE_MAP HEX: 8513 ; inline
-: GL_TEXTURE_BINDING_CUBE_MAP HEX: 8514 ; inline
-: GL_TEXTURE_CUBE_MAP_POSITIVE_X HEX: 8515 ; inline
-: GL_TEXTURE_CUBE_MAP_NEGATIVE_X HEX: 8516 ; inline
-: GL_TEXTURE_CUBE_MAP_POSITIVE_Y HEX: 8517 ; inline
-: GL_TEXTURE_CUBE_MAP_NEGATIVE_Y HEX: 8518 ; inline
-: GL_TEXTURE_CUBE_MAP_POSITIVE_Z HEX: 8519 ; inline
-: GL_TEXTURE_CUBE_MAP_NEGATIVE_Z HEX: 851A ; inline
-: GL_PROXY_TEXTURE_CUBE_MAP HEX: 851B ; inline
-: GL_MAX_CUBE_MAP_TEXTURE_SIZE HEX: 851C ; inline
-: GL_COMBINE HEX: 8570 ; inline
-: GL_COMBINE_RGB HEX: 8571 ; inline
-: GL_COMBINE_ALPHA HEX: 8572 ; inline
-: GL_RGB_SCALE HEX: 8573 ; inline
-: GL_ADD_SIGNED HEX: 8574 ; inline
-: GL_INTERPOLATE HEX: 8575 ; inline
-: GL_CONSTANT HEX: 8576 ; inline
-: GL_PRIMARY_COLOR HEX: 8577 ; inline
-: GL_PREVIOUS HEX: 8578 ; inline
-: GL_SOURCE0_RGB HEX: 8580 ; inline
-: GL_SOURCE1_RGB HEX: 8581 ; inline
-: GL_SOURCE2_RGB HEX: 8582 ; inline
-: GL_SOURCE0_ALPHA HEX: 8588 ; inline
-: GL_SOURCE1_ALPHA HEX: 8589 ; inline
-: GL_SOURCE2_ALPHA HEX: 858A ; inline
-: GL_OPERAND0_RGB HEX: 8590 ; inline
-: GL_OPERAND1_RGB HEX: 8591 ; inline
-: GL_OPERAND2_RGB HEX: 8592 ; inline
-: GL_OPERAND0_ALPHA HEX: 8598 ; inline
-: GL_OPERAND1_ALPHA HEX: 8599 ; inline
-: GL_OPERAND2_ALPHA HEX: 859A ; inline
-: GL_TEXTURE_COMPRESSED_IMAGE_SIZE HEX: 86A0 ; inline
-: GL_TEXTURE_COMPRESSED HEX: 86A1 ; inline
-: GL_NUM_COMPRESSED_TEXTURE_FORMATS HEX: 86A2 ; inline
-: GL_COMPRESSED_TEXTURE_FORMATS HEX: 86A3 ; inline
-: GL_DOT3_RGB HEX: 86AE ; inline
-: GL_DOT3_RGBA HEX: 86AF ; inline
-: GL_MULTISAMPLE_BIT HEX: 20000000 ; inline
+CONSTANT: GL_MULTISAMPLE HEX: 809D
+CONSTANT: GL_SAMPLE_ALPHA_TO_COVERAGE HEX: 809E
+CONSTANT: GL_SAMPLE_ALPHA_TO_ONE HEX: 809F
+CONSTANT: GL_SAMPLE_COVERAGE HEX: 80A0
+CONSTANT: GL_SAMPLE_BUFFERS HEX: 80A8
+CONSTANT: GL_SAMPLES HEX: 80A9
+CONSTANT: GL_SAMPLE_COVERAGE_VALUE HEX: 80AA
+CONSTANT: GL_SAMPLE_COVERAGE_INVERT HEX: 80AB
+CONSTANT: GL_CLAMP_TO_BORDER HEX: 812D
+CONSTANT: GL_TEXTURE0 HEX: 84C0
+CONSTANT: GL_TEXTURE1 HEX: 84C1
+CONSTANT: GL_TEXTURE2 HEX: 84C2
+CONSTANT: GL_TEXTURE3 HEX: 84C3
+CONSTANT: GL_TEXTURE4 HEX: 84C4
+CONSTANT: GL_TEXTURE5 HEX: 84C5
+CONSTANT: GL_TEXTURE6 HEX: 84C6
+CONSTANT: GL_TEXTURE7 HEX: 84C7
+CONSTANT: GL_TEXTURE8 HEX: 84C8
+CONSTANT: GL_TEXTURE9 HEX: 84C9
+CONSTANT: GL_TEXTURE10 HEX: 84CA
+CONSTANT: GL_TEXTURE11 HEX: 84CB
+CONSTANT: GL_TEXTURE12 HEX: 84CC
+CONSTANT: GL_TEXTURE13 HEX: 84CD
+CONSTANT: GL_TEXTURE14 HEX: 84CE
+CONSTANT: GL_TEXTURE15 HEX: 84CF
+CONSTANT: GL_TEXTURE16 HEX: 84D0
+CONSTANT: GL_TEXTURE17 HEX: 84D1
+CONSTANT: GL_TEXTURE18 HEX: 84D2
+CONSTANT: GL_TEXTURE19 HEX: 84D3
+CONSTANT: GL_TEXTURE20 HEX: 84D4
+CONSTANT: GL_TEXTURE21 HEX: 84D5
+CONSTANT: GL_TEXTURE22 HEX: 84D6
+CONSTANT: GL_TEXTURE23 HEX: 84D7
+CONSTANT: GL_TEXTURE24 HEX: 84D8
+CONSTANT: GL_TEXTURE25 HEX: 84D9
+CONSTANT: GL_TEXTURE26 HEX: 84DA
+CONSTANT: GL_TEXTURE27 HEX: 84DB
+CONSTANT: GL_TEXTURE28 HEX: 84DC
+CONSTANT: GL_TEXTURE29 HEX: 84DD
+CONSTANT: GL_TEXTURE30 HEX: 84DE
+CONSTANT: GL_TEXTURE31 HEX: 84DF
+CONSTANT: GL_ACTIVE_TEXTURE HEX: 84E0
+CONSTANT: GL_CLIENT_ACTIVE_TEXTURE HEX: 84E1
+CONSTANT: GL_MAX_TEXTURE_UNITS HEX: 84E2
+CONSTANT: GL_TRANSPOSE_MODELVIEW_MATRIX HEX: 84E3
+CONSTANT: GL_TRANSPOSE_PROJECTION_MATRIX HEX: 84E4
+CONSTANT: GL_TRANSPOSE_TEXTURE_MATRIX HEX: 84E5
+CONSTANT: GL_TRANSPOSE_COLOR_MATRIX HEX: 84E6
+CONSTANT: GL_SUBTRACT HEX: 84E7
+CONSTANT: GL_COMPRESSED_ALPHA HEX: 84E9
+CONSTANT: GL_COMPRESSED_LUMINANCE HEX: 84EA
+CONSTANT: GL_COMPRESSED_LUMINANCE_ALPHA HEX: 84EB
+CONSTANT: GL_COMPRESSED_INTENSITY HEX: 84EC
+CONSTANT: GL_COMPRESSED_RGB HEX: 84ED
+CONSTANT: GL_COMPRESSED_RGBA HEX: 84EE
+CONSTANT: GL_TEXTURE_COMPRESSION_HINT HEX: 84EF
+CONSTANT: GL_NORMAL_MAP HEX: 8511
+CONSTANT: GL_REFLECTION_MAP HEX: 8512
+CONSTANT: GL_TEXTURE_CUBE_MAP HEX: 8513
+CONSTANT: GL_TEXTURE_BINDING_CUBE_MAP HEX: 8514
+CONSTANT: GL_TEXTURE_CUBE_MAP_POSITIVE_X HEX: 8515
+CONSTANT: GL_TEXTURE_CUBE_MAP_NEGATIVE_X HEX: 8516
+CONSTANT: GL_TEXTURE_CUBE_MAP_POSITIVE_Y HEX: 8517
+CONSTANT: GL_TEXTURE_CUBE_MAP_NEGATIVE_Y HEX: 8518
+CONSTANT: GL_TEXTURE_CUBE_MAP_POSITIVE_Z HEX: 8519
+CONSTANT: GL_TEXTURE_CUBE_MAP_NEGATIVE_Z HEX: 851A
+CONSTANT: GL_PROXY_TEXTURE_CUBE_MAP HEX: 851B
+CONSTANT: GL_MAX_CUBE_MAP_TEXTURE_SIZE HEX: 851C
+CONSTANT: GL_COMBINE HEX: 8570
+CONSTANT: GL_COMBINE_RGB HEX: 8571
+CONSTANT: GL_COMBINE_ALPHA HEX: 8572
+CONSTANT: GL_RGB_SCALE HEX: 8573
+CONSTANT: GL_ADD_SIGNED HEX: 8574
+CONSTANT: GL_INTERPOLATE HEX: 8575
+CONSTANT: GL_CONSTANT HEX: 8576
+CONSTANT: GL_PRIMARY_COLOR HEX: 8577
+CONSTANT: GL_PREVIOUS HEX: 8578
+CONSTANT: GL_SOURCE0_RGB HEX: 8580
+CONSTANT: GL_SOURCE1_RGB HEX: 8581
+CONSTANT: GL_SOURCE2_RGB HEX: 8582
+CONSTANT: GL_SOURCE0_ALPHA HEX: 8588
+CONSTANT: GL_SOURCE1_ALPHA HEX: 8589
+CONSTANT: GL_SOURCE2_ALPHA HEX: 858A
+CONSTANT: GL_OPERAND0_RGB HEX: 8590
+CONSTANT: GL_OPERAND1_RGB HEX: 8591
+CONSTANT: GL_OPERAND2_RGB HEX: 8592
+CONSTANT: GL_OPERAND0_ALPHA HEX: 8598
+CONSTANT: GL_OPERAND1_ALPHA HEX: 8599
+CONSTANT: GL_OPERAND2_ALPHA HEX: 859A
+CONSTANT: GL_TEXTURE_COMPRESSED_IMAGE_SIZE HEX: 86A0
+CONSTANT: GL_TEXTURE_COMPRESSED HEX: 86A1
+CONSTANT: GL_NUM_COMPRESSED_TEXTURE_FORMATS HEX: 86A2
+CONSTANT: GL_COMPRESSED_TEXTURE_FORMATS HEX: 86A3
+CONSTANT: GL_DOT3_RGB HEX: 86AE
+CONSTANT: GL_DOT3_RGBA HEX: 86AF
+CONSTANT: GL_MULTISAMPLE_BIT HEX: 20000000
GL-FUNCTION: void glActiveTexture { glActiveTextureARB } ( GLenum texture ) ;
GL-FUNCTION: void glClientActiveTexture { glClientActiveTextureARB } ( GLenum texture ) ;
! OpenGL 1.4
-: GL_BLEND_DST_RGB HEX: 80C8 ; inline
-: GL_BLEND_SRC_RGB HEX: 80C9 ; inline
-: GL_BLEND_DST_ALPHA HEX: 80CA ; inline
-: GL_BLEND_SRC_ALPHA HEX: 80CB ; inline
-: GL_POINT_SIZE_MIN HEX: 8126 ; inline
-: GL_POINT_SIZE_MAX HEX: 8127 ; inline
-: GL_POINT_FADE_THRESHOLD_SIZE HEX: 8128 ; inline
-: GL_POINT_DISTANCE_ATTENUATION HEX: 8129 ; inline
-: GL_GENERATE_MIPMAP HEX: 8191 ; inline
-: GL_GENERATE_MIPMAP_HINT HEX: 8192 ; inline
-: GL_DEPTH_COMPONENT16 HEX: 81A5 ; inline
-: GL_DEPTH_COMPONENT24 HEX: 81A6 ; inline
-: GL_DEPTH_COMPONENT32 HEX: 81A7 ; inline
-: GL_MIRRORED_REPEAT HEX: 8370 ; inline
-: GL_FOG_COORDINATE_SOURCE HEX: 8450 ; inline
-: GL_FOG_COORDINATE HEX: 8451 ; inline
-: GL_FRAGMENT_DEPTH HEX: 8452 ; inline
-: GL_CURRENT_FOG_COORDINATE HEX: 8453 ; inline
-: GL_FOG_COORDINATE_ARRAY_TYPE HEX: 8454 ; inline
-: GL_FOG_COORDINATE_ARRAY_STRIDE HEX: 8455 ; inline
-: GL_FOG_COORDINATE_ARRAY_POINTER HEX: 8456 ; inline
-: GL_FOG_COORDINATE_ARRAY HEX: 8457 ; inline
-: GL_COLOR_SUM HEX: 8458 ; inline
-: GL_CURRENT_SECONDARY_COLOR HEX: 8459 ; inline
-: GL_SECONDARY_COLOR_ARRAY_SIZE HEX: 845A ; inline
-: GL_SECONDARY_COLOR_ARRAY_TYPE HEX: 845B ; inline
-: GL_SECONDARY_COLOR_ARRAY_STRIDE HEX: 845C ; inline
-: GL_SECONDARY_COLOR_ARRAY_POINTER HEX: 845D ; inline
-: GL_SECONDARY_COLOR_ARRAY HEX: 845E ; inline
-: GL_MAX_TEXTURE_LOD_BIAS HEX: 84FD ; inline
-: GL_TEXTURE_FILTER_CONTROL HEX: 8500 ; inline
-: GL_TEXTURE_LOD_BIAS HEX: 8501 ; inline
-: GL_INCR_WRAP HEX: 8507 ; inline
-: GL_DECR_WRAP HEX: 8508 ; inline
-: GL_TEXTURE_DEPTH_SIZE HEX: 884A ; inline
-: GL_DEPTH_TEXTURE_MODE HEX: 884B ; inline
-: GL_TEXTURE_COMPARE_MODE HEX: 884C ; inline
-: GL_TEXTURE_COMPARE_FUNC HEX: 884D ; inline
-: GL_COMPARE_R_TO_TEXTURE HEX: 884E ; inline
+CONSTANT: GL_BLEND_DST_RGB HEX: 80C8
+CONSTANT: GL_BLEND_SRC_RGB HEX: 80C9
+CONSTANT: GL_BLEND_DST_ALPHA HEX: 80CA
+CONSTANT: GL_BLEND_SRC_ALPHA HEX: 80CB
+CONSTANT: GL_POINT_SIZE_MIN HEX: 8126
+CONSTANT: GL_POINT_SIZE_MAX HEX: 8127
+CONSTANT: GL_POINT_FADE_THRESHOLD_SIZE HEX: 8128
+CONSTANT: GL_POINT_DISTANCE_ATTENUATION HEX: 8129
+CONSTANT: GL_GENERATE_MIPMAP HEX: 8191
+CONSTANT: GL_GENERATE_MIPMAP_HINT HEX: 8192
+CONSTANT: GL_DEPTH_COMPONENT16 HEX: 81A5
+CONSTANT: GL_DEPTH_COMPONENT24 HEX: 81A6
+CONSTANT: GL_DEPTH_COMPONENT32 HEX: 81A7
+CONSTANT: GL_MIRRORED_REPEAT HEX: 8370
+CONSTANT: GL_FOG_COORDINATE_SOURCE HEX: 8450
+CONSTANT: GL_FOG_COORDINATE HEX: 8451
+CONSTANT: GL_FRAGMENT_DEPTH HEX: 8452
+CONSTANT: GL_CURRENT_FOG_COORDINATE HEX: 8453
+CONSTANT: GL_FOG_COORDINATE_ARRAY_TYPE HEX: 8454
+CONSTANT: GL_FOG_COORDINATE_ARRAY_STRIDE HEX: 8455
+CONSTANT: GL_FOG_COORDINATE_ARRAY_POINTER HEX: 8456
+CONSTANT: GL_FOG_COORDINATE_ARRAY HEX: 8457
+CONSTANT: GL_COLOR_SUM HEX: 8458
+CONSTANT: GL_CURRENT_SECONDARY_COLOR HEX: 8459
+CONSTANT: GL_SECONDARY_COLOR_ARRAY_SIZE HEX: 845A
+CONSTANT: GL_SECONDARY_COLOR_ARRAY_TYPE HEX: 845B
+CONSTANT: GL_SECONDARY_COLOR_ARRAY_STRIDE HEX: 845C
+CONSTANT: GL_SECONDARY_COLOR_ARRAY_POINTER HEX: 845D
+CONSTANT: GL_SECONDARY_COLOR_ARRAY HEX: 845E
+CONSTANT: GL_MAX_TEXTURE_LOD_BIAS HEX: 84FD
+CONSTANT: GL_TEXTURE_FILTER_CONTROL HEX: 8500
+CONSTANT: GL_TEXTURE_LOD_BIAS HEX: 8501
+CONSTANT: GL_INCR_WRAP HEX: 8507
+CONSTANT: GL_DECR_WRAP HEX: 8508
+CONSTANT: GL_TEXTURE_DEPTH_SIZE HEX: 884A
+CONSTANT: GL_DEPTH_TEXTURE_MODE HEX: 884B
+CONSTANT: GL_TEXTURE_COMPARE_MODE HEX: 884C
+CONSTANT: GL_TEXTURE_COMPARE_FUNC HEX: 884D
+CONSTANT: GL_COMPARE_R_TO_TEXTURE HEX: 884E
GL-FUNCTION: void glBlendColor { glBlendColorEXT } ( GLclampf red, GLclampf green, GLclampf blue, GLclampf alpha ) ;
GL-FUNCTION: void glBlendEquation { glBlendEquationEXT } ( GLenum mode ) ;
! OpenGL 1.5
-: GL_BUFFER_SIZE HEX: 8764 ; inline
-: GL_BUFFER_USAGE HEX: 8765 ; inline
-: GL_QUERY_COUNTER_BITS HEX: 8864 ; inline
-: GL_CURRENT_QUERY HEX: 8865 ; inline
-: GL_QUERY_RESULT HEX: 8866 ; inline
-: GL_QUERY_RESULT_AVAILABLE HEX: 8867 ; inline
-: GL_ARRAY_BUFFER HEX: 8892 ; inline
-: GL_ELEMENT_ARRAY_BUFFER HEX: 8893 ; inline
-: GL_ARRAY_BUFFER_BINDING HEX: 8894 ; inline
-: GL_ELEMENT_ARRAY_BUFFER_BINDING HEX: 8895 ; inline
-: GL_VERTEX_ARRAY_BUFFER_BINDING HEX: 8896 ; inline
-: GL_NORMAL_ARRAY_BUFFER_BINDING HEX: 8897 ; inline
-: GL_COLOR_ARRAY_BUFFER_BINDING HEX: 8898 ; inline
-: GL_INDEX_ARRAY_BUFFER_BINDING HEX: 8899 ; inline
-: GL_TEXTURE_COORD_ARRAY_BUFFER_BINDING HEX: 889A ; inline
-: GL_EDGE_FLAG_ARRAY_BUFFER_BINDING HEX: 889B ; inline
-: GL_SECONDARY_COLOR_ARRAY_BUFFER_BINDING HEX: 889C ; inline
-: GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING HEX: 889D ; inline
-: GL_WEIGHT_ARRAY_BUFFER_BINDING HEX: 889E ; inline
-: GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING HEX: 889F ; inline
-: GL_READ_ONLY HEX: 88B8 ; inline
-: GL_WRITE_ONLY HEX: 88B9 ; inline
-: GL_READ_WRITE HEX: 88BA ; inline
-: GL_BUFFER_ACCESS HEX: 88BB ; inline
-: GL_BUFFER_MAPPED HEX: 88BC ; inline
-: GL_BUFFER_MAP_POINTER HEX: 88BD ; inline
-: GL_STREAM_DRAW HEX: 88E0 ; inline
-: GL_STREAM_READ HEX: 88E1 ; inline
-: GL_STREAM_COPY HEX: 88E2 ; inline
-: GL_STATIC_DRAW HEX: 88E4 ; inline
-: GL_STATIC_READ HEX: 88E5 ; inline
-: GL_STATIC_COPY HEX: 88E6 ; inline
-: GL_DYNAMIC_DRAW HEX: 88E8 ; inline
-: GL_DYNAMIC_READ HEX: 88E9 ; inline
-: GL_DYNAMIC_COPY HEX: 88EA ; inline
-: GL_SAMPLES_PASSED HEX: 8914 ; inline
-: GL_FOG_COORD_SRC GL_FOG_COORDINATE_SOURCE ; inline
-: GL_FOG_COORD GL_FOG_COORDINATE ; inline
-: GL_FOG_COORD_ARRAY GL_FOG_COORDINATE_ARRAY ; inline
-: GL_SRC0_RGB GL_SOURCE0_RGB ; inline
-: GL_FOG_COORD_ARRAY_POINTER GL_FOG_COORDINATE_ARRAY_POINTER ; inline
-: GL_FOG_COORD_ARRAY_TYPE GL_FOG_COORDINATE_ARRAY_TYPE ; inline
-: GL_SRC1_ALPHA GL_SOURCE1_ALPHA ; inline
-: GL_CURRENT_FOG_COORD GL_CURRENT_FOG_COORDINATE ; inline
-: GL_FOG_COORD_ARRAY_STRIDE GL_FOG_COORDINATE_ARRAY_STRIDE ; inline
-: GL_SRC0_ALPHA GL_SOURCE0_ALPHA ; inline
-: GL_SRC1_RGB GL_SOURCE1_RGB ; inline
-: GL_FOG_COORD_ARRAY_BUFFER_BINDING GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING ; inline
-: GL_SRC2_ALPHA GL_SOURCE2_ALPHA ; inline
-: GL_SRC2_RGB GL_SOURCE2_RGB ; inline
+CONSTANT: GL_BUFFER_SIZE HEX: 8764
+CONSTANT: GL_BUFFER_USAGE HEX: 8765
+CONSTANT: GL_QUERY_COUNTER_BITS HEX: 8864
+CONSTANT: GL_CURRENT_QUERY HEX: 8865
+CONSTANT: GL_QUERY_RESULT HEX: 8866
+CONSTANT: GL_QUERY_RESULT_AVAILABLE HEX: 8867
+CONSTANT: GL_ARRAY_BUFFER HEX: 8892
+CONSTANT: GL_ELEMENT_ARRAY_BUFFER HEX: 8893
+CONSTANT: GL_ARRAY_BUFFER_BINDING HEX: 8894
+CONSTANT: GL_ELEMENT_ARRAY_BUFFER_BINDING HEX: 8895
+CONSTANT: GL_VERTEX_ARRAY_BUFFER_BINDING HEX: 8896
+CONSTANT: GL_NORMAL_ARRAY_BUFFER_BINDING HEX: 8897
+CONSTANT: GL_COLOR_ARRAY_BUFFER_BINDING HEX: 8898
+CONSTANT: GL_INDEX_ARRAY_BUFFER_BINDING HEX: 8899
+CONSTANT: GL_TEXTURE_COORD_ARRAY_BUFFER_BINDING HEX: 889A
+CONSTANT: GL_EDGE_FLAG_ARRAY_BUFFER_BINDING HEX: 889B
+CONSTANT: GL_SECONDARY_COLOR_ARRAY_BUFFER_BINDING HEX: 889C
+CONSTANT: GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING HEX: 889D
+CONSTANT: GL_WEIGHT_ARRAY_BUFFER_BINDING HEX: 889E
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING HEX: 889F
+CONSTANT: GL_READ_ONLY HEX: 88B8
+CONSTANT: GL_WRITE_ONLY HEX: 88B9
+CONSTANT: GL_READ_WRITE HEX: 88BA
+CONSTANT: GL_BUFFER_ACCESS HEX: 88BB
+CONSTANT: GL_BUFFER_MAPPED HEX: 88BC
+CONSTANT: GL_BUFFER_MAP_POINTER HEX: 88BD
+CONSTANT: GL_STREAM_DRAW HEX: 88E0
+CONSTANT: GL_STREAM_READ HEX: 88E1
+CONSTANT: GL_STREAM_COPY HEX: 88E2
+CONSTANT: GL_STATIC_DRAW HEX: 88E4
+CONSTANT: GL_STATIC_READ HEX: 88E5
+CONSTANT: GL_STATIC_COPY HEX: 88E6
+CONSTANT: GL_DYNAMIC_DRAW HEX: 88E8
+CONSTANT: GL_DYNAMIC_READ HEX: 88E9
+CONSTANT: GL_DYNAMIC_COPY HEX: 88EA
+CONSTANT: GL_SAMPLES_PASSED HEX: 8914
+ALIAS: GL_FOG_COORD_SRC GL_FOG_COORDINATE_SOURCE
+ALIAS: GL_FOG_COORD GL_FOG_COORDINATE
+ALIAS: GL_FOG_COORD_ARRAY GL_FOG_COORDINATE_ARRAY
+ALIAS: GL_SRC0_RGB GL_SOURCE0_RGB
+ALIAS: GL_FOG_COORD_ARRAY_POINTER GL_FOG_COORDINATE_ARRAY_POINTER
+ALIAS: GL_FOG_COORD_ARRAY_TYPE GL_FOG_COORDINATE_ARRAY_TYPE
+ALIAS: GL_SRC1_ALPHA GL_SOURCE1_ALPHA
+ALIAS: GL_CURRENT_FOG_COORD GL_CURRENT_FOG_COORDINATE
+ALIAS: GL_FOG_COORD_ARRAY_STRIDE GL_FOG_COORDINATE_ARRAY_STRIDE
+ALIAS: GL_SRC0_ALPHA GL_SOURCE0_ALPHA
+ALIAS: GL_SRC1_RGB GL_SOURCE1_RGB
+ALIAS: GL_FOG_COORD_ARRAY_BUFFER_BINDING GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING
+ALIAS: GL_SRC2_ALPHA GL_SOURCE2_ALPHA
+ALIAS: GL_SRC2_RGB GL_SOURCE2_RGB
TYPEDEF: ptrdiff_t GLsizeiptr
TYPEDEF: ptrdiff_t GLintptr
! OpenGL 2.0
-: GL_VERTEX_ATTRIB_ARRAY_ENABLED HEX: 8622 ; inline
-: GL_VERTEX_ATTRIB_ARRAY_SIZE HEX: 8623 ; inline
-: GL_VERTEX_ATTRIB_ARRAY_STRIDE HEX: 8624 ; inline
-: GL_VERTEX_ATTRIB_ARRAY_TYPE HEX: 8625 ; inline
-: GL_CURRENT_VERTEX_ATTRIB HEX: 8626 ; inline
-: GL_VERTEX_PROGRAM_POINT_SIZE HEX: 8642 ; inline
-: GL_VERTEX_PROGRAM_TWO_SIDE HEX: 8643 ; inline
-: GL_VERTEX_ATTRIB_ARRAY_POINTER HEX: 8645 ; inline
-: GL_STENCIL_BACK_FUNC HEX: 8800 ; inline
-: GL_STENCIL_BACK_FAIL HEX: 8801 ; inline
-: GL_STENCIL_BACK_PASS_DEPTH_FAIL HEX: 8802 ; inline
-: GL_STENCIL_BACK_PASS_DEPTH_PASS HEX: 8803 ; inline
-: GL_MAX_DRAW_BUFFERS HEX: 8824 ; inline
-: GL_DRAW_BUFFER0 HEX: 8825 ; inline
-: GL_DRAW_BUFFER1 HEX: 8826 ; inline
-: GL_DRAW_BUFFER2 HEX: 8827 ; inline
-: GL_DRAW_BUFFER3 HEX: 8828 ; inline
-: GL_DRAW_BUFFER4 HEX: 8829 ; inline
-: GL_DRAW_BUFFER5 HEX: 882A ; inline
-: GL_DRAW_BUFFER6 HEX: 882B ; inline
-: GL_DRAW_BUFFER7 HEX: 882C ; inline
-: GL_DRAW_BUFFER8 HEX: 882D ; inline
-: GL_DRAW_BUFFER9 HEX: 882E ; inline
-: GL_DRAW_BUFFER10 HEX: 882F ; inline
-: GL_DRAW_BUFFER11 HEX: 8830 ; inline
-: GL_DRAW_BUFFER12 HEX: 8831 ; inline
-: GL_DRAW_BUFFER13 HEX: 8832 ; inline
-: GL_DRAW_BUFFER14 HEX: 8833 ; inline
-: GL_DRAW_BUFFER15 HEX: 8834 ; inline
-: GL_BLEND_EQUATION_ALPHA HEX: 883D ; inline
-: GL_POINT_SPRITE HEX: 8861 ; inline
-: GL_COORD_REPLACE HEX: 8862 ; inline
-: GL_MAX_VERTEX_ATTRIBS HEX: 8869 ; inline
-: GL_VERTEX_ATTRIB_ARRAY_NORMALIZED HEX: 886A ; inline
-: GL_MAX_TEXTURE_COORDS HEX: 8871 ; inline
-: GL_MAX_TEXTURE_IMAGE_UNITS HEX: 8872 ; inline
-: GL_FRAGMENT_SHADER HEX: 8B30 ; inline
-: GL_VERTEX_SHADER HEX: 8B31 ; inline
-: GL_MAX_FRAGMENT_UNIFORM_COMPONENTS HEX: 8B49 ; inline
-: GL_MAX_VERTEX_UNIFORM_COMPONENTS HEX: 8B4A ; inline
-: GL_MAX_VARYING_FLOATS HEX: 8B4B ; inline
-: GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS HEX: 8B4C ; inline
-: GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS HEX: 8B4D ; inline
-: GL_SHADER_TYPE HEX: 8B4F ; inline
-: GL_FLOAT_VEC2 HEX: 8B50 ; inline
-: GL_FLOAT_VEC3 HEX: 8B51 ; inline
-: GL_FLOAT_VEC4 HEX: 8B52 ; inline
-: GL_INT_VEC2 HEX: 8B53 ; inline
-: GL_INT_VEC3 HEX: 8B54 ; inline
-: GL_INT_VEC4 HEX: 8B55 ; inline
-: GL_BOOL HEX: 8B56 ; inline
-: GL_BOOL_VEC2 HEX: 8B57 ; inline
-: GL_BOOL_VEC3 HEX: 8B58 ; inline
-: GL_BOOL_VEC4 HEX: 8B59 ; inline
-: GL_FLOAT_MAT2 HEX: 8B5A ; inline
-: GL_FLOAT_MAT3 HEX: 8B5B ; inline
-: GL_FLOAT_MAT4 HEX: 8B5C ; inline
-: GL_SAMPLER_1D HEX: 8B5D ; inline
-: GL_SAMPLER_2D HEX: 8B5E ; inline
-: GL_SAMPLER_3D HEX: 8B5F ; inline
-: GL_SAMPLER_CUBE HEX: 8B60 ; inline
-: GL_SAMPLER_1D_SHADOW HEX: 8B61 ; inline
-: GL_SAMPLER_2D_SHADOW HEX: 8B62 ; inline
-: GL_DELETE_STATUS HEX: 8B80 ; inline
-: GL_COMPILE_STATUS HEX: 8B81 ; inline
-: GL_LINK_STATUS HEX: 8B82 ; inline
-: GL_VALIDATE_STATUS HEX: 8B83 ; inline
-: GL_INFO_LOG_LENGTH HEX: 8B84 ; inline
-: GL_ATTACHED_SHADERS HEX: 8B85 ; inline
-: GL_ACTIVE_UNIFORMS HEX: 8B86 ; inline
-: GL_ACTIVE_UNIFORM_MAX_LENGTH HEX: 8B87 ; inline
-: GL_SHADER_SOURCE_LENGTH HEX: 8B88 ; inline
-: GL_ACTIVE_ATTRIBUTES HEX: 8B89 ; inline
-: GL_ACTIVE_ATTRIBUTE_MAX_LENGTH HEX: 8B8A ; inline
-: GL_FRAGMENT_SHADER_DERIVATIVE_HINT HEX: 8B8B ; inline
-: GL_SHADING_LANGUAGE_VERSION HEX: 8B8C ; inline
-: GL_CURRENT_PROGRAM HEX: 8B8D ; inline
-: GL_POINT_SPRITE_COORD_ORIGIN HEX: 8CA0 ; inline
-: GL_LOWER_LEFT HEX: 8CA1 ; inline
-: GL_UPPER_LEFT HEX: 8CA2 ; inline
-: GL_STENCIL_BACK_REF HEX: 8CA3 ; inline
-: GL_STENCIL_BACK_VALUE_MASK HEX: 8CA4 ; inline
-: GL_STENCIL_BACK_WRITEMASK HEX: 8CA5 ; inline
-: GL_BLEND_EQUATION HEX: 8009 ; inline
-: GL_BLEND_EQUATION_RGB GL_BLEND_EQUATION ; inline
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_ENABLED HEX: 8622
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_SIZE HEX: 8623
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_STRIDE HEX: 8624
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_TYPE HEX: 8625
+CONSTANT: GL_CURRENT_VERTEX_ATTRIB HEX: 8626
+CONSTANT: GL_VERTEX_PROGRAM_POINT_SIZE HEX: 8642
+CONSTANT: GL_VERTEX_PROGRAM_TWO_SIDE HEX: 8643
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_POINTER HEX: 8645
+CONSTANT: GL_STENCIL_BACK_FUNC HEX: 8800
+CONSTANT: GL_STENCIL_BACK_FAIL HEX: 8801
+CONSTANT: GL_STENCIL_BACK_PASS_DEPTH_FAIL HEX: 8802
+CONSTANT: GL_STENCIL_BACK_PASS_DEPTH_PASS HEX: 8803
+CONSTANT: GL_MAX_DRAW_BUFFERS HEX: 8824
+CONSTANT: GL_DRAW_BUFFER0 HEX: 8825
+CONSTANT: GL_DRAW_BUFFER1 HEX: 8826
+CONSTANT: GL_DRAW_BUFFER2 HEX: 8827
+CONSTANT: GL_DRAW_BUFFER3 HEX: 8828
+CONSTANT: GL_DRAW_BUFFER4 HEX: 8829
+CONSTANT: GL_DRAW_BUFFER5 HEX: 882A
+CONSTANT: GL_DRAW_BUFFER6 HEX: 882B
+CONSTANT: GL_DRAW_BUFFER7 HEX: 882C
+CONSTANT: GL_DRAW_BUFFER8 HEX: 882D
+CONSTANT: GL_DRAW_BUFFER9 HEX: 882E
+CONSTANT: GL_DRAW_BUFFER10 HEX: 882F
+CONSTANT: GL_DRAW_BUFFER11 HEX: 8830
+CONSTANT: GL_DRAW_BUFFER12 HEX: 8831
+CONSTANT: GL_DRAW_BUFFER13 HEX: 8832
+CONSTANT: GL_DRAW_BUFFER14 HEX: 8833
+CONSTANT: GL_DRAW_BUFFER15 HEX: 8834
+CONSTANT: GL_BLEND_EQUATION_ALPHA HEX: 883D
+CONSTANT: GL_POINT_SPRITE HEX: 8861
+CONSTANT: GL_COORD_REPLACE HEX: 8862
+CONSTANT: GL_MAX_VERTEX_ATTRIBS HEX: 8869
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_NORMALIZED HEX: 886A
+CONSTANT: GL_MAX_TEXTURE_COORDS HEX: 8871
+CONSTANT: GL_MAX_TEXTURE_IMAGE_UNITS HEX: 8872
+CONSTANT: GL_FRAGMENT_SHADER HEX: 8B30
+CONSTANT: GL_VERTEX_SHADER HEX: 8B31
+CONSTANT: GL_MAX_FRAGMENT_UNIFORM_COMPONENTS HEX: 8B49
+CONSTANT: GL_MAX_VERTEX_UNIFORM_COMPONENTS HEX: 8B4A
+CONSTANT: GL_MAX_VARYING_FLOATS HEX: 8B4B
+CONSTANT: GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS HEX: 8B4C
+CONSTANT: GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS HEX: 8B4D
+CONSTANT: GL_SHADER_TYPE HEX: 8B4F
+CONSTANT: GL_FLOAT_VEC2 HEX: 8B50
+CONSTANT: GL_FLOAT_VEC3 HEX: 8B51
+CONSTANT: GL_FLOAT_VEC4 HEX: 8B52
+CONSTANT: GL_INT_VEC2 HEX: 8B53
+CONSTANT: GL_INT_VEC3 HEX: 8B54
+CONSTANT: GL_INT_VEC4 HEX: 8B55
+CONSTANT: GL_BOOL HEX: 8B56
+CONSTANT: GL_BOOL_VEC2 HEX: 8B57
+CONSTANT: GL_BOOL_VEC3 HEX: 8B58
+CONSTANT: GL_BOOL_VEC4 HEX: 8B59
+CONSTANT: GL_FLOAT_MAT2 HEX: 8B5A
+CONSTANT: GL_FLOAT_MAT3 HEX: 8B5B
+CONSTANT: GL_FLOAT_MAT4 HEX: 8B5C
+CONSTANT: GL_SAMPLER_1D HEX: 8B5D
+CONSTANT: GL_SAMPLER_2D HEX: 8B5E
+CONSTANT: GL_SAMPLER_3D HEX: 8B5F
+CONSTANT: GL_SAMPLER_CUBE HEX: 8B60
+CONSTANT: GL_SAMPLER_1D_SHADOW HEX: 8B61
+CONSTANT: GL_SAMPLER_2D_SHADOW HEX: 8B62
+CONSTANT: GL_DELETE_STATUS HEX: 8B80
+CONSTANT: GL_COMPILE_STATUS HEX: 8B81
+CONSTANT: GL_LINK_STATUS HEX: 8B82
+CONSTANT: GL_VALIDATE_STATUS HEX: 8B83
+CONSTANT: GL_INFO_LOG_LENGTH HEX: 8B84
+CONSTANT: GL_ATTACHED_SHADERS HEX: 8B85
+CONSTANT: GL_ACTIVE_UNIFORMS HEX: 8B86
+CONSTANT: GL_ACTIVE_UNIFORM_MAX_LENGTH HEX: 8B87
+CONSTANT: GL_SHADER_SOURCE_LENGTH HEX: 8B88
+CONSTANT: GL_ACTIVE_ATTRIBUTES HEX: 8B89
+CONSTANT: GL_ACTIVE_ATTRIBUTE_MAX_LENGTH HEX: 8B8A
+CONSTANT: GL_FRAGMENT_SHADER_DERIVATIVE_HINT HEX: 8B8B
+CONSTANT: GL_SHADING_LANGUAGE_VERSION HEX: 8B8C
+CONSTANT: GL_CURRENT_PROGRAM HEX: 8B8D
+CONSTANT: GL_POINT_SPRITE_COORD_ORIGIN HEX: 8CA0
+CONSTANT: GL_LOWER_LEFT HEX: 8CA1
+CONSTANT: GL_UPPER_LEFT HEX: 8CA2
+CONSTANT: GL_STENCIL_BACK_REF HEX: 8CA3
+CONSTANT: GL_STENCIL_BACK_VALUE_MASK HEX: 8CA4
+CONSTANT: GL_STENCIL_BACK_WRITEMASK HEX: 8CA5
+CONSTANT: GL_BLEND_EQUATION HEX: 8009
+ALIAS: GL_BLEND_EQUATION_RGB GL_BLEND_EQUATION
TYPEDEF: char GLchar
! OpenGL 2.1
-: GL_CURRENT_RASTER_SECONDARY_COLOR HEX: 845F ; inline
-: GL_PIXEL_PACK_BUFFER HEX: 88EB ; inline
-: GL_PIXEL_UNPACK_BUFFER HEX: 88EC ; inline
-: GL_PIXEL_PACK_BUFFER_BINDING HEX: 88ED ; inline
-: GL_PIXEL_UNPACK_BUFFER_BINDING HEX: 88EF ; inline
-: GL_SRGB HEX: 8C40 ; inline
-: GL_SRGB8 HEX: 8C41 ; inline
-: GL_SRGB_ALPHA HEX: 8C42 ; inline
-: GL_SRGB8_ALPHA8 HEX: 8C43 ; inline
-: GL_SLUMINANCE_ALPHA HEX: 8C44 ; inline
-: GL_SLUMINANCE8_ALPHA8 HEX: 8C45 ; inline
-: GL_SLUMINANCE HEX: 8C46 ; inline
-: GL_SLUMINANCE8 HEX: 8C47 ; inline
-: GL_COMPRESSED_SRGB HEX: 8C48 ; inline
-: GL_COMPRESSED_SRGB_ALPHA HEX: 8C49 ; inline
-: GL_COMPRESSED_SLUMINANCE HEX: 8C4A ; inline
-: GL_COMPRESSED_SLUMINANCE_ALPHA HEX: 8C4B ; inline
+CONSTANT: GL_CURRENT_RASTER_SECONDARY_COLOR HEX: 845F
+CONSTANT: GL_PIXEL_PACK_BUFFER HEX: 88EB
+CONSTANT: GL_PIXEL_UNPACK_BUFFER HEX: 88EC
+CONSTANT: GL_PIXEL_PACK_BUFFER_BINDING HEX: 88ED
+CONSTANT: GL_PIXEL_UNPACK_BUFFER_BINDING HEX: 88EF
+CONSTANT: GL_SRGB HEX: 8C40
+CONSTANT: GL_SRGB8 HEX: 8C41
+CONSTANT: GL_SRGB_ALPHA HEX: 8C42
+CONSTANT: GL_SRGB8_ALPHA8 HEX: 8C43
+CONSTANT: GL_SLUMINANCE_ALPHA HEX: 8C44
+CONSTANT: GL_SLUMINANCE8_ALPHA8 HEX: 8C45
+CONSTANT: GL_SLUMINANCE HEX: 8C46
+CONSTANT: GL_SLUMINANCE8 HEX: 8C47
+CONSTANT: GL_COMPRESSED_SRGB HEX: 8C48
+CONSTANT: GL_COMPRESSED_SRGB_ALPHA HEX: 8C49
+CONSTANT: GL_COMPRESSED_SLUMINANCE HEX: 8C4A
+CONSTANT: GL_COMPRESSED_SLUMINANCE_ALPHA HEX: 8C4B
GL-FUNCTION: void glUniformMatrix2x3fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix2x4fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
! GL_EXT_framebuffer_object
-: GL_INVALID_FRAMEBUFFER_OPERATION_EXT HEX: 0506 ; inline
-: GL_MAX_RENDERBUFFER_SIZE_EXT HEX: 84E8 ; inline
-: GL_FRAMEBUFFER_BINDING_EXT HEX: 8CA6 ; inline
-: GL_RENDERBUFFER_BINDING_EXT HEX: 8CA7 ; inline
-: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE_EXT HEX: 8CD0 ; inline
-: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT HEX: 8CD1 ; inline
-: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL_EXT HEX: 8CD2 ; inline
-: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE_EXT HEX: 8CD3 ; inline
-: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT HEX: 8CD4 ; inline
-: GL_FRAMEBUFFER_COMPLETE_EXT HEX: 8CD5 ; inline
-: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT HEX: 8CD6 ; inline
-: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT HEX: 8CD7 ; inline
-: GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT HEX: 8CD9 ; inline
-: GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT HEX: 8CDA ; inline
-: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT HEX: 8CDB ; inline
-: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT HEX: 8CDC ; inline
-: GL_FRAMEBUFFER_UNSUPPORTED_EXT HEX: 8CDD ; inline
-: GL_MAX_COLOR_ATTACHMENTS_EXT HEX: 8CDF ; inline
-: GL_COLOR_ATTACHMENT0_EXT HEX: 8CE0 ; inline
-: GL_COLOR_ATTACHMENT1_EXT HEX: 8CE1 ; inline
-: GL_COLOR_ATTACHMENT2_EXT HEX: 8CE2 ; inline
-: GL_COLOR_ATTACHMENT3_EXT HEX: 8CE3 ; inline
-: GL_COLOR_ATTACHMENT4_EXT HEX: 8CE4 ; inline
-: GL_COLOR_ATTACHMENT5_EXT HEX: 8CE5 ; inline
-: GL_COLOR_ATTACHMENT6_EXT HEX: 8CE6 ; inline
-: GL_COLOR_ATTACHMENT7_EXT HEX: 8CE7 ; inline
-: GL_COLOR_ATTACHMENT8_EXT HEX: 8CE8 ; inline
-: GL_COLOR_ATTACHMENT9_EXT HEX: 8CE9 ; inline
-: GL_COLOR_ATTACHMENT10_EXT HEX: 8CEA ; inline
-: GL_COLOR_ATTACHMENT11_EXT HEX: 8CEB ; inline
-: GL_COLOR_ATTACHMENT12_EXT HEX: 8CEC ; inline
-: GL_COLOR_ATTACHMENT13_EXT HEX: 8CED ; inline
-: GL_COLOR_ATTACHMENT14_EXT HEX: 8CEE ; inline
-: GL_COLOR_ATTACHMENT15_EXT HEX: 8CEF ; inline
-: GL_DEPTH_ATTACHMENT_EXT HEX: 8D00 ; inline
-: GL_STENCIL_ATTACHMENT_EXT HEX: 8D20 ; inline
-: GL_FRAMEBUFFER_EXT HEX: 8D40 ; inline
-: GL_RENDERBUFFER_EXT HEX: 8D41 ; inline
-: GL_RENDERBUFFER_WIDTH_EXT HEX: 8D42 ; inline
-: GL_RENDERBUFFER_HEIGHT_EXT HEX: 8D43 ; inline
-: GL_RENDERBUFFER_INTERNAL_FORMAT_EXT HEX: 8D44 ; inline
-: GL_STENCIL_INDEX1_EXT HEX: 8D46 ; inline
-: GL_STENCIL_INDEX4_EXT HEX: 8D47 ; inline
-: GL_STENCIL_INDEX8_EXT HEX: 8D48 ; inline
-: GL_STENCIL_INDEX16_EXT HEX: 8D49 ; inline
-: GL_RENDERBUFFER_RED_SIZE_EXT HEX: 8D50 ; inline
-: GL_RENDERBUFFER_GREEN_SIZE_EXT HEX: 8D51 ; inline
-: GL_RENDERBUFFER_BLUE_SIZE_EXT HEX: 8D52 ; inline
-: GL_RENDERBUFFER_ALPHA_SIZE_EXT HEX: 8D53 ; inline
-: GL_RENDERBUFFER_DEPTH_SIZE_EXT HEX: 8D54 ; inline
-: GL_RENDERBUFFER_STENCIL_SIZE_EXT HEX: 8D55 ; inline
+CONSTANT: GL_INVALID_FRAMEBUFFER_OPERATION_EXT HEX: 0506
+CONSTANT: GL_MAX_RENDERBUFFER_SIZE_EXT HEX: 84E8
+CONSTANT: GL_FRAMEBUFFER_BINDING_EXT HEX: 8CA6
+CONSTANT: GL_RENDERBUFFER_BINDING_EXT HEX: 8CA7
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE_EXT HEX: 8CD0
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT HEX: 8CD1
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL_EXT HEX: 8CD2
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE_EXT HEX: 8CD3
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT HEX: 8CD4
+CONSTANT: GL_FRAMEBUFFER_COMPLETE_EXT HEX: 8CD5
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT HEX: 8CD6
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT HEX: 8CD7
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT HEX: 8CD9
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT HEX: 8CDA
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT HEX: 8CDB
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT HEX: 8CDC
+CONSTANT: GL_FRAMEBUFFER_UNSUPPORTED_EXT HEX: 8CDD
+CONSTANT: GL_MAX_COLOR_ATTACHMENTS_EXT HEX: 8CDF
+CONSTANT: GL_COLOR_ATTACHMENT0_EXT HEX: 8CE0
+CONSTANT: GL_COLOR_ATTACHMENT1_EXT HEX: 8CE1
+CONSTANT: GL_COLOR_ATTACHMENT2_EXT HEX: 8CE2
+CONSTANT: GL_COLOR_ATTACHMENT3_EXT HEX: 8CE3
+CONSTANT: GL_COLOR_ATTACHMENT4_EXT HEX: 8CE4
+CONSTANT: GL_COLOR_ATTACHMENT5_EXT HEX: 8CE5
+CONSTANT: GL_COLOR_ATTACHMENT6_EXT HEX: 8CE6
+CONSTANT: GL_COLOR_ATTACHMENT7_EXT HEX: 8CE7
+CONSTANT: GL_COLOR_ATTACHMENT8_EXT HEX: 8CE8
+CONSTANT: GL_COLOR_ATTACHMENT9_EXT HEX: 8CE9
+CONSTANT: GL_COLOR_ATTACHMENT10_EXT HEX: 8CEA
+CONSTANT: GL_COLOR_ATTACHMENT11_EXT HEX: 8CEB
+CONSTANT: GL_COLOR_ATTACHMENT12_EXT HEX: 8CEC
+CONSTANT: GL_COLOR_ATTACHMENT13_EXT HEX: 8CED
+CONSTANT: GL_COLOR_ATTACHMENT14_EXT HEX: 8CEE
+CONSTANT: GL_COLOR_ATTACHMENT15_EXT HEX: 8CEF
+CONSTANT: GL_DEPTH_ATTACHMENT_EXT HEX: 8D00
+CONSTANT: GL_STENCIL_ATTACHMENT_EXT HEX: 8D20
+CONSTANT: GL_FRAMEBUFFER_EXT HEX: 8D40
+CONSTANT: GL_RENDERBUFFER_EXT HEX: 8D41
+CONSTANT: GL_RENDERBUFFER_WIDTH_EXT HEX: 8D42
+CONSTANT: GL_RENDERBUFFER_HEIGHT_EXT HEX: 8D43
+CONSTANT: GL_RENDERBUFFER_INTERNAL_FORMAT_EXT HEX: 8D44
+CONSTANT: GL_STENCIL_INDEX1_EXT HEX: 8D46
+CONSTANT: GL_STENCIL_INDEX4_EXT HEX: 8D47
+CONSTANT: GL_STENCIL_INDEX8_EXT HEX: 8D48
+CONSTANT: GL_STENCIL_INDEX16_EXT HEX: 8D49
+CONSTANT: GL_RENDERBUFFER_RED_SIZE_EXT HEX: 8D50
+CONSTANT: GL_RENDERBUFFER_GREEN_SIZE_EXT HEX: 8D51
+CONSTANT: GL_RENDERBUFFER_BLUE_SIZE_EXT HEX: 8D52
+CONSTANT: GL_RENDERBUFFER_ALPHA_SIZE_EXT HEX: 8D53
+CONSTANT: GL_RENDERBUFFER_DEPTH_SIZE_EXT HEX: 8D54
+CONSTANT: GL_RENDERBUFFER_STENCIL_SIZE_EXT HEX: 8D55
GL-FUNCTION: void glBindFramebufferEXT { } ( GLenum target, GLuint framebuffer ) ;
GL-FUNCTION: void glBindRenderbufferEXT { } ( GLenum target, GLuint renderbuffer ) ;
! GL_ARB_texture_float
-: GL_RGBA32F_ARB HEX: 8814 ; inline
-: GL_RGB32F_ARB HEX: 8815 ; inline
-: GL_ALPHA32F_ARB HEX: 8816 ; inline
-: GL_INTENSITY32F_ARB HEX: 8817 ; inline
-: GL_LUMINANCE32F_ARB HEX: 8818 ; inline
-: GL_LUMINANCE_ALPHA32F_ARB HEX: 8819 ; inline
-: GL_RGBA16F_ARB HEX: 881A ; inline
-: GL_RGB16F_ARB HEX: 881B ; inline
-: GL_ALPHA16F_ARB HEX: 881C ; inline
-: GL_INTENSITY16F_ARB HEX: 881D ; inline
-: GL_LUMINANCE16F_ARB HEX: 881E ; inline
-: GL_LUMINANCE_ALPHA16F_ARB HEX: 881F ; inline
-: GL_TEXTURE_RED_TYPE_ARB HEX: 8C10 ; inline
-: GL_TEXTURE_GREEN_TYPE_ARB HEX: 8C11 ; inline
-: GL_TEXTURE_BLUE_TYPE_ARB HEX: 8C12 ; inline
-: GL_TEXTURE_ALPHA_TYPE_ARB HEX: 8C13 ; inline
-: GL_TEXTURE_LUMINANCE_TYPE_ARB HEX: 8C14 ; inline
-: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15 ; inline
-: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16 ; inline
-: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17 ; inline
+CONSTANT: GL_RGBA32F_ARB HEX: 8814
+CONSTANT: GL_RGB32F_ARB HEX: 8815
+CONSTANT: GL_ALPHA32F_ARB HEX: 8816
+CONSTANT: GL_INTENSITY32F_ARB HEX: 8817
+CONSTANT: GL_LUMINANCE32F_ARB HEX: 8818
+CONSTANT: GL_LUMINANCE_ALPHA32F_ARB HEX: 8819
+CONSTANT: GL_RGBA16F_ARB HEX: 881A
+CONSTANT: GL_RGB16F_ARB HEX: 881B
+CONSTANT: GL_ALPHA16F_ARB HEX: 881C
+CONSTANT: GL_INTENSITY16F_ARB HEX: 881D
+CONSTANT: GL_LUMINANCE16F_ARB HEX: 881E
+CONSTANT: GL_LUMINANCE_ALPHA16F_ARB HEX: 881F
+CONSTANT: GL_TEXTURE_RED_TYPE_ARB HEX: 8C10
+CONSTANT: GL_TEXTURE_GREEN_TYPE_ARB HEX: 8C11
+CONSTANT: GL_TEXTURE_BLUE_TYPE_ARB HEX: 8C12
+CONSTANT: GL_TEXTURE_ALPHA_TYPE_ARB HEX: 8C13
+CONSTANT: GL_TEXTURE_LUMINANCE_TYPE_ARB HEX: 8C14
+CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15
+CONSTANT: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16
+CONSTANT: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17
--- /dev/null
+Joe Groff
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs strings ;
+IN: opengl.shaders
+
+HELP: gl-shader
+{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:"
+ { $list
+ { { $link <gl-shader> } " - Compile GLSL code into a shader object" }
+ { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" }
+ { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" }
+ { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" }
+ { { $link delete-gl-shader } " - Invalidate a shader object" }
+ }
+ "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ;
+
+HELP: vertex-shader
+{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:"
+ { $list
+ { { $link <vertex-shader> } " - Compile GLSL code into a vertex shader object "}
+ }
+} ;
+
+HELP: fragment-shader
+{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:"
+ { $list
+ { { $link <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
+ }
+} ;
+
+HELP: <gl-shader>
+{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } { "shader" "a new " { $link gl-shader } } }
+{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
+
+HELP: <vertex-shader>
+{ $values { "source" "The GLSL source code to compile" } { "vertex-shader" "a new " { $link vertex-shader } } }
+{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
+
+HELP: <fragment-shader>
+{ $values { "source" "The GLSL source code to compile" } { "fragment-shader" "a new " { $link fragment-shader } } }
+{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
+
+HELP: gl-shader-ok?
+{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } }
+{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
+
+HELP: check-gl-shader
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ;
+
+HELP: delete-gl-shader
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
+
+HELP: gl-shader-info-log
+{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } }
+{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
+
+HELP: gl-program
+{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
+ { $list
+ { { $link <gl-program> } ", " { $link <simple-gl-program> } " - Link a set of shaders into a GLSL program" }
+ { { $link gl-program-ok? } " - Check whether a program object linked successfully" }
+ { { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
+ { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
+ { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" }
+ { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
+ { { $link with-gl-program } " - Use a program object" }
+ }
+} ;
+
+HELP: <gl-program>
+{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } { "program" "a new " { $link gl-program } } }
+{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
+
+HELP: <simple-gl-program>
+{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } { "program" "a new " { $link gl-program } } }
+{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
+
+{ <gl-program> <simple-gl-program> } related-words
+
+HELP: gl-program-ok?
+{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } }
+{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
+
+HELP: check-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
+
+HELP: gl-program-info-log
+{ $values { "program" "A " { $link gl-program } " object" } { "log" string } }
+{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
+
+HELP: delete-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
+
+HELP: with-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } }
+{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
+
+ABOUT: "gl-utilities"
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel opengl.gl alien.c-types continuations namespaces
+assocs alien alien.strings libc opengl math sequences combinators
+macros arrays io.encodings.ascii fry specialized-arrays.uint
+destructors accessors ;
+IN: opengl.shaders
+
+: with-gl-shader-source-ptr ( string quot -- )
+ swap ascii malloc-string [ <void*> swap call ] keep free ; inline
+
+: <gl-shader> ( source kind -- shader )
+ glCreateShader dup rot
+ [ 1 swap f glShaderSource ] with-gl-shader-source-ptr
+ [ glCompileShader ] keep
+ gl-error ;
+
+: (gl-shader?) ( object -- ? )
+ dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
+
+: gl-shader-get-int ( shader enum -- value )
+ 0 <int> [ glGetShaderiv ] keep *int ;
+
+: gl-shader-ok? ( shader -- ? )
+ GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
+
+: <vertex-shader> ( source -- vertex-shader )
+ GL_VERTEX_SHADER <gl-shader> ; inline
+
+: (vertex-shader?) ( object -- ? )
+ dup (gl-shader?)
+ [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
+ [ drop f ] if ;
+
+: <fragment-shader> ( source -- fragment-shader )
+ GL_FRAGMENT_SHADER <gl-shader> ; inline
+
+: (fragment-shader?) ( object -- ? )
+ dup (gl-shader?)
+ [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ]
+ [ drop f ] if ;
+
+: gl-shader-info-log-length ( shader -- log-length )
+ GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
+
+: gl-shader-info-log ( shader -- log )
+ dup gl-shader-info-log-length dup [
+ 1 calloc &free
+ [ 0 <int> swap glGetShaderInfoLog ] keep
+ ascii alien>string
+ ] with-destructors ;
+
+: check-gl-shader ( shader -- shader )
+ dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
+
+: delete-gl-shader ( shader -- ) glDeleteShader ; inline
+
+PREDICATE: gl-shader < integer (gl-shader?) ;
+PREDICATE: vertex-shader < gl-shader (vertex-shader?) ;
+PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
+
+! Programs
+
+: <gl-program> ( shaders -- program )
+ glCreateProgram swap
+ [ dupd glAttachShader ] each
+ [ glLinkProgram ] keep
+ gl-error ;
+
+: (gl-program?) ( object -- ? )
+ dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
+
+: gl-program-get-int ( program enum -- value )
+ 0 <int> [ glGetProgramiv ] keep *int ;
+
+: gl-program-ok? ( program -- ? )
+ GL_LINK_STATUS gl-program-get-int c-bool> ;
+
+: gl-program-info-log-length ( program -- log-length )
+ GL_INFO_LOG_LENGTH gl-program-get-int ; inline
+
+: gl-program-info-log ( program -- log )
+ dup gl-program-info-log-length dup [
+ 1 calloc &free
+ [ 0 <int> swap glGetProgramInfoLog ] keep
+ ascii alien>string
+ ] with-destructors ;
+
+: check-gl-program ( program -- program )
+ dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
+
+: gl-program-shaders-length ( program -- shaders-length )
+ GL_ATTACHED_SHADERS gl-program-get-int ; inline
+
+: gl-program-shaders ( program -- shaders )
+ dup gl-program-shaders-length
+ 0 <int>
+ over <uint-array>
+ [ underlying>> glGetAttachedShaders ] keep ;
+
+: delete-gl-program-only ( program -- )
+ glDeleteProgram ; inline
+
+: detach-gl-program-shader ( program shader -- )
+ glDetachShader ; inline
+
+: delete-gl-program ( program -- )
+ dup gl-program-shaders [
+ 2dup detach-gl-program-shader delete-gl-shader
+ ] each delete-gl-program-only ;
+
+: with-gl-program ( program quot -- )
+ over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
+
+PREDICATE: gl-program < integer (gl-program?) ;
+
+: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
+ >r <vertex-shader> check-gl-shader
+ r> <fragment-shader> check-gl-shader
+ 2array <gl-program> check-gl-program ;
+
--- /dev/null
+OpenGL Shading Language (GLSL) support
\ No newline at end of file
--- /dev/null
+opengl
+bindings
\ No newline at end of file
{ [ os unix? ] [ "libssl" "libssl.so" "cdecl" add-library ] }
} cond >>
-: X509_FILETYPE_PEM 1 ; inline
-: X509_FILETYPE_ASN1 2 ; inline
-: X509_FILETYPE_DEFAULT 3 ; inline
-
-: SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1 ; inline
-: SSL_FILETYPE_PEM X509_FILETYPE_PEM ; inline
-
-: SSL_CTRL_NEED_TMP_RSA 1 ; inline
-: SSL_CTRL_SET_TMP_RSA 2 ; inline
-: SSL_CTRL_SET_TMP_DH 3 ; inline
-: SSL_CTRL_SET_TMP_RSA_CB 4 ; inline
-: SSL_CTRL_SET_TMP_DH_CB 5 ; inline
-
-: SSL_CTRL_GET_SESSION_REUSED 6 ; inline
-: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7 ; inline
-: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8 ; inline
-: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9 ; inline
-: SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 10 ; inline
-: SSL_CTRL_GET_FLAGS 11 ; inline
-: SSL_CTRL_EXTRA_CHAIN_CERT 12 ; inline
-
-: SSL_CTRL_SET_MSG_CALLBACK 13 ; inline
-: SSL_CTRL_SET_MSG_CALLBACK_ARG 14 ; inline
-
-: SSL_CTRL_SESS_NUMBER 20 ; inline
-: SSL_CTRL_SESS_CONNECT 21 ; inline
-: SSL_CTRL_SESS_CONNECT_GOOD 22 ; inline
-: SSL_CTRL_SESS_CONNECT_RENEGOTIATE 23 ; inline
-: SSL_CTRL_SESS_ACCEPT 24 ; inline
-: SSL_CTRL_SESS_ACCEPT_GOOD 25 ; inline
-: SSL_CTRL_SESS_ACCEPT_RENEGOTIATE 26 ; inline
-: SSL_CTRL_SESS_HIT 27 ; inline
-: SSL_CTRL_SESS_CB_HIT 28 ; inline
-: SSL_CTRL_SESS_MISSES 29 ; inline
-: SSL_CTRL_SESS_TIMEOUTS 30 ; inline
-: SSL_CTRL_SESS_CACHE_FULL 31 ; inline
-: SSL_CTRL_OPTIONS 32 ; inline
-: SSL_CTRL_MODE 33 ; inline
-
-: SSL_CTRL_GET_READ_AHEAD 40 ; inline
-: SSL_CTRL_SET_READ_AHEAD 41 ; inline
-: SSL_CTRL_SET_SESS_CACHE_SIZE 42 ; inline
-: SSL_CTRL_GET_SESS_CACHE_SIZE 43 ; inline
-: SSL_CTRL_SET_SESS_CACHE_MODE 44 ; inline
-: SSL_CTRL_GET_SESS_CACHE_MODE 45 ; inline
-
-: SSL_CTRL_GET_MAX_CERT_LIST 50 ; inline
-: SSL_CTRL_SET_MAX_CERT_LIST 51 ; inline
-
-: SSL_ERROR_NONE 0 ; inline
-: SSL_ERROR_SSL 1 ; inline
-: SSL_ERROR_WANT_READ 2 ; inline
-: SSL_ERROR_WANT_WRITE 3 ; inline
-: SSL_ERROR_WANT_X509_LOOKUP 4 ; inline
-: SSL_ERROR_SYSCALL 5 ; inline ! consult errno for details
-: SSL_ERROR_ZERO_RETURN 6 ; inline
-: SSL_ERROR_WANT_CONNECT 7 ; inline
-: SSL_ERROR_WANT_ACCEPT 8 ; inline
+CONSTANT: X509_FILETYPE_PEM 1
+CONSTANT: X509_FILETYPE_ASN1 2
+CONSTANT: X509_FILETYPE_DEFAULT 3
+
+ALIAS: SSL_FILETYPE_ASN1 X509_FILETYPE_ASN1
+ALIAS: SSL_FILETYPE_PEM X509_FILETYPE_PEM
+
+CONSTANT: SSL_CTRL_NEED_TMP_RSA 1
+CONSTANT: SSL_CTRL_SET_TMP_RSA 2
+CONSTANT: SSL_CTRL_SET_TMP_DH 3
+CONSTANT: SSL_CTRL_SET_TMP_RSA_CB 4
+CONSTANT: SSL_CTRL_SET_TMP_DH_CB 5
+
+CONSTANT: SSL_CTRL_GET_SESSION_REUSED 6
+CONSTANT: SSL_CTRL_GET_CLIENT_CERT_REQUEST 7
+CONSTANT: SSL_CTRL_GET_NUM_RENEGOTIATIONS 8
+CONSTANT: SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 9
+CONSTANT: SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 10
+CONSTANT: SSL_CTRL_GET_FLAGS 11
+CONSTANT: SSL_CTRL_EXTRA_CHAIN_CERT 12
+
+CONSTANT: SSL_CTRL_SET_MSG_CALLBACK 13
+CONSTANT: SSL_CTRL_SET_MSG_CALLBACK_ARG 14
+
+CONSTANT: SSL_CTRL_SESS_NUMBER 20
+CONSTANT: SSL_CTRL_SESS_CONNECT 21
+CONSTANT: SSL_CTRL_SESS_CONNECT_GOOD 22
+CONSTANT: SSL_CTRL_SESS_CONNECT_RENEGOTIATE 23
+CONSTANT: SSL_CTRL_SESS_ACCEPT 24
+CONSTANT: SSL_CTRL_SESS_ACCEPT_GOOD 25
+CONSTANT: SSL_CTRL_SESS_ACCEPT_RENEGOTIATE 26
+CONSTANT: SSL_CTRL_SESS_HIT 27
+CONSTANT: SSL_CTRL_SESS_CB_HIT 28
+CONSTANT: SSL_CTRL_SESS_MISSES 29
+CONSTANT: SSL_CTRL_SESS_TIMEOUTS 30
+CONSTANT: SSL_CTRL_SESS_CACHE_FULL 31
+CONSTANT: SSL_CTRL_OPTIONS 32
+CONSTANT: SSL_CTRL_MODE 33
+
+CONSTANT: SSL_CTRL_GET_READ_AHEAD 40
+CONSTANT: SSL_CTRL_SET_READ_AHEAD 41
+CONSTANT: SSL_CTRL_SET_SESS_CACHE_SIZE 42
+CONSTANT: SSL_CTRL_GET_SESS_CACHE_SIZE 43
+CONSTANT: SSL_CTRL_SET_SESS_CACHE_MODE 44
+CONSTANT: SSL_CTRL_GET_SESS_CACHE_MODE 45
+
+CONSTANT: SSL_CTRL_GET_MAX_CERT_LIST 50
+CONSTANT: SSL_CTRL_SET_MAX_CERT_LIST 51
+
+CONSTANT: SSL_ERROR_NONE 0
+CONSTANT: SSL_ERROR_SSL 1
+CONSTANT: SSL_ERROR_WANT_READ 2
+CONSTANT: SSL_ERROR_WANT_WRITE 3
+CONSTANT: SSL_ERROR_WANT_X509_LOOKUP 4
+CONSTANT: SSL_ERROR_SYSCALL 5 ! consult errno for details
+CONSTANT: SSL_ERROR_ZERO_RETURN 6
+CONSTANT: SSL_ERROR_WANT_CONNECT 7
+CONSTANT: SSL_ERROR_WANT_ACCEPT 8
! Error messages table
: error-messages ( -- hash )
FUNCTION: int SSL_shutdown ( SSL* ssl ) ;
-: SSL_SENT_SHUTDOWN 1 ;
-: SSL_RECEIVED_SHUTDOWN 2 ;
+CONSTANT: SSL_SENT_SHUTDOWN 1
+CONSTANT: SSL_RECEIVED_SHUTDOWN 2
FUNCTION: int SSL_get_shutdown ( SSL* ssl ) ;
FUNCTION: int SSL_want ( SSL* ssl ) ;
-: SSL_NOTHING 1 ; inline
-: SSL_WRITING 2 ; inline
-: SSL_READING 3 ; inline
-: SSL_X509_LOOKUP 4 ; inline
+CONSTANT: SSL_NOTHING 1
+CONSTANT: SSL_WRITING 2
+CONSTANT: SSL_READING 3
+CONSTANT: SSL_X509_LOOKUP 4
FUNCTION: long SSL_get_verify_result ( SSL* ssl ) ;
FUNCTION: int SSL_CTX_set_default_verify_paths ( SSL_CTX* ctx ) ;
-: SSL_VERIFY_NONE 0 ; inline
-: SSL_VERIFY_PEER 1 ; inline
-: SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2 ; inline
-: SSL_VERIFY_CLIENT_ONCE 4 ; inline
+CONSTANT: SSL_VERIFY_NONE 0
+CONSTANT: SSL_VERIFY_PEER 1
+CONSTANT: SSL_VERIFY_FAIL_IF_NO_PEER_CERT 2
+CONSTANT: SSL_VERIFY_CLIENT_ONCE 4
FUNCTION: void SSL_CTX_set_verify ( SSL_CTX* ctx, int mode, void* callback ) ;
: SSL_CTX_set_session_cache_mode ( ctx mode -- n )
[ SSL_CTRL_SET_SESS_CACHE_MODE ] dip f SSL_CTX_ctrl ;
-: SSL_SESS_CACHE_OFF HEX: 0000 ; inline
-: SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline
-: SSL_SESS_CACHE_SERVER HEX: 0002 ; inline
+CONSTANT: SSL_SESS_CACHE_OFF HEX: 0000
+CONSTANT: SSL_SESS_CACHE_CLIENT HEX: 0001
+CONSTANT: SSL_SESS_CACHE_SERVER HEX: 0002
: SSL_SESS_CACHE_BOTH ( -- n )
{ SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
-: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080 ; inline
-: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100 ; inline
-: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 ; inline
+CONSTANT: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080
+CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100
+CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200
: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
: X509_V_:
scan "X509_V_" prepend create-in
scan-word
- [ 1quotation define-inline ]
- [ verify-messages get set-at ] 2bi ; parsing
+ [ 1quotation (( -- value )) define-inline ]
+ [ verify-messages get set-at ]
+ 2bi ; parsing
>>
! obj_mac.h
! ===============================================
-: NID_commonName 13 ; inline
+CONSTANT: NID_commonName 13
! Copyback (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math qualified ;
+USING: kernel accessors math ;
QUALIFIED: sequences
IN: persistent.deques
: node-size 32 ; inline
-: node-mask node-size mod ; inline
+: node-mask ( m -- n ) node-size mod ; inline
-: node-shift -5 * shift ; inline
+: node-shift ( m n -- x ) -5 * shift ; inline
: node-nth ( i node -- obj )
[ node-mask ] [ children>> ] bi* nth ;
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays generic hashtables io assocs
-kernel math namespaces make sequences strings sbufs io.styles
-vectors words prettyprint.config prettyprint.custom
-prettyprint.sections quotations io io.files math.parser effects
+kernel math namespaces make sequences strings sbufs vectors
+words prettyprint.config prettyprint.custom prettyprint.sections
+quotations io io.pathnames io.styles math.parser effects
classes.tuple math.order classes.tuple.private classes
combinators colors ;
IN: prettyprint.backend
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic generic.standard assocs io kernel math
namespaces make sequences strings io.styles io.streams.string
-vectors words prettyprint.backend prettyprint.custom
+vectors words words.symbol prettyprint.backend prettyprint.custom
prettyprint.sections prettyprint.config sorting splitting
grouping math.parser vocabs definitions effects classes.builtin
-classes.tuple io.files classes continuations hashtables
+classes.tuple io.pathnames classes continuations hashtables
classes.mixin classes.union classes.intersection
classes.predicate classes.singleton combinators quotations sets
-accessors colors parser summary ;
+accessors colors parser summary vocabs.parser ;
IN: prettyprint
: make-pprint ( obj quot -- block in use )
] when drop ;
M: word see
- dup see-class
- dup class? over symbol? not and [
- nl
- ] when
- dup [ class? ] [ symbol? ] bi and
- [ drop ] [ call-next-method ] if ;
+ [ see-class ]
+ [ [ class? ] [ symbol? not ] bi and [ nl ] when ]
+ [
+ dup [ class? ] [ symbol? ] bi and
+ [ drop ] [ call-next-method ] if
+ ] tri ;
: see-all ( seq -- )
natural-sort [ nl ] [ see ] interleave ;
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: qualified
-
-HELP: QUALIFIED:
-{ $syntax "QUALIFIED: vocab" }
-{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
-{ $examples { $example
- "USING: prettyprint qualified ;"
- "QUALIFIED: math"
- "1 2 math:+ ." "3"
-} } ;
-
-HELP: QUALIFIED-WITH:
-{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
-{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
-{ $examples { $code
- "USING: prettyprint qualified ;"
- "QUALIFIED-WITH: math m"
- "1 2 m:+ ."
- "3"
-} } ;
-
-HELP: FROM:
-{ $syntax "FROM: vocab => words ... ;" }
-{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." }
-{ $examples { $code
- "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
-
-HELP: EXCLUDE:
-{ $syntax "EXCLUDE: vocab => words ... ;" }
-{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." }
-{ $examples { $code
- "EXCLUDE: math.parser => bin> hex> ; ! imports everything but bin> and hex>" } } ;
-
-HELP: RENAME:
-{ $syntax "RENAME: word vocab => newname " }
-{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
-{ $examples { $example
- "USING: prettyprint qualified ;"
- "RENAME: + math => -"
- "2 3 - ."
- "5"
-} } ;
-
-ARTICLE: "qualified" "Qualified word lookup"
-"The " { $vocab-link "qualified" } " vocabulary provides a handful of parsing words which give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } "."
-$nl
-"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file."
-{ $subsection POSTPONE: QUALIFIED: }
-{ $subsection POSTPONE: QUALIFIED-WITH: }
-{ $subsection POSTPONE: FROM: }
-{ $subsection POSTPONE: EXCLUDE: }
-{ $subsection POSTPONE: RENAME: } ;
-
-ABOUT: "qualified"
+++ /dev/null
-USING: tools.test qualified eval accessors parser ;
-IN: qualified.tests.foo
-: x 1 ;
-: y 5 ;
-IN: qualified.tests.bar
-: x 2 ;
-: y 4 ;
-IN: qualified.tests.baz
-: x 3 ;
-
-QUALIFIED: qualified.tests.foo
-QUALIFIED: qualified.tests.bar
-[ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test
-
-QUALIFIED-WITH: qualified.tests.bar p
-[ 2 ] [ p:x ] unit-test
-
-RENAME: x qualified.tests.baz => y
-[ 3 ] [ y ] unit-test
-
-FROM: qualified.tests.baz => x ;
-[ 3 ] [ x ] unit-test
-[ 3 ] [ y ] unit-test
-
-EXCLUDE: qualified.tests.bar => x ;
-[ 3 ] [ x ] unit-test
-[ 4 ] [ y ] unit-test
-
-[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
-[ error>> no-word-error? ] must-fail-with
-
-[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ]
-[ error>> no-word-error? ] must-fail-with
+++ /dev/null
-! Copyright (C) 2007, 2008 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs hashtables parser lexer
-vocabs words namespaces vocabs.loader sets fry ;
-IN: qualified
-
-: define-qualified ( vocab-name prefix-name -- )
- [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
- '[ [ [ _ ] dip append ] dip ] assoc-map
- use get push ;
-
-: QUALIFIED:
- #! Syntax: QUALIFIED: vocab
- scan dup define-qualified ; parsing
-
-: QUALIFIED-WITH:
- #! Syntax: QUALIFIED-WITH: vocab prefix
- scan scan define-qualified ; parsing
-
-: partial-vocab ( words vocab -- assoc )
- '[ dup _ lookup [ no-word-error ] unless* ]
- { } map>assoc ;
-
-: FROM:
- #! Syntax: FROM: vocab => words... ;
- scan dup load-vocab drop "=>" expect
- ";" parse-tokens swap partial-vocab use get push ; parsing
-
-: partial-vocab-excluding ( words vocab -- assoc )
- [ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
-
-: EXCLUDE:
- #! Syntax: EXCLUDE: vocab => words ... ;
- scan "=>" expect
- ";" parse-tokens swap partial-vocab-excluding use get push ; parsing
-
-: RENAME:
- #! Syntax: RENAME: word vocab => newname
- scan scan dup load-vocab drop
- dupd lookup [ ] [ no-word-error ] ?if
- "=>" expect
- scan associate use get push ; parsing
-
+++ /dev/null
-Qualified naming for vocabularies
+++ /dev/null
-extensions
TUPLE: ref assoc key ;
-: >ref< [ key>> ] [ assoc>> ] bi ; inline
+: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math math.order symbols
-words regexp.utils unicode.categories combinators.short-circuit ;
+USING: accessors kernel math math.order words regexp.utils
+unicode.categories combinators.short-circuit ;
IN: regexp.classes
SINGLETONS: any-char any-char-no-nl
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators io io.streams.string
-kernel math math.parser namespaces qualified sets
-quotations sequences splitting symbols vectors math.order
+kernel math math.parser namespaces sets
+quotations sequences splitting vectors math.order
unicode.categories strings regexp.backend regexp.utils
unicode.case words locals regexp.classes ;
IN: regexp.parser
ABOUT: "search-deques"
-HELP: <search-deque> ( assoc deque -- search-deque )
+HELP: <search-deque>
{ $values { "assoc" assoc } { "deque" deque } { "search-deque" search-deque } }
{ $description "Creates a new " { $link search-deque } "." } ;
Daniel Ehrenberg
+Doug Coleman
[ "foo" ] [ "foo" [ string? ] deep-find ] unit-test
[ { { 1 2 } 1 2 } ] [ [ { 1 2 } [ , ] deep-each ] { } make ] unit-test
+
+[ t ]
+[ { { 1 2 3 } 4 } { { { 1 { { 1 2 3 } 4 } } } 2 } deep-member? ] unit-test
+
+[ t ]
+[ { { 1 2 3 } 4 } { { { 1 2 3 } 4 } 2 } deep-member? ] unit-test
+
+[ f ]
+[ { 1 2 3 4 } { 1 2 3 { 4 } } deep-subseq? ] unit-test
+
+[ t ]
+[ { 1 2 3 4 } { 1 2 3 4 } deep-subseq? ] unit-test
+
+[ t ]
+[ { 1 2 3 4 } { { 1 2 3 4 } } deep-subseq? ] unit-test
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel strings math ;
+USING: sequences kernel strings math fry ;
IN: sequences.deep
! All traversal goes in postorder
: deep-all? ( obj quot -- ? )
[ not ] compose deep-contains? not ; inline
+: deep-member? ( obj seq -- ? )
+ swap '[
+ _ swap dup branch? [ member? ] [ 2drop f ] if
+ ] deep-find >boolean ;
+
+: deep-subseq? ( subseq seq -- ? )
+ swap '[
+ _ swap dup branch? [ subseq? ] [ 2drop f ] if
+ ] deep-find >boolean ;
+
: deep-change-each ( obj quot: ( elt -- elt' ) -- )
over branch? [
[ [ call ] keep over [ deep-change-each ] dip ] curry change-each
<PRIVATE
-: iterate-seq [ dup length swap ] dip ; inline
+: iterate-seq ( seq quot -- i seq quot )
+ [ [ length ] keep ] dip ; inline
: (map-next) ( i seq quot -- )
! this uses O(n) more bounds checks than is really necessary
namespaces io.sockets io.sockets.secure continuations calendar
io.encodings.ascii io.streams.duplex destructors locals
concurrency.promises threads accessors smtp.private
-io.unix.sockets.secure.debug ;
+io.sockets.secure.unix.debug ;
IN: smtp.server
! Mock SMTP server for testing purposes.
HELP: plain-auth
{ $class-description "If the " { $link smtp-auth } " variable is set to this value, plain authentication will be performed, with the username and password stored in the " { $slot "username" } " and " { $slot "password" } " slots of the tuple sent to the server as plain-text." } ;
-HELP: <plain-auth> ( username password -- plain-auth )
+HELP: <plain-auth>
{ $values { "username" string } { "password" string } { "plain-auth" plain-auth } }
{ $description "Creates a new " { $link plain-auth } " instance." } ;
LOG: smtp-response DEBUG
-: multiline? ( response -- boolean )
+: multiline? ( response -- ? )
3 swap ?nth CHAR: - = ;
: (receive-response) ( -- )
TUPLE: V { underlying A } { length array-capacity } ;
-: <V> <A> execute 0 V boa ; inline
+: <V>
( capacity -- vector ) <A> execute 0 V boa ; inline
M: V like
drop dup V instance? [
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
-: >V V new clone-like ; inline
+: >V ( seq -- vector ) V new clone-like ; inline
M: V pprint-delims drop V{ \ } ;
: effect-required? ( word -- ? )
{
- { [ dup inline? ] [ drop f ] }
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
[ def>> [ word? ] contains? ]
+++ /dev/null
-Slava Pestov
-Doug Coleman
+++ /dev/null
-Utility for defining multiple symbols at a time
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: symbols
-
-HELP: SYMBOLS:
-{ $syntax "SYMBOLS: words... ;" }
-{ $values { "words" "a sequence of new words to define" } }
-{ $description "Creates a new word for every token until the ';'." }
-{ $examples { $example "USING: prettyprint symbols ;" "IN: scratchpad" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } }
-{ $see-also POSTPONE: SYMBOL: } ;
+++ /dev/null
-USING: kernel symbols tools.test parser generic words accessors
-eval ;
-IN: symbols.tests
-
-[ ] [ SYMBOLS: a b c ; ] unit-test
-[ a ] [ a ] unit-test
-[ b ] [ b ] unit-test
-[ c ] [ c ] unit-test
-
-DEFER: blah
-
-[ ] [ "IN: symbols.tests GENERIC: blah" eval ] unit-test
-[ ] [ "IN: symbols.tests USE: symbols SYMBOLS: blah ;" eval ] unit-test
-
-[ f ] [ \ blah generic? ] unit-test
-[ t ] [ \ blah symbol? ] unit-test
-
-[ "IN: symbols.tests USE: symbols SINGLETONS: blah blah blah ;" eval ]
-[ error>> error>> def>> \ blah eq? ]
-must-fail-with
-
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer sequences words kernel classes.singleton
-classes.parser ;
-IN: symbols
-
-: SYMBOLS:
- ";" parse-tokens
- [ create-in dup reset-generic define-symbol ] each ;
- parsing
-
-: SINGLETONS:
- ";" parse-tokens
- [ create-class-in define-singleton-class ] each ;
- parsing
+++ /dev/null
-extensions
-USING: math kernel sequences io.files tools.crossref tools.test
-parser namespaces source-files generic definitions ;
+USING: math kernel sequences io.files io.pathnames
+tools.crossref tools.test parser namespaces source-files generic
+definitions ;
IN: tools.crossref.tests
GENERIC: foo
assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
summary layouts vocabs.loader prettyprint.config prettyprint
-debugger io.streams.c io.files io.backend quotations io.launcher
-words.private tools.deploy.config tools.deploy.config.editor
-bootstrap.image io.encodings.utf8 destructors accessors ;
+debugger io.streams.c io.files io.files.temp io.pathnames
+io.directories io.directories.hierarchy io.backend quotations
+io.launcher words.private tools.deploy.config
+tools.deploy.config.editor bootstrap.image io.encodings.utf8
+destructors accessors ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name extension -- vm )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs io.files kernel parser prettyprint sequences
+USING: assocs io.pathnames kernel parser prettyprint sequences
splitting tools.deploy.config tools.vocabs vocabs.loader ;
IN: tools.deploy.config.editor
IN: tools.deploy.tests\r
-USING: tools.test system io.files kernel tools.deploy.config\r
+USING: tools.test system io.pathnames io.files io.files.info\r
+io.files.temp kernel tools.deploy.config\r
tools.deploy.config.editor tools.deploy.backend math sequences\r
io.launcher arrays namespaces continuations layouts accessors\r
-io.encodings.ascii urls math.parser ;\r
+io.encodings.ascii urls math.parser io.directories ;\r
\r
: shake-and-bake ( vocab -- )\r
[ "test.image" temp-file delete-file ] ignore-errors\r
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files kernel namespaces make sequences system
-tools.deploy.backend tools.deploy.config
+USING: io io.files io.files.info.unix io.pathnames
+io.directories io.directories.hierarchy kernel namespaces make
+sequences system tools.deploy.backend tools.deploy.config
tools.deploy.config.editor assocs hashtables prettyprint
-io.unix.backend cocoa io.encodings.utf8 io.backend
-cocoa.application cocoa.classes cocoa.plists qualified
+io.backend.unix cocoa io.encodings.utf8 io.backend
+cocoa.application cocoa.classes cocoa.plists
combinators ;
IN: tools.deploy.macosx
} cleave
]
[ create-app-plist ]
- [ "Contents/MacOS/" append-path "" copy-vm ] 2tri ;
+ [ "Contents/MacOS/" append-path "" copy-vm ] 2tri
+ dup OCT: 755 set-file-permissions ;
: deploy.app-image ( vocab bundle-name -- str )
[ % "/Contents/Resources/" % % ".image" % ] "" make ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors qualified io.backend io.streams.c init fry
+USING: accessors io.backend io.streams.c init fry
namespaces make assocs kernel parser lexer strings.parser vocabs
sequences words words.private memory kernel.private
continuations io vocabs.loader system strings sets
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files io.backend kernel namespaces make sequences
+USING: io io.pathnames io.directories io.files
+io.files.info.unix io.backend kernel namespaces make sequences
system tools.deploy.backend tools.deploy.config
tools.deploy.config.editor assocs hashtables prettyprint ;
IN: tools.deploy.unix
: create-app-dir ( vocab bundle-name -- vm )
dup "" copy-fonts
- "" copy-vm ;
+ "" copy-vm
+ dup OCT: 755 set-file-permissions ;
: bundle-name ( -- str )
deploy-name get ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files kernel namespaces sequences system
+USING: io io.files io.directories kernel namespaces sequences system
tools.deploy.backend tools.deploy.config
tools.deploy.config.editor assocs hashtables prettyprint
combinators windows.shell32 windows.user32 ;
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io words alien kernel math.parser alien.syntax
-io.launcher system assocs arrays sequences namespaces make
-qualified system math io.encodings.ascii accessors
-tools.disassembler ;
+USING: io.files io.files.temp io words alien kernel math.parser
+alien.syntax io.launcher system assocs arrays sequences
+namespaces make system math io.encodings.ascii
+accessors tools.disassembler ;
IN: tools.disassembler.gdb
SINGLETON: gdb-disassembler
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
-: UD_SYN_INTEL &: ud_translate_intel ; inline
-: UD_SYN_ATT &: ud_translate_att ; inline
+: UD_SYN_INTEL ( -- addr ) &: ud_translate_intel ; inline
+: UD_SYN_ATT ( -- addr ) &: ud_translate_att ; inline
+
: UD_EOI -1 ; inline
: UD_INP_CACHE_SZ 32 ; inline
: UD_VENDOR_AMD 0 ; inline
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators io io.files kernel
-math.parser sequences system vocabs.loader calendar math
-symbols fry prettyprint ;
+USING: accessors arrays combinators io io.files io.files.info
+io.directories kernel math.parser sequences system vocabs.loader
+calendar math fry prettyprint ;
IN: tools.files
<PRIVATE
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel system unicode.case
-io.unix.files tools.files generalizations strings
-arrays sequences io.files math.parser unix.groups unix.users
+USING: accessors combinators kernel system unicode.case io.files
+io.files.info io.files.info.unix tools.files generalizations
+strings arrays sequences math.parser unix.groups unix.users
tools.files.private unix.stat math ;
IN: tools.files.unix
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar.format combinators io.files
kernel math.parser sequences splitting system tools.files
-generalizations tools.files.private ;
+generalizations tools.files.private io.files.info ;
IN: tools.files.windows
<PRIVATE
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs io.files hashtables kernel namespaces sequences
-vocabs.loader io combinators io.encodings.utf8 calendar accessors
-math.parser io.streams.string ui.tools.operations quotations
-strings arrays prettyprint words vocabs sorting sets
-classes math alien urls splitting ascii ;
+USING: assocs io.files io.pathnames io.directories
+io.encodings.utf8 hashtables kernel namespaces sequences
+vocabs.loader io combinators calendar accessors math.parser
+io.streams.string ui.tools.operations quotations strings arrays
+prettyprint words vocabs sorting sets classes math alien urls
+splitting ascii ;
IN: tools.scaffold
SYMBOL: developer-name
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple classes.union combinators
-definitions effects fry generic help help.markup
-help.stylesheet help.topics io io.files io.styles kernel macros
+definitions effects fry generic help help.markup help.stylesheet
+help.topics io io.files io.pathnames io.styles kernel macros
make namespaces prettyprint sequences sets sorting summary
-tools.vocabs vocabs vocabs.loader words ;
+tools.vocabs vocabs vocabs.loader words words.symbol ;
IN: tools.vocabs.browser
: vocab-status-string ( vocab -- string )
-USING: tools.test tools.vocabs.monitor io.files ;
+USING: tools.test tools.vocabs.monitor io.pathnames ;
IN: tools.vocabs.monitor.tests
[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: threads io.files io.monitors init kernel\r
+USING: threads io.files io.pathnames io.monitors init kernel\r
vocabs vocabs.loader tools.vocabs namespaces continuations\r
sequences splitting assocs command-line concurrency.messaging\r
io.backend sets tr ;\r
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel io io.styles io.files io.encodings.utf8\r
-vocabs.loader vocabs sequences namespaces make math.parser\r
-arrays hashtables assocs memoize summary sorting splitting\r
-combinators source-files debugger continuations compiler.errors\r
-init checksums checksums.crc32 sets accessors generic\r
-definitions words ;\r
+USING: kernel io io.styles io.files io.files.info io.directories\r
+io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences\r
+namespaces make math.parser arrays hashtables assocs memoize\r
+summary sorting splitting combinators source-files debugger\r
+continuations compiler.errors init checksums checksums.crc32\r
+sets accessors generic definitions words ;\r
IN: tools.vocabs\r
\r
: vocab-xref ( vocab quot -- vocabs )\r
--- /dev/null
+IN: ui.event-loop.tests
+USING: ui.event-loop tools.test ;
+
+\ event-loop must-infer
72 dpi set-global
-: ft-floor -6 shift ; inline
+: ft-floor ( m -- n ) -6 shift ; inline
-: ft-ceil 63 + -64 bitand -6 shift ; inline
+: ft-ceil ( m -- n ) 63 + -64 bitand -6 shift ; inline
: font-units>pixels ( n font -- n )
face-size face-size-y-scale FT_MulFix ;
SYMBOL: grid-dim
-: half-gap grid get gap>> [ 2/ ] map ; inline
+: half-gap ( -- gap ) grid get gap>> [ 2/ ] map ; inline
: grid-line-from/to ( orientation point -- from to )
half-gap v-
HELP: pane-stream
{ $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." } ;
-HELP: <pane-stream> ( pane -- stream )
-{ $values { "pane" pane } { "stream" "a new " { $link pane-stream } } }
+HELP: <pane-stream>
+{ $values { "pane" pane } { "pane-stream" "a new " { $link pane-stream } } }
{ $description "Creates a new " { $link pane-stream } " for writing to " { $snippet "pane" } "." } ;
{ with-pane make-pane } related-words
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors colors.gray qualified accessors ;
+colors colors.gray accessors ;
QUALIFIED: colors
IN: ui.gadgets.theme
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables
math.parser math.vectors classes.tuple classes boxes calendar
-alarms symbols combinators sets columns fry deques ui.gadgets ;
+alarms combinators sets columns fry deques ui.gadgets ;
IN: ui.gestures
GENERIC: handle-gesture ( gesture gadget -- ? )
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions calendar concurrency.flags concurrency.mailboxes
-ui.tools.workspace accessors sets destructors fry ;
+ui.tools.workspace accessors sets destructors fry vocabs.parser ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
USING: continuations definitions ui.tools.browser
ui.tools.interactor ui.tools.listener ui.tools.profiler
ui.tools.search ui.tools.traceback ui.tools.workspace generic
-help.topics stack-checker summary inspector io.files io.styles
-kernel namespaces parser prettyprint quotations
+help.topics stack-checker summary inspector io.pathnames
+io.styles kernel namespaces parser prettyprint quotations
tools.annotations editors tools.profiler tools.test tools.time
tools.walker ui.commands ui.gadgets.editors ui.gestures
ui.operations ui.tools.deploy vocabs vocabs.loader words
-sequences tools.vocabs classes compiler.units accessors ;
+sequences tools.vocabs classes compiler.units accessors
+vocabs.parser ;
IN: ui.tools.operations
V{ } clone operations set-global
-USING: assocs ui.tools.search help.topics io.files io.styles
+USING: assocs ui.tools.search help.topics io.pathnames io.styles
kernel namespaces sequences source-files threads
tools.test ui.gadgets ui.gestures vocabs accessors
vocabs.loader words tools.test.ui debugger calendar ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs help help.topics io.files io.styles
+USING: accessors assocs help help.topics io.pathnames io.styles
kernel models models.delay models.filter namespaces prettyprint
quotations sequences sorting source-files definitions strings
tools.completion tools.apropos tools.crossref classes.tuple
IN: ui.tests
USING: ui tools.test ;
-\ event-loop must-infer
\ open-window must-infer
windows.gdi32 windows.user32 windows.opengl32 windows.messages
windows.types windows.nt windows threads libc combinators fry
combinators.short-circuit continuations command-line shuffle
-opengl ui.render ascii math.bitwise locals symbols accessors
+opengl ui.render ascii math.bitwise locals accessors
math.geometry.rect math.order ascii calendar io.encodings.utf16n
;
IN: ui.windows
{ 27 "ESC" }
} ;
-: exclude-key-wm-keydown? ( n -- bool )
+: exclude-key-wm-keydown? ( n -- ? )
exclude-keys-wm-keydown key? ;
-: exclude-key-wm-char? ( n -- bool )
+: exclude-key-wm-char? ( n -- ? )
exclude-keys-wm-char key? ;
: keystroke>gesture ( n -- mods sym )
ui.event-loop assocs kernel math namespaces opengl sequences
strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
x11.constants x11.windows io.encodings.string io.encodings.ascii
-io.encodings.utf8 combinators command-line qualified
+io.encodings.utf8 combinators command-line
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ascii ;
IN: ui.x11
USING: alien.syntax combinators system vocabs.loader ;
IN: unix
-: MAXPATHLEN 1024 ; inline
-
-: O_RDONLY HEX: 0000 ; inline
-: O_WRONLY HEX: 0001 ; inline
-: O_RDWR HEX: 0002 ; inline
-: O_NONBLOCK HEX: 0004 ; inline
-: O_APPEND HEX: 0008 ; inline
-: O_CREAT HEX: 0200 ; inline
-: O_TRUNC HEX: 0400 ; inline
-: O_EXCL HEX: 0800 ; inline
-: O_NOCTTY HEX: 20000 ; inline
-: O_NDELAY O_NONBLOCK ; inline
-
-: SOL_SOCKET HEX: ffff ; inline
-: SO_REUSEADDR HEX: 4 ; inline
-: SO_OOBINLINE HEX: 100 ; inline
-: SO_SNDTIMEO HEX: 1005 ; inline
-: SO_RCVTIMEO HEX: 1006 ; inline
-
-: F_SETFD 2 ; inline
-: F_SETFL 4 ; inline
-: FD_CLOEXEC 1 ; inline
+CONSTANT: MAXPATHLEN 1024
+
+CONSTANT: O_RDONLY HEX: 0000
+CONSTANT: O_WRONLY HEX: 0001
+CONSTANT: O_RDWR HEX: 0002
+CONSTANT: O_NONBLOCK HEX: 0004
+CONSTANT: O_APPEND HEX: 0008
+CONSTANT: O_CREAT HEX: 0200
+CONSTANT: O_TRUNC HEX: 0400
+CONSTANT: O_EXCL HEX: 0800
+CONSTANT: O_NOCTTY HEX: 20000
+ALIAS: O_NDELAY O_NONBLOCK
+
+CONSTANT: SOL_SOCKET HEX: ffff
+CONSTANT: SO_REUSEADDR HEX: 4
+CONSTANT: SO_OOBINLINE HEX: 100
+CONSTANT: SO_SNDTIMEO HEX: 1005
+CONSTANT: SO_RCVTIMEO HEX: 1006
+
+CONSTANT: F_SETFD 2
+CONSTANT: F_SETFL 4
+CONSTANT: FD_CLOEXEC 1
C-STRUCT: sockaddr-in
{ "uchar" "len" }
{ "time_t" "pw_expire" }
{ "int" "pw_fields" } ;
-: max-un-path 104 ; inline
+CONSTANT: max-un-path 104
-: SOCK_STREAM 1 ; inline
-: SOCK_DGRAM 2 ; inline
+CONSTANT: SOCK_STREAM 1
+CONSTANT: SOCK_DGRAM 2
-: AF_UNSPEC 0 ; inline
-: AF_UNIX 1 ; inline
-: AF_INET 2 ; inline
-: AF_INET6 30 ; inline
+CONSTANT: AF_UNSPEC 0
+CONSTANT: AF_UNIX 1
+CONSTANT: AF_INET 2
+CONSTANT: AF_INET6 30
-: PF_UNSPEC AF_UNSPEC ; inline
-: PF_UNIX AF_UNIX ; inline
-: PF_INET AF_INET ; inline
-: PF_INET6 AF_INET6 ; inline
+ALIAS: PF_UNSPEC AF_UNSPEC
+ALIAS: PF_UNIX AF_UNIX
+ALIAS: PF_INET AF_INET
+ALIAS: PF_INET6 AF_INET6
-: IPPROTO_TCP 6 ; inline
-: IPPROTO_UDP 17 ; inline
+CONSTANT: IPPROTO_TCP 6
+CONSTANT: IPPROTO_UDP 17
-: AI_PASSIVE 1 ; inline
+CONSTANT: AI_PASSIVE 1
-: SEEK_SET 0 ; inline
-: SEEK_CUR 1 ; inline
-: SEEK_END 2 ; inline
+CONSTANT: SEEK_SET 0
+CONSTANT: SEEK_CUR 1
+CONSTANT: SEEK_END 2
os {
{ macosx [ "unix.bsd.macosx" require ] }
{ "u_int8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
-: EPERM 1 ; inline
-: ENOENT 2 ; inline
-: ESRCH 3 ; inline
-: EINTR 4 ; inline
-: EIO 5 ; inline
-: ENXIO 6 ; inline
-: E2BIG 7 ; inline
-: ENOEXEC 8 ; inline
-: EBADF 9 ; inline
-: ECHILD 10 ; inline
-: EDEADLK 11 ; inline
-: ENOMEM 12 ; inline
-: EACCES 13 ; inline
-: EFAULT 14 ; inline
-: ENOTBLK 15 ; inline
-: EBUSY 16 ; inline
-: EEXIST 17 ; inline
-: EXDEV 18 ; inline
-: ENODEV 19 ; inline
-: ENOTDIR 20 ; inline
-: EISDIR 21 ; inline
-: EINVAL 22 ; inline
-: ENFILE 23 ; inline
-: EMFILE 24 ; inline
-: ENOTTY 25 ; inline
-: ETXTBSY 26 ; inline
-: EFBIG 27 ; inline
-: ENOSPC 28 ; inline
-: ESPIPE 29 ; inline
-: EROFS 30 ; inline
-: EMLINK 31 ; inline
-: EPIPE 32 ; inline
-: EDOM 33 ; inline
-: ERANGE 34 ; inline
-: EAGAIN 35 ; inline
-: EWOULDBLOCK EAGAIN ; inline
-: EINPROGRESS 36 ; inline
-: EALREADY 37 ; inline
-: ENOTSOCK 38 ; inline
-: EDESTADDRREQ 39 ; inline
-: EMSGSIZE 40 ; inline
-: EPROTOTYPE 41 ; inline
-: ENOPROTOOPT 42 ; inline
-: EPROTONOSUPPORT 43 ; inline
-: ESOCKTNOSUPPORT 44 ; inline
-: EOPNOTSUPP 45 ; inline
-: ENOTSUP EOPNOTSUPP ; inline
-: EPFNOSUPPORT 46 ; inline
-: EAFNOSUPPORT 47 ; inline
-: EADDRINUSE 48 ; inline
-: EADDRNOTAVAIL 49 ; inline
-: ENETDOWN 50 ; inline
-: ENETUNREACH 51 ; inline
-: ENETRESET 52 ; inline
-: ECONNABORTED 53 ; inline
-: ECONNRESET 54 ; inline
-: ENOBUFS 55 ; inline
-: EISCONN 56 ; inline
-: ENOTCONN 57 ; inline
-: ESHUTDOWN 58 ; inline
-: ETOOMANYREFS 59 ; inline
-: ETIMEDOUT 60 ; inline
-: ECONNREFUSED 61 ; inline
-: ELOOP 62 ; inline
-: ENAMETOOLONG 63 ; inline
-: EHOSTDOWN 64 ; inline
-: EHOSTUNREACH 65 ; inline
-: ENOTEMPTY 66 ; inline
-: EPROCLIM 67 ; inline
-: EUSERS 68 ; inline
-: EDQUOT 69 ; inline
-: ESTALE 70 ; inline
-: EREMOTE 71 ; inline
-: EBADRPC 72 ; inline
-: ERPCMISMATCH 73 ; inline
-: EPROGUNAVAIL 74 ; inline
-: EPROGMISMATCH 75 ; inline
-: EPROCUNAVAIL 76 ; inline
-: ENOLCK 77 ; inline
-: ENOSYS 78 ; inline
-: EFTYPE 79 ; inline
-: EAUTH 80 ; inline
-: ENEEDAUTH 81 ; inline
-: EIDRM 82 ; inline
-: ENOMSG 83 ; inline
-: EOVERFLOW 84 ; inline
-: ECANCELED 85 ; inline
-: EILSEQ 86 ; inline
-: ENOATTR 87 ; inline
-: EDOOFUS 88 ; inline
-: EBADMSG 89 ; inline
-: EMULTIHOP 90 ; inline
-: ENOLINK 91 ; inline
-: EPROTO 92 ; inline
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EDEADLK 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EAGAIN 35
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: EINPROGRESS 36
+CONSTANT: EALREADY 37
+CONSTANT: ENOTSOCK 38
+CONSTANT: EDESTADDRREQ 39
+CONSTANT: EMSGSIZE 40
+CONSTANT: EPROTOTYPE 41
+CONSTANT: ENOPROTOOPT 42
+CONSTANT: EPROTONOSUPPORT 43
+CONSTANT: ESOCKTNOSUPPORT 44
+CONSTANT: EOPNOTSUPP 45
+ALIAS: ENOTSUP EOPNOTSUPP
+CONSTANT: EPFNOSUPPORT 46
+CONSTANT: EAFNOSUPPORT 47
+CONSTANT: EADDRINUSE 48
+CONSTANT: EADDRNOTAVAIL 49
+CONSTANT: ENETDOWN 50
+CONSTANT: ENETUNREACH 51
+CONSTANT: ENETRESET 52
+CONSTANT: ECONNABORTED 53
+CONSTANT: ECONNRESET 54
+CONSTANT: ENOBUFS 55
+CONSTANT: EISCONN 56
+CONSTANT: ENOTCONN 57
+CONSTANT: ESHUTDOWN 58
+CONSTANT: ETOOMANYREFS 59
+CONSTANT: ETIMEDOUT 60
+CONSTANT: ECONNREFUSED 61
+CONSTANT: ELOOP 62
+CONSTANT: ENAMETOOLONG 63
+CONSTANT: EHOSTDOWN 64
+CONSTANT: EHOSTUNREACH 65
+CONSTANT: ENOTEMPTY 66
+CONSTANT: EPROCLIM 67
+CONSTANT: EUSERS 68
+CONSTANT: EDQUOT 69
+CONSTANT: ESTALE 70
+CONSTANT: EREMOTE 71
+CONSTANT: EBADRPC 72
+CONSTANT: ERPCMISMATCH 73
+CONSTANT: EPROGUNAVAIL 74
+CONSTANT: EPROGMISMATCH 75
+CONSTANT: EPROCUNAVAIL 76
+CONSTANT: ENOLCK 77
+CONSTANT: ENOSYS 78
+CONSTANT: EFTYPE 79
+CONSTANT: EAUTH 80
+CONSTANT: ENEEDAUTH 81
+CONSTANT: EIDRM 82
+CONSTANT: ENOMSG 83
+CONSTANT: EOVERFLOW 84
+CONSTANT: ECANCELED 85
+CONSTANT: EILSEQ 86
+CONSTANT: ENOATTR 87
+CONSTANT: EDOOFUS 88
+CONSTANT: EBADMSG 89
+CONSTANT: EMULTIHOP 90
+CONSTANT: ENOLINK 91
+CONSTANT: EPROTO 92
USING: alien.syntax unix.time ;
IN: unix
-: FD_SETSIZE 1024 ; inline
+CONSTANT: FD_SETSIZE 1024
C-STRUCT: addrinfo
{ "int" "flags" }
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
-: _UTX_USERSIZE 256 ; inline
-: _UTX_LINESIZE 32 ; inline
-: _UTX_IDSIZE 4 ; inline
-: _UTX_HOSTSIZE 256 ; inline
+CONSTANT: _UTX_USERSIZE 256
+CONSTANT: _UTX_LINESIZE 32
+CONSTANT: _UTX_IDSIZE 4
+CONSTANT: _UTX_HOSTSIZE 256
C-STRUCT: utmpx
{ { "char" _UTX_USERSIZE } "ut_user" }
{ { "char" _UTX_HOSTSIZE } "ut_host" }
{ { "uint" 16 } "ut_pad" } ;
-: __DARWIN_MAXPATHLEN 1024 ; inline
-: __DARWIN_MAXNAMELEN 255 ; inline
-: __DARWIN_MAXNAMELEN+1 255 ; inline
+CONSTANT: __DARWIN_MAXPATHLEN 1024
+CONSTANT: __DARWIN_MAXNAMELEN 255
+CONSTANT: __DARWIN_MAXNAMELEN+1 255
C-STRUCT: dirent
{ "ino_t" "d_ino" }
{ "__uint8_t" "d_namlen" }
{ { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ;
-: EPERM 1 ; inline
-: ENOENT 2 ; inline
-: ESRCH 3 ; inline
-: EINTR 4 ; inline
-: EIO 5 ; inline
-: ENXIO 6 ; inline
-: E2BIG 7 ; inline
-: ENOEXEC 8 ; inline
-: EBADF 9 ; inline
-: ECHILD 10 ; inline
-: EDEADLK 11 ; inline
-: ENOMEM 12 ; inline
-: EACCES 13 ; inline
-: EFAULT 14 ; inline
-: ENOTBLK 15 ; inline
-: EBUSY 16 ; inline
-: EEXIST 17 ; inline
-: EXDEV 18 ; inline
-: ENODEV 19 ; inline
-: ENOTDIR 20 ; inline
-: EISDIR 21 ; inline
-: EINVAL 22 ; inline
-: ENFILE 23 ; inline
-: EMFILE 24 ; inline
-: ENOTTY 25 ; inline
-: ETXTBSY 26 ; inline
-: EFBIG 27 ; inline
-: ENOSPC 28 ; inline
-: ESPIPE 29 ; inline
-: EROFS 30 ; inline
-: EMLINK 31 ; inline
-: EPIPE 32 ; inline
-: EDOM 33 ; inline
-: ERANGE 34 ; inline
-: EAGAIN 35 ; inline
-: EWOULDBLOCK EAGAIN ; inline
-: EINPROGRESS 36 ; inline
-: EALREADY 37 ; inline
-: ENOTSOCK 38 ; inline
-: EDESTADDRREQ 39 ; inline
-: EMSGSIZE 40 ; inline
-: EPROTOTYPE 41 ; inline
-: ENOPROTOOPT 42 ; inline
-: EPROTONOSUPPORT 43 ; inline
-: ESOCKTNOSUPPORT 44 ; inline
-: ENOTSUP 45 ; inline
-: EPFNOSUPPORT 46 ; inline
-: EAFNOSUPPORT 47 ; inline
-: EADDRINUSE 48 ; inline
-: EADDRNOTAVAIL 49 ; inline
-: ENETDOWN 50 ; inline
-: ENETUNREACH 51 ; inline
-: ENETRESET 52 ; inline
-: ECONNABORTED 53 ; inline
-: ECONNRESET 54 ; inline
-: ENOBUFS 55 ; inline
-: EISCONN 56 ; inline
-: ENOTCONN 57 ; inline
-: ESHUTDOWN 58 ; inline
-: ETOOMANYREFS 59 ; inline
-: ETIMEDOUT 60 ; inline
-: ECONNREFUSED 61 ; inline
-: ELOOP 62 ; inline
-: ENAMETOOLONG 63 ; inline
-: EHOSTDOWN 64 ; inline
-: EHOSTUNREACH 65 ; inline
-: ENOTEMPTY 66 ; inline
-: EPROCLIM 67 ; inline
-: EUSERS 68 ; inline
-: EDQUOT 69 ; inline
-: ESTALE 70 ; inline
-: EREMOTE 71 ; inline
-: EBADRPC 72 ; inline
-: ERPCMISMATCH 73 ; inline
-: EPROGUNAVAIL 74 ; inline
-: EPROGMISMATCH 75 ; inline
-: EPROCUNAVAIL 76 ; inline
-: ENOLCK 77 ; inline
-: ENOSYS 78 ; inline
-: EFTYPE 79 ; inline
-: EAUTH 80 ; inline
-: ENEEDAUTH 81 ; inline
-: EPWROFF 82 ; inline
-: EDEVERR 83 ; inline
-: EOVERFLOW 84 ; inline
-: EBADEXEC 85 ; inline
-: EBADARCH 86 ; inline
-: ESHLIBVERS 87 ; inline
-: EBADMACHO 88 ; inline
-: ECANCELED 89 ; inline
-: EIDRM 90 ; inline
-: ENOMSG 91 ; inline
-: EILSEQ 92 ; inline
-: ENOATTR 93 ; inline
-: EBADMSG 94 ; inline
-: EMULTIHOP 95 ; inline
-: ENODATA 96 ; inline
-: ENOLINK 97 ; inline
-: ENOSR 98 ; inline
-: ENOSTR 99 ; inline
-: EPROTO 100 ; inline
-: ETIME 101 ; inline
-: EOPNOTSUPP 102 ; inline
-: ENOPOLICY 103 ; inline
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EDEADLK 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EAGAIN 35
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: EINPROGRESS 36
+CONSTANT: EALREADY 37
+CONSTANT: ENOTSOCK 38
+CONSTANT: EDESTADDRREQ 39
+CONSTANT: EMSGSIZE 40
+CONSTANT: EPROTOTYPE 41
+CONSTANT: ENOPROTOOPT 42
+CONSTANT: EPROTONOSUPPORT 43
+CONSTANT: ESOCKTNOSUPPORT 44
+CONSTANT: ENOTSUP 45
+CONSTANT: EPFNOSUPPORT 46
+CONSTANT: EAFNOSUPPORT 47
+CONSTANT: EADDRINUSE 48
+CONSTANT: EADDRNOTAVAIL 49
+CONSTANT: ENETDOWN 50
+CONSTANT: ENETUNREACH 51
+CONSTANT: ENETRESET 52
+CONSTANT: ECONNABORTED 53
+CONSTANT: ECONNRESET 54
+CONSTANT: ENOBUFS 55
+CONSTANT: EISCONN 56
+CONSTANT: ENOTCONN 57
+CONSTANT: ESHUTDOWN 58
+CONSTANT: ETOOMANYREFS 59
+CONSTANT: ETIMEDOUT 60
+CONSTANT: ECONNREFUSED 61
+CONSTANT: ELOOP 62
+CONSTANT: ENAMETOOLONG 63
+CONSTANT: EHOSTDOWN 64
+CONSTANT: EHOSTUNREACH 65
+CONSTANT: ENOTEMPTY 66
+CONSTANT: EPROCLIM 67
+CONSTANT: EUSERS 68
+CONSTANT: EDQUOT 69
+CONSTANT: ESTALE 70
+CONSTANT: EREMOTE 71
+CONSTANT: EBADRPC 72
+CONSTANT: ERPCMISMATCH 73
+CONSTANT: EPROGUNAVAIL 74
+CONSTANT: EPROGMISMATCH 75
+CONSTANT: EPROCUNAVAIL 76
+CONSTANT: ENOLCK 77
+CONSTANT: ENOSYS 78
+CONSTANT: EFTYPE 79
+CONSTANT: EAUTH 80
+CONSTANT: ENEEDAUTH 81
+CONSTANT: EPWROFF 82
+CONSTANT: EDEVERR 83
+CONSTANT: EOVERFLOW 84
+CONSTANT: EBADEXEC 85
+CONSTANT: EBADARCH 86
+CONSTANT: ESHLIBVERS 87
+CONSTANT: EBADMACHO 88
+CONSTANT: ECANCELED 89
+CONSTANT: EIDRM 90
+CONSTANT: ENOMSG 91
+CONSTANT: EILSEQ 92
+CONSTANT: ENOATTR 93
+CONSTANT: EBADMSG 94
+CONSTANT: EMULTIHOP 95
+CONSTANT: ENODATA 96
+CONSTANT: ENOLINK 97
+CONSTANT: ENOSR 98
+CONSTANT: ENOSTR 99
+CONSTANT: EPROTO 100
+CONSTANT: ETIME 101
+CONSTANT: EOPNOTSUPP 102
+CONSTANT: ENOPOLICY 103
USING: alien.syntax alien.c-types math vocabs.loader ;
IN: unix
-: FD_SETSIZE 256 ; inline
+CONSTANT: FD_SETSIZE 256
C-STRUCT: addrinfo
{ "int" "flags" }
{ "__uint8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
-: EPERM 1 ; inline
-: ENOENT 2 ; inline
-: ESRCH 3 ; inline
-: EINTR 4 ; inline
-: EIO 5 ; inline
-: ENXIO 6 ; inline
-: E2BIG 7 ; inline
-: ENOEXEC 8 ; inline
-: EBADF 9 ; inline
-: ECHILD 10 ; inline
-: EDEADLK 11 ; inline
-: ENOMEM 12 ; inline
-: EACCES 13 ; inline
-: EFAULT 14 ; inline
-: ENOTBLK 15 ; inline
-: EBUSY 16 ; inline
-: EEXIST 17 ; inline
-: EXDEV 18 ; inline
-: ENODEV 19 ; inline
-: ENOTDIR 20 ; inline
-: EISDIR 21 ; inline
-: EINVAL 22 ; inline
-: ENFILE 23 ; inline
-: EMFILE 24 ; inline
-: ENOTTY 25 ; inline
-: ETXTBSY 26 ; inline
-: EFBIG 27 ; inline
-: ENOSPC 28 ; inline
-: ESPIPE 29 ; inline
-: EROFS 30 ; inline
-: EMLINK 31 ; inline
-: EPIPE 32 ; inline
-: EDOM 33 ; inline
-: ERANGE 34 ; inline
-: EAGAIN 35 ; inline
-: EWOULDBLOCK EAGAIN ; inline
-: EINPROGRESS 36 ; inline
-: EALREADY 37 ; inline
-: ENOTSOCK 38 ; inline
-: EDESTADDRREQ 39 ; inline
-: EMSGSIZE 40 ; inline
-: EPROTOTYPE 41 ; inline
-: ENOPROTOOPT 42 ; inline
-: EPROTONOSUPPORT 43 ; inline
-: ESOCKTNOSUPPORT 44 ; inline
-: EOPNOTSUPP 45 ; inline
-: EPFNOSUPPORT 46 ; inline
-: EAFNOSUPPORT 47 ; inline
-: EADDRINUSE 48 ; inline
-: EADDRNOTAVAIL 49 ; inline
-: ENETDOWN 50 ; inline
-: ENETUNREACH 51 ; inline
-: ENETRESET 52 ; inline
-: ECONNABORTED 53 ; inline
-: ECONNRESET 54 ; inline
-: ENOBUFS 55 ; inline
-: EISCONN 56 ; inline
-: ENOTCONN 57 ; inline
-: ESHUTDOWN 58 ; inline
-: ETOOMANYREFS 59 ; inline
-: ETIMEDOUT 60 ; inline
-: ECONNREFUSED 61 ; inline
-: ELOOP 62 ; inline
-: ENAMETOOLONG 63 ; inline
-: EHOSTDOWN 64 ; inline
-: EHOSTUNREACH 65 ; inline
-: ENOTEMPTY 66 ; inline
-: EPROCLIM 67 ; inline
-: EUSERS 68 ; inline
-: EDQUOT 69 ; inline
-: ESTALE 70 ; inline
-: EREMOTE 71 ; inline
-: EBADRPC 72 ; inline
-: ERPCMISMATCH 73 ; inline
-: EPROGUNAVAIL 74 ; inline
-: EPROGMISMATCH 75 ; inline
-: EPROCUNAVAIL 76 ; inline
-: ENOLCK 77 ; inline
-: ENOSYS 78 ; inline
-: EFTYPE 79 ; inline
-: EAUTH 80 ; inline
-: ENEEDAUTH 81 ; inline
-: EIDRM 82 ; inline
-: ENOMSG 83 ; inline
-: EOVERFLOW 84 ; inline
-: EILSEQ 85 ; inline
-: ENOTSUP 86 ; inline
-: ECANCELED 87 ; inline
-: EBADMSG 88 ; inline
-: ENODATA 89 ; inline
-: ENOSR 90 ; inline
-: ENOSTR 91 ; inline
-: ETIME 92 ; inline
-: ENOATTR 93 ; inline
-: EMULTIHOP 94 ; inline
-: ENOLINK 95 ; inline
-: EPROTO 96 ; inline
-: ELAST 96 ; inline
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EDEADLK 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EAGAIN 35
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: EINPROGRESS 36
+CONSTANT: EALREADY 37
+CONSTANT: ENOTSOCK 38
+CONSTANT: EDESTADDRREQ 39
+CONSTANT: EMSGSIZE 40
+CONSTANT: EPROTOTYPE 41
+CONSTANT: ENOPROTOOPT 42
+CONSTANT: EPROTONOSUPPORT 43
+CONSTANT: ESOCKTNOSUPPORT 44
+CONSTANT: EOPNOTSUPP 45
+CONSTANT: EPFNOSUPPORT 46
+CONSTANT: EAFNOSUPPORT 47
+CONSTANT: EADDRINUSE 48
+CONSTANT: EADDRNOTAVAIL 49
+CONSTANT: ENETDOWN 50
+CONSTANT: ENETUNREACH 51
+CONSTANT: ENETRESET 52
+CONSTANT: ECONNABORTED 53
+CONSTANT: ECONNRESET 54
+CONSTANT: ENOBUFS 55
+CONSTANT: EISCONN 56
+CONSTANT: ENOTCONN 57
+CONSTANT: ESHUTDOWN 58
+CONSTANT: ETOOMANYREFS 59
+CONSTANT: ETIMEDOUT 60
+CONSTANT: ECONNREFUSED 61
+CONSTANT: ELOOP 62
+CONSTANT: ENAMETOOLONG 63
+CONSTANT: EHOSTDOWN 64
+CONSTANT: EHOSTUNREACH 65
+CONSTANT: ENOTEMPTY 66
+CONSTANT: EPROCLIM 67
+CONSTANT: EUSERS 68
+CONSTANT: EDQUOT 69
+CONSTANT: ESTALE 70
+CONSTANT: EREMOTE 71
+CONSTANT: EBADRPC 72
+CONSTANT: ERPCMISMATCH 73
+CONSTANT: EPROGUNAVAIL 74
+CONSTANT: EPROGMISMATCH 75
+CONSTANT: EPROCUNAVAIL 76
+CONSTANT: ENOLCK 77
+CONSTANT: ENOSYS 78
+CONSTANT: EFTYPE 79
+CONSTANT: EAUTH 80
+CONSTANT: ENEEDAUTH 81
+CONSTANT: EIDRM 82
+CONSTANT: ENOMSG 83
+CONSTANT: EOVERFLOW 84
+CONSTANT: EILSEQ 85
+CONSTANT: ENOTSUP 86
+CONSTANT: ECANCELED 87
+CONSTANT: EBADMSG 88
+CONSTANT: ENODATA 89
+CONSTANT: ENOSR 90
+CONSTANT: ENOSTR 91
+CONSTANT: ETIME 92
+CONSTANT: ENOATTR 93
+CONSTANT: EMULTIHOP 94
+CONSTANT: ENOLINK 95
+CONSTANT: EPROTO 96
+CONSTANT: ELAST 96
TYPEDEF: __uint8_t sa_family_t
-: _UTX_USERSIZE 32 ; inline
-: _UTX_LINESIZE 32 ; inline
-: _UTX_IDSIZE 4 ; inline
-: _UTX_HOSTSIZE 256 ; inline
+CONSTANT: _UTX_USERSIZE 32
+CONSTANT: _UTX_LINESIZE 32
+CONSTANT: _UTX_IDSIZE 4
+CONSTANT: _UTX_HOSTSIZE 256
: _SS_MAXSIZE ( -- n )
128 ; inline
USING: alien.syntax ;
IN: unix
-: FD_SETSIZE 1024 ; inline
+CONSTANT: FD_SETSIZE 1024
C-STRUCT: addrinfo
{ "int" "flags" }
{ "__uint8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
-: EPERM 1 ; inline
-: ENOENT 2 ; inline
-: ESRCH 3 ; inline
-: EINTR 4 ; inline
-: EIO 5 ; inline
-: ENXIO 6 ; inline
-: E2BIG 7 ; inline
-: ENOEXEC 8 ; inline
-: EBADF 9 ; inline
-: ECHILD 10 ; inline
-: EDEADLK 11 ; inline
-: ENOMEM 12 ; inline
-: EACCES 13 ; inline
-: EFAULT 14 ; inline
-: ENOTBLK 15 ; inline
-: EBUSY 16 ; inline
-: EEXIST 17 ; inline
-: EXDEV 18 ; inline
-: ENODEV 19 ; inline
-: ENOTDIR 20 ; inline
-: EISDIR 21 ; inline
-: EINVAL 22 ; inline
-: ENFILE 23 ; inline
-: EMFILE 24 ; inline
-: ENOTTY 25 ; inline
-: ETXTBSY 26 ; inline
-: EFBIG 27 ; inline
-: ENOSPC 28 ; inline
-: ESPIPE 29 ; inline
-: EROFS 30 ; inline
-: EMLINK 31 ; inline
-: EPIPE 32 ; inline
-: EDOM 33 ; inline
-: ERANGE 34 ; inline
-: EAGAIN 35 ; inline
-: EWOULDBLOCK EAGAIN ; inline
-: EINPROGRESS 36 ; inline
-: EALREADY 37 ; inline
-: ENOTSOCK 38 ; inline
-: EDESTADDRREQ 39 ; inline
-: EMSGSIZE 40 ; inline
-: EPROTOTYPE 41 ; inline
-: ENOPROTOOPT 42 ; inline
-: EPROTONOSUPPORT 43 ; inline
-: ESOCKTNOSUPPORT 44 ; inline
-: EOPNOTSUPP 45 ; inline
-: EPFNOSUPPORT 46 ; inline
-: EAFNOSUPPORT 47 ; inline
-: EADDRINUSE 48 ; inline
-: EADDRNOTAVAIL 49 ; inline
-: ENETDOWN 50 ; inline
-: ENETUNREACH 51 ; inline
-: ENETRESET 52 ; inline
-: ECONNABORTED 53 ; inline
-: ECONNRESET 54 ; inline
-: ENOBUFS 55 ; inline
-: EISCONN 56 ; inline
-: ENOTCONN 57 ; inline
-: ESHUTDOWN 58 ; inline
-: ETOOMANYREFS 59 ; inline
-: ETIMEDOUT 60 ; inline
-: ECONNREFUSED 61 ; inline
-: ELOOP 62 ; inline
-: ENAMETOOLONG 63 ; inline
-: EHOSTDOWN 64 ; inline
-: EHOSTUNREACH 65 ; inline
-: ENOTEMPTY 66 ; inline
-: EPROCLIM 67 ; inline
-: EUSERS 68 ; inline
-: EDQUOT 69 ; inline
-: ESTALE 70 ; inline
-: EREMOTE 71 ; inline
-: EBADRPC 72 ; inline
-: ERPCMISMATCH 73 ; inline
-: EPROGUNAVAIL 74 ; inline
-: EPROGMISMATCH 75 ; inline
-: EPROCUNAVAIL 76 ; inline
-: ENOLCK 77 ; inline
-: ENOSYS 78 ; inline
-: EFTYPE 79 ; inline
-: EAUTH 80 ; inline
-: ENEEDAUTH 81 ; inline
-: EIPSEC 82 ; inline
-: ENOATTR 83 ; inline
-: EILSEQ 84 ; inline
-: ENOMEDIUM 85 ; inline
-: EMEDIUMTYPE 86 ; inline
-: EOVERFLOW 87 ; inline
-: ECANCELED 88 ; inline
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EDEADLK 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EAGAIN 35
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: EINPROGRESS 36
+CONSTANT: EALREADY 37
+CONSTANT: ENOTSOCK 38
+CONSTANT: EDESTADDRREQ 39
+CONSTANT: EMSGSIZE 40
+CONSTANT: EPROTOTYPE 41
+CONSTANT: ENOPROTOOPT 42
+CONSTANT: EPROTONOSUPPORT 43
+CONSTANT: ESOCKTNOSUPPORT 44
+CONSTANT: EOPNOTSUPP 45
+CONSTANT: EPFNOSUPPORT 46
+CONSTANT: EAFNOSUPPORT 47
+CONSTANT: EADDRINUSE 48
+CONSTANT: EADDRNOTAVAIL 49
+CONSTANT: ENETDOWN 50
+CONSTANT: ENETUNREACH 51
+CONSTANT: ENETRESET 52
+CONSTANT: ECONNABORTED 53
+CONSTANT: ECONNRESET 54
+CONSTANT: ENOBUFS 55
+CONSTANT: EISCONN 56
+CONSTANT: ENOTCONN 57
+CONSTANT: ESHUTDOWN 58
+CONSTANT: ETOOMANYREFS 59
+CONSTANT: ETIMEDOUT 60
+CONSTANT: ECONNREFUSED 61
+CONSTANT: ELOOP 62
+CONSTANT: ENAMETOOLONG 63
+CONSTANT: EHOSTDOWN 64
+CONSTANT: EHOSTUNREACH 65
+CONSTANT: ENOTEMPTY 66
+CONSTANT: EPROCLIM 67
+CONSTANT: EUSERS 68
+CONSTANT: EDQUOT 69
+CONSTANT: ESTALE 70
+CONSTANT: EREMOTE 71
+CONSTANT: EBADRPC 72
+CONSTANT: ERPCMISMATCH 73
+CONSTANT: EPROGUNAVAIL 74
+CONSTANT: EPROGMISMATCH 75
+CONSTANT: EPROCUNAVAIL 76
+CONSTANT: ENOLCK 77
+CONSTANT: ENOSYS 78
+CONSTANT: EFTYPE 79
+CONSTANT: EAUTH 80
+CONSTANT: ENEEDAUTH 81
+CONSTANT: EIPSEC 82
+CONSTANT: ENOATTR 83
+CONSTANT: EILSEQ 84
+CONSTANT: ENOMEDIUM 85
+CONSTANT: EMEDIUMTYPE 86
+CONSTANT: EOVERFLOW 87
+CONSTANT: ECANCELED 88
USING: alien.syntax ;
IN: unix.getfsstat.freebsd
-: MNT_WAIT 1 ; inline ! synchronously wait for I/O to complete
-: MNT_NOWAIT 2 ; inline ! start all I/O, but do not wait for it
-: MNT_LAZY 3 ; inline ! push data not written by filesystem syncer
-: MNT_SUSPEND 4 ; inline ! Suspend file system after sync
+CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
+CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it
+CONSTANT: MNT_LAZY 3 ! push data not written by filesystem syncer
+CONSTANT: MNT_SUSPEND 4 ! Suspend file system after sync
FUNCTION: int getfsstat ( statfs* buf, int bufsize, int flags ) ;
USING: alien.syntax ;
IN: unix.getfsstat.macosx
-: MNT_WAIT 1 ; inline ! synchronously wait for I/O to complete
-: MNT_NOWAIT 2 ; inline ! start all I/O, but do not wait for it
+CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
+CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it
FUNCTION: int getfsstat64 ( statfs* buf, int bufsize, int flags ) ;
USING: alien.syntax ;
IN: unix.getfsstat.netbsd
-: MNT_WAIT 1 ; inline ! synchronously wait for I/O to complete
-: MNT_NOWAIT 2 ; inline ! start all I/O, but do not wait for it
-: MNT_LAZY 3 ; inline ! push data not written by filesystem syncer
+CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
+CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it
+CONSTANT: MNT_LAZY 3 ! push data not written by filesystem syncer
FUNCTION: int getvfsstat ( statfs* buf, int bufsize, int flags ) ;
USING: alien.syntax ;
IN: unix.getfsstat.openbsd
-: MNT_WAIT 1 ; ! synchronously wait for I/O to complete
-: MNT_NOWAIT 2 ; ! start all I/O, but do not wait for it
-: MNT_LAZY 3 ; ! push data not written by filesystem syncer
+CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete
+CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it
+CONSTANT: MNT_LAZY 3 ! push data not written by filesystem syncer
FUNCTION: int getfsstat ( statfs* buf, int bufsize, int flags ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings io.encodings.utf8
-io.unix.backend kernel math sequences splitting unix strings
-combinators.short-circuit byte-arrays combinators qualified
+io.backend.unix kernel math sequences splitting unix strings
+combinators.short-circuit byte-arrays combinators
accessors math.parser fry assocs namespaces continuations
unix.users unix.utilities ;
IN: unix.groups
-USE: alien.syntax
+USING: alien.syntax ;
IN: unix.kqueue
C-STRUCT: kevent
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
-: EVFILT_READ -1 ; inline
-: EVFILT_WRITE -2 ; inline
-: EVFILT_AIO -3 ; inline ! attached to aio requests
-: EVFILT_VNODE -4 ; inline ! attached to vnodes
-: EVFILT_PROC -5 ; inline ! attached to struct proc
-: EVFILT_SIGNAL -6 ; inline ! attached to struct proc
-: EVFILT_TIMER -7 ; inline ! timers
-: EVFILT_NETDEV -8 ; inline ! Mach ports
-: EVFILT_FS -9 ; inline ! Filesystem events
+CONSTANT: EVFILT_READ -1
+CONSTANT: EVFILT_WRITE -2
+CONSTANT: EVFILT_AIO -3 ! attached to aio requests
+CONSTANT: EVFILT_VNODE -4 ! attached to vnodes
+CONSTANT: EVFILT_PROC -5 ! attached to struct proc
+CONSTANT: EVFILT_SIGNAL -6 ! attached to struct proc
+CONSTANT: EVFILT_TIMER -7 ! timers
+CONSTANT: EVFILT_NETDEV -8 ! Mach ports
+CONSTANT: EVFILT_FS -9 ! Filesystem events
FUNCTION: int kqueue ( ) ;
! actions
-: EV_ADD HEX: 1 ; inline ! add event to kq (implies enable)
-: EV_DELETE HEX: 2 ; inline ! delete event from kq
-: EV_ENABLE HEX: 4 ; inline ! enable event
-: EV_DISABLE HEX: 8 ; inline ! disable event (not reported)
+CONSTANT: EV_ADD HEX: 1 ! add event to kq (implies enable)
+CONSTANT: EV_DELETE HEX: 2 ! delete event from kq
+CONSTANT: EV_ENABLE HEX: 4 ! enable event
+CONSTANT: EV_DISABLE HEX: 8 ! disable event (not reported)
! flags
-: EV_ONESHOT HEX: 10 ; inline ! only report one occurrence
-: EV_CLEAR HEX: 20 ; inline ! clear event state after reporting
+CONSTANT: EV_ONESHOT HEX: 10 ! only report one occurrence
+CONSTANT: EV_CLEAR HEX: 20 ! clear event state after reporting
-: EV_SYSFLAGS HEX: f000 ; inline ! reserved by system
-: EV_FLAG0 HEX: 1000 ; inline ! filter-specific flag
-: EV_FLAG1 HEX: 2000 ; inline ! filter-specific flag
+CONSTANT: EV_SYSFLAGS HEX: f000 ! reserved by system
+CONSTANT: EV_FLAG0 HEX: 1000 ! filter-specific flag
+CONSTANT: EV_FLAG1 HEX: 2000 ! filter-specific flag
! returned values
-: EV_EOF HEX: 8000 ; inline ! EOF detected
-: EV_ERROR HEX: 4000 ; inline ! error, data contains errno
-
-: EV_POLL EV_FLAG0 ; inline
-: EV_OOBAND EV_FLAG1 ; inline
-
-: NOTE_LOWAT HEX: 00000001 ; inline ! low water mark
-
-: NOTE_DELETE HEX: 00000001 ; inline ! vnode was removed
-: NOTE_WRITE HEX: 00000002 ; inline ! data contents changed
-: NOTE_EXTEND HEX: 00000004 ; inline ! size increased
-: NOTE_ATTRIB HEX: 00000008 ; inline ! attributes changed
-: NOTE_LINK HEX: 00000010 ; inline ! link count changed
-: NOTE_RENAME HEX: 00000020 ; inline ! vnode was renamed
-: NOTE_REVOKE HEX: 00000040 ; inline ! vnode access was revoked
-
-: NOTE_EXIT HEX: 80000000 ; inline ! process exited
-: NOTE_FORK HEX: 40000000 ; inline ! process forked
-: NOTE_EXEC HEX: 20000000 ; inline ! process exec'd
-: NOTE_PCTRLMASK HEX: f0000000 ; inline ! mask for hint bits
-: NOTE_PDATAMASK HEX: 000fffff ; inline ! mask for pid
-
-: NOTE_SECONDS HEX: 00000001 ; inline ! data is seconds
-: NOTE_USECONDS HEX: 00000002 ; inline ! data is microseconds
-: NOTE_NSECONDS HEX: 00000004 ; inline ! data is nanoseconds
-: NOTE_ABSOLUTE HEX: 00000008 ; inline ! absolute timeout
-
-: NOTE_TRACK HEX: 00000001 ; inline ! follow across forks
-: NOTE_TRACKERR HEX: 00000002 ; inline ! could not track child
-: NOTE_CHILD HEX: 00000004 ; inline ! am a child process
+CONSTANT: EV_EOF HEX: 8000 ! EOF detected
+CONSTANT: EV_ERROR HEX: 4000 ! error, data contains errno
+
+ALIAS: EV_POLL EV_FLAG0
+ALIAS: EV_OOBAND EV_FLAG1
+
+CONSTANT: NOTE_LOWAT HEX: 00000001 ! low water mark
+
+CONSTANT: NOTE_DELETE HEX: 00000001 ! vnode was removed
+CONSTANT: NOTE_WRITE HEX: 00000002 ! data contents changed
+CONSTANT: NOTE_EXTEND HEX: 00000004 ! size increased
+CONSTANT: NOTE_ATTRIB HEX: 00000008 ! attributes changed
+CONSTANT: NOTE_LINK HEX: 00000010 ! link count changed
+CONSTANT: NOTE_RENAME HEX: 00000020 ! vnode was renamed
+CONSTANT: NOTE_REVOKE HEX: 00000040 ! vnode access was revoked
+
+CONSTANT: NOTE_EXIT HEX: 80000000 ! process exited
+CONSTANT: NOTE_FORK HEX: 40000000 ! process forked
+CONSTANT: NOTE_EXEC HEX: 20000000 ! process exec'd
+CONSTANT: NOTE_PCTRLMASK HEX: f0000000 ! mask for hint bits
+CONSTANT: NOTE_PDATAMASK HEX: 000fffff ! mask for pid
+
+CONSTANT: NOTE_SECONDS HEX: 00000001 ! data is seconds
+CONSTANT: NOTE_USECONDS HEX: 00000002 ! data is microseconds
+CONSTANT: NOTE_NSECONDS HEX: 00000004 ! data is nanoseconds
+CONSTANT: NOTE_ABSOLUTE HEX: 00000008 ! absolute timeout
+
+CONSTANT: NOTE_TRACK HEX: 00000001 ! follow across forks
+CONSTANT: NOTE_TRACKERR HEX: 00000002 ! could not track child
+CONSTANT: NOTE_CHILD HEX: 00000004 ! am a child process
-USE: alien.syntax
+USING: alien.syntax ;
IN: unix.kqueue
C-STRUCT: kevent
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
-: EVFILT_READ -1 ; inline
-: EVFILT_WRITE -2 ; inline
-: EVFILT_AIO -3 ; inline ! attached to aio requests
-: EVFILT_VNODE -4 ; inline ! attached to vnodes
-: EVFILT_PROC -5 ; inline ! attached to struct proc
-: EVFILT_SIGNAL -6 ; inline ! attached to struct proc
-: EVFILT_TIMER -7 ; inline ! timers
-: EVFILT_MACHPORT -8 ; inline ! Mach ports
-: EVFILT_FS -9 ; inline ! Filesystem events
+CONSTANT: EVFILT_READ -1
+CONSTANT: EVFILT_WRITE -2
+CONSTANT: EVFILT_AIO -3 ! attached to aio requests
+CONSTANT: EVFILT_VNODE -4 ! attached to vnodes
+CONSTANT: EVFILT_PROC -5 ! attached to struct proc
+CONSTANT: EVFILT_SIGNAL -6 ! attached to struct proc
+CONSTANT: EVFILT_TIMER -7 ! timers
+CONSTANT: EVFILT_MACHPORT -8 ! Mach ports
+CONSTANT: EVFILT_FS -9 ! Filesystem events
-USE: alien.syntax
+USING: alien.syntax ;
IN: unix.kqueue
C-STRUCT: kevent
FUNCTION: int kevent ( int kq, kevent* changelist, size_t nchanges, kevent* eventlist, size_t nevents, timespec* timeout ) ;
-: EVFILT_READ 0 ; inline
-: EVFILT_WRITE 1 ; inline
-: EVFILT_AIO 2 ; inline ! attached to aio requests
-: EVFILT_VNODE 3 ; inline ! attached to vnodes
-: EVFILT_PROC 4 ; inline ! attached to struct proc
-: EVFILT_SIGNAL 5 ; inline ! attached to struct proc
-: EVFILT_TIMER 6 ; inline ! timers
-: EVFILT_SYSCOUNT 7 ; inline ! Filesystem events
+CONSTANT: EVFILT_READ 0
+CONSTANT: EVFILT_WRITE 1
+CONSTANT: EVFILT_AIO 2 ! attached to aio requests
+CONSTANT: EVFILT_VNODE 3 ! attached to vnodes
+CONSTANT: EVFILT_PROC 4 ! attached to struct proc
+CONSTANT: EVFILT_SIGNAL 5 ! attached to struct proc
+CONSTANT: EVFILT_TIMER 6 ! timers
+CONSTANT: EVFILT_SYSCOUNT 7 ! Filesystem events
-USE: alien.syntax
+USING: alien.syntax ;
IN: unix.kqueue
C-STRUCT: kevent
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
-: EVFILT_READ -1 ; inline
-: EVFILT_WRITE -2 ; inline
-: EVFILT_AIO -3 ; inline ! attached to aio requests
-: EVFILT_VNODE -4 ; inline ! attached to vnodes
-: EVFILT_PROC -5 ; inline ! attached to struct proc
-: EVFILT_SIGNAL -6 ; inline ! attached to struct proc
-: EVFILT_TIMER -7 ; inline ! timers
+CONSTANT: EVFILT_READ -1
+CONSTANT: EVFILT_WRITE -2
+CONSTANT: EVFILT_AIO -3 ! attached to aio requests
+CONSTANT: EVFILT_VNODE -4 ! attached to vnodes
+CONSTANT: EVFILT_PROC -5 ! attached to struct proc
+CONSTANT: EVFILT_SIGNAL -6 ! attached to struct proc
+CONSTANT: EVFILT_TIMER -7 ! timers
FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;
-: EPOLL_CTL_ADD 1 ; inline ! Add a file decriptor to the interface.
-: EPOLL_CTL_DEL 2 ; inline ! Remove a file decriptor from the interface.
-: EPOLL_CTL_MOD 3 ; inline ! Change file decriptor epoll_event structure.
+CONSTANT: EPOLL_CTL_ADD 1 ! Add a file decriptor to the interface.
+CONSTANT: EPOLL_CTL_DEL 2 ! Remove a file decriptor from the interface.
+CONSTANT: EPOLL_CTL_MOD 3 ! Change file decriptor epoll_event structure.
-: EPOLLIN HEX: 001 ; inline
-: EPOLLPRI HEX: 002 ; inline
-: EPOLLOUT HEX: 004 ; inline
-: EPOLLRDNORM HEX: 040 ; inline
-: EPOLLRDBAND HEX: 080 ; inline
-: EPOLLWRNORM HEX: 100 ; inline
-: EPOLLWRBAND HEX: 200 ; inline
-: EPOLLMSG HEX: 400 ; inline
-: EPOLLERR HEX: 008 ; inline
-: EPOLLHUP HEX: 010 ; inline
-: EPOLLONESHOT 30 2^ ; inline
-: EPOLLET 31 2^ ; inline
+CONSTANT: EPOLLIN HEX: 001
+CONSTANT: EPOLLPRI HEX: 002
+CONSTANT: EPOLLOUT HEX: 004
+CONSTANT: EPOLLRDNORM HEX: 040
+CONSTANT: EPOLLRDBAND HEX: 080
+CONSTANT: EPOLLWRNORM HEX: 100
+CONSTANT: EPOLLWRBAND HEX: 200
+CONSTANT: EPOLLMSG HEX: 400
+CONSTANT: EPOLLERR HEX: 008
+CONSTANT: EPOLLHUP HEX: 010
+: EPOLLONESHOT ( -- n ) 30 2^ ; inline
+: EPOLLET ( -- n ) 31 2^ ; inline
{ "char[0]" "name" } ! stub for possible name\r
;\r
\r
-: IN_ACCESS HEX: 1 ; inline ! File was accessed\r
-: IN_MODIFY HEX: 2 ; inline ! File was modified\r
-: IN_ATTRIB HEX: 4 ; inline ! Metadata changed\r
-: IN_CLOSE_WRITE HEX: 8 ; inline ! Writtable file was closed\r
-: IN_CLOSE_NOWRITE HEX: 10 ; inline ! Unwrittable file closed\r
-: IN_OPEN HEX: 20 ; inline ! File was opened\r
-: IN_MOVED_FROM HEX: 40 ; inline ! File was moved from X\r
-: IN_MOVED_TO HEX: 80 ; inline ! File was moved to Y\r
-: IN_CREATE HEX: 100 ; inline ! Subfile was created\r
-: IN_DELETE HEX: 200 ; inline ! Subfile was deleted\r
-: IN_DELETE_SELF HEX: 400 ; inline ! Self was deleted\r
-: IN_MOVE_SELF HEX: 800 ; inline ! Self was moved\r
-\r
-: IN_UNMOUNT HEX: 2000 ; inline ! Backing fs was unmounted\r
-: IN_Q_OVERFLOW HEX: 4000 ; inline ! Event queued overflowed\r
-: IN_IGNORED HEX: 8000 ; inline ! File was ignored\r
+CONSTANT: IN_ACCESS HEX: 1 ! File was accessed\r
+CONSTANT: IN_MODIFY HEX: 2 ! File was modified\r
+CONSTANT: IN_ATTRIB HEX: 4 ! Metadata changed\r
+CONSTANT: IN_CLOSE_WRITE HEX: 8 ! Writtable file was closed\r
+CONSTANT: IN_CLOSE_NOWRITE HEX: 10 ! Unwrittable file closed\r
+CONSTANT: IN_OPEN HEX: 20 ! File was opened\r
+CONSTANT: IN_MOVED_FROM HEX: 40 ! File was moved from X\r
+CONSTANT: IN_MOVED_TO HEX: 80 ! File was moved to Y\r
+CONSTANT: IN_CREATE HEX: 100 ! Subfile was created\r
+CONSTANT: IN_DELETE HEX: 200 ! Subfile was deleted\r
+CONSTANT: IN_DELETE_SELF HEX: 400 ! Self was deleted\r
+CONSTANT: IN_MOVE_SELF HEX: 800 ! Self was moved\r
+\r
+CONSTANT: IN_UNMOUNT HEX: 2000 ! Backing fs was unmounted\r
+CONSTANT: IN_Q_OVERFLOW HEX: 4000 ! Event queued overflowed\r
+CONSTANT: IN_IGNORED HEX: 8000 ! File was ignored\r
\r
: IN_CLOSE ( -- n ) IN_CLOSE_WRITE IN_CLOSE_NOWRITE bitor ; inline ! close\r
-: IN_MOVE ( -- n ) IN_MOVED_FROM IN_MOVED_TO bitor ; inline ! moves\r
+: IN_MOVE ( -- n ) IN_MOVED_FROM IN_MOVED_TO bitor ; inline ! moves\r
\r
-: IN_ONLYDIR HEX: 1000000 ; inline ! only watch the path if it is a directory\r
-: IN_DONT_FOLLOW HEX: 2000000 ; inline ! don't follow a sym link\r
-: IN_MASK_ADD HEX: 20000000 ; inline ! add to the mask of an already existing watch\r
-: IN_ISDIR HEX: 40000000 ; inline ! event occurred against dir\r
-: IN_ONESHOT HEX: 80000000 ; inline ! only send event once\r
+CONSTANT: IN_ONLYDIR HEX: 1000000 ! only watch the path if it is a directory\r
+CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link\r
+CONSTANT: IN_MASK_ADD HEX: 20000000 ! add to the mask of an already existing watch\r
+CONSTANT: IN_ISDIR HEX: 40000000 ! event occurred against dir\r
+CONSTANT: IN_ONESHOT HEX: 80000000 ! only send event once\r
\r
: IN_CHANGE_EVENTS ( -- n )\r
{\r
! Linux.
-: MAXPATHLEN 1024 ; inline
+CONSTANT: MAXPATHLEN 1024
-: O_RDONLY HEX: 0000 ; inline
-: O_WRONLY HEX: 0001 ; inline
-: O_RDWR HEX: 0002 ; inline
-: O_CREAT HEX: 0040 ; inline
-: O_EXCL HEX: 0080 ; inline
-: O_NOCTTY HEX: 0100 ; inline
-: O_TRUNC HEX: 0200 ; inline
-: O_APPEND HEX: 0400 ; inline
-: O_NONBLOCK HEX: 0800 ; inline
-: O_NDELAY O_NONBLOCK ; inline
+CONSTANT: O_RDONLY HEX: 0000
+CONSTANT: O_WRONLY HEX: 0001
+CONSTANT: O_RDWR HEX: 0002
+CONSTANT: O_CREAT HEX: 0040
+CONSTANT: O_EXCL HEX: 0080
+CONSTANT: O_NOCTTY HEX: 0100
+CONSTANT: O_TRUNC HEX: 0200
+CONSTANT: O_APPEND HEX: 0400
+CONSTANT: O_NONBLOCK HEX: 0800
-: SOL_SOCKET 1 ; inline
+ALIAS: O_NDELAY O_NONBLOCK
-: FD_SETSIZE 1024 ; inline
+CONSTANT: SOL_SOCKET 1
-: SO_REUSEADDR 2 ; inline
-: SO_OOBINLINE 10 ; inline
-: SO_SNDTIMEO HEX: 15 ; inline
-: SO_RCVTIMEO HEX: 14 ; inline
+CONSTANT: FD_SETSIZE 1024
-: F_SETFD 2 ; inline
-: FD_CLOEXEC 1 ; inline
+CONSTANT: SO_REUSEADDR 2
+CONSTANT: SO_OOBINLINE 10
+CONSTANT: SO_SNDTIMEO HEX: 15
+CONSTANT: SO_RCVTIMEO HEX: 14
-: F_SETFL 4 ; inline
+CONSTANT: F_SETFD 2
+CONSTANT: FD_CLOEXEC 1
+
+CONSTANT: F_SETFL 4
C-STRUCT: addrinfo
{ "int" "flags" }
{ { "uchar" 16 } "addr" }
{ "uint" "scopeid" } ;
-: max-un-path 108 ; inline
+CONSTANT: max-un-path 108
C-STRUCT: sockaddr-un
{ "ushort" "family" }
{ { "char" max-un-path } "path" } ;
-: SOCK_STREAM 1 ; inline
-: SOCK_DGRAM 2 ; inline
+CONSTANT: SOCK_STREAM 1
+CONSTANT: SOCK_DGRAM 2
-: AF_UNSPEC 0 ; inline
-: AF_UNIX 1 ; inline
-: AF_INET 2 ; inline
-: AF_INET6 10 ; inline
+CONSTANT: AF_UNSPEC 0
+CONSTANT: AF_UNIX 1
+CONSTANT: AF_INET 2
+CONSTANT: AF_INET6 10
-: PF_UNSPEC AF_UNSPEC ; inline
-: PF_UNIX AF_UNIX ; inline
-: PF_INET AF_INET ; inline
-: PF_INET6 AF_INET6 ; inline
+ALIAS: PF_UNSPEC AF_UNSPEC
+ALIAS: PF_UNIX AF_UNIX
+ALIAS: PF_INET AF_INET
+ALIAS: PF_INET6 AF_INET6
-: IPPROTO_TCP 6 ; inline
-: IPPROTO_UDP 17 ; inline
+CONSTANT: IPPROTO_TCP 6
+CONSTANT: IPPROTO_UDP 17
-: AI_PASSIVE 1 ; inline
+CONSTANT: AI_PASSIVE 1
-: SEEK_SET 0 ; inline
-: SEEK_CUR 1 ; inline
-: SEEK_END 2 ; inline
+CONSTANT: SEEK_SET 0
+CONSTANT: SEEK_CUR 1
+CONSTANT: SEEK_END 2
C-STRUCT: passwd
{ "char*" "pw_name" }
{ "uchar" "d_type" }
{ { "char" 256 } "d_name" } ;
-: EPERM 1 ; inline
-: ENOENT 2 ; inline
-: ESRCH 3 ; inline
-: EINTR 4 ; inline
-: EIO 5 ; inline
-: ENXIO 6 ; inline
-: E2BIG 7 ; inline
-: ENOEXEC 8 ; inline
-: EBADF 9 ; inline
-: ECHILD 10 ; inline
-: EAGAIN 11 ; inline
-: ENOMEM 12 ; inline
-: EACCES 13 ; inline
-: EFAULT 14 ; inline
-: ENOTBLK 15 ; inline
-: EBUSY 16 ; inline
-: EEXIST 17 ; inline
-: EXDEV 18 ; inline
-: ENODEV 19 ; inline
-: ENOTDIR 20 ; inline
-: EISDIR 21 ; inline
-: EINVAL 22 ; inline
-: ENFILE 23 ; inline
-: EMFILE 24 ; inline
-: ENOTTY 25 ; inline
-: ETXTBSY 26 ; inline
-: EFBIG 27 ; inline
-: ENOSPC 28 ; inline
-: ESPIPE 29 ; inline
-: EROFS 30 ; inline
-: EMLINK 31 ; inline
-: EPIPE 32 ; inline
-: EDOM 33 ; inline
-: ERANGE 34 ; inline
-: EDEADLK 35 ; inline
-: ENAMETOOLONG 36 ; inline
-: ENOLCK 37 ; inline
-: ENOSYS 38 ; inline
-: ENOTEMPTY 39 ; inline
-: ELOOP 40 ; inline
-: EWOULDBLOCK EAGAIN ; inline
-: ENOMSG 42 ; inline
-: EIDRM 43 ; inline
-: ECHRNG 44 ; inline
-: EL2NSYNC 45 ; inline
-: EL3HLT 46 ; inline
-: EL3RST 47 ; inline
-: ELNRNG 48 ; inline
-: EUNATCH 49 ; inline
-: ENOCSI 50 ; inline
-: EL2HLT 51 ; inline
-: EBADE 52 ; inline
-: EBADR 53 ; inline
-: EXFULL 54 ; inline
-: ENOANO 55 ; inline
-: EBADRQC 56 ; inline
-: EBADSLT 57 ; inline
-: EDEADLOCK EDEADLK ; inline
-: EBFONT 59 ; inline
-: ENOSTR 60 ; inline
-: ENODATA 61 ; inline
-: ETIME 62 ; inline
-: ENOSR 63 ; inline
-: ENONET 64 ; inline
-: ENOPKG 65 ; inline
-: EREMOTE 66 ; inline
-: ENOLINK 67 ; inline
-: EADV 68 ; inline
-: ESRMNT 69 ; inline
-: ECOMM 70 ; inline
-: EPROTO 71 ; inline
-: EMULTIHOP 72 ; inline
-: EDOTDOT 73 ; inline
-: EBADMSG 74 ; inline
-: EOVERFLOW 75 ; inline
-: ENOTUNIQ 76 ; inline
-: EBADFD 77 ; inline
-: EREMCHG 78 ; inline
-: ELIBACC 79 ; inline
-: ELIBBAD 80 ; inline
-: ELIBSCN 81 ; inline
-: ELIBMAX 82 ; inline
-: ELIBEXEC 83 ; inline
-: EILSEQ 84 ; inline
-: ERESTART 85 ; inline
-: ESTRPIPE 86 ; inline
-: EUSERS 87 ; inline
-: ENOTSOCK 88 ; inline
-: EDESTADDRREQ 89 ; inline
-: EMSGSIZE 90 ; inline
-: EPROTOTYPE 91 ; inline
-: ENOPROTOOPT 92 ; inline
-: EPROTONOSUPPORT 93 ; inline
-: ESOCKTNOSUPPORT 94 ; inline
-: EOPNOTSUPP 95 ; inline
-: EPFNOSUPPORT 96 ; inline
-: EAFNOSUPPORT 97 ; inline
-: EADDRINUSE 98 ; inline
-: EADDRNOTAVAIL 99 ; inline
-: ENETDOWN 100 ; inline
-: ENETUNREACH 101 ; inline
-: ENETRESET 102 ; inline
-: ECONNABORTED 103 ; inline
-: ECONNRESET 104 ; inline
-: ENOBUFS 105 ; inline
-: EISCONN 106 ; inline
-: ENOTCONN 107 ; inline
-: ESHUTDOWN 108 ; inline
-: ETOOMANYREFS 109 ; inline
-: ETIMEDOUT 110 ; inline
-: ECONNREFUSED 111 ; inline
-: EHOSTDOWN 112 ; inline
-: EHOSTUNREACH 113 ; inline
-: EALREADY 114 ; inline
-: EINPROGRESS 115 ; inline
-: ESTALE 116 ; inline
-: EUCLEAN 117 ; inline
-: ENOTNAM 118 ; inline
-: ENAVAIL 119 ; inline
-: EISNAM 120 ; inline
-: EREMOTEIO 121 ; inline
-: EDQUOT 122 ; inline
-: ENOMEDIUM 123 ; inline
-: EMEDIUMTYPE 124 ; inline
-: ECANCELED 125 ; inline
-: ENOKEY 126 ; inline
-: EKEYEXPIRED 127 ; inline
-: EKEYREVOKED 128 ; inline
-: EKEYREJECTED 129 ; inline
-: EOWNERDEAD 130 ; inline
-: ENOTRECOVERABLE 131 ; inline
+CONSTANT: EPERM 1
+CONSTANT: ENOENT 2
+CONSTANT: ESRCH 3
+CONSTANT: EINTR 4
+CONSTANT: EIO 5
+CONSTANT: ENXIO 6
+CONSTANT: E2BIG 7
+CONSTANT: ENOEXEC 8
+CONSTANT: EBADF 9
+CONSTANT: ECHILD 10
+CONSTANT: EAGAIN 11
+CONSTANT: ENOMEM 12
+CONSTANT: EACCES 13
+CONSTANT: EFAULT 14
+CONSTANT: ENOTBLK 15
+CONSTANT: EBUSY 16
+CONSTANT: EEXIST 17
+CONSTANT: EXDEV 18
+CONSTANT: ENODEV 19
+CONSTANT: ENOTDIR 20
+CONSTANT: EISDIR 21
+CONSTANT: EINVAL 22
+CONSTANT: ENFILE 23
+CONSTANT: EMFILE 24
+CONSTANT: ENOTTY 25
+CONSTANT: ETXTBSY 26
+CONSTANT: EFBIG 27
+CONSTANT: ENOSPC 28
+CONSTANT: ESPIPE 29
+CONSTANT: EROFS 30
+CONSTANT: EMLINK 31
+CONSTANT: EPIPE 32
+CONSTANT: EDOM 33
+CONSTANT: ERANGE 34
+CONSTANT: EDEADLK 35
+CONSTANT: ENAMETOOLONG 36
+CONSTANT: ENOLCK 37
+CONSTANT: ENOSYS 38
+CONSTANT: ENOTEMPTY 39
+CONSTANT: ELOOP 40
+ALIAS: EWOULDBLOCK EAGAIN
+CONSTANT: ENOMSG 42
+CONSTANT: EIDRM 43
+CONSTANT: ECHRNG 44
+CONSTANT: EL2NSYNC 45
+CONSTANT: EL3HLT 46
+CONSTANT: EL3RST 47
+CONSTANT: ELNRNG 48
+CONSTANT: EUNATCH 49
+CONSTANT: ENOCSI 50
+CONSTANT: EL2HLT 51
+CONSTANT: EBADE 52
+CONSTANT: EBADR 53
+CONSTANT: EXFULL 54
+CONSTANT: ENOANO 55
+CONSTANT: EBADRQC 56
+CONSTANT: EBADSLT 57
+ALIAS: EDEADLOCK EDEADLK
+CONSTANT: EBFONT 59
+CONSTANT: ENOSTR 60
+CONSTANT: ENODATA 61
+CONSTANT: ETIME 62
+CONSTANT: ENOSR 63
+CONSTANT: ENONET 64
+CONSTANT: ENOPKG 65
+CONSTANT: EREMOTE 66
+CONSTANT: ENOLINK 67
+CONSTANT: EADV 68
+CONSTANT: ESRMNT 69
+CONSTANT: ECOMM 70
+CONSTANT: EPROTO 71
+CONSTANT: EMULTIHOP 72
+CONSTANT: EDOTDOT 73
+CONSTANT: EBADMSG 74
+CONSTANT: EOVERFLOW 75
+CONSTANT: ENOTUNIQ 76
+CONSTANT: EBADFD 77
+CONSTANT: EREMCHG 78
+CONSTANT: ELIBACC 79
+CONSTANT: ELIBBAD 80
+CONSTANT: ELIBSCN 81
+CONSTANT: ELIBMAX 82
+CONSTANT: ELIBEXEC 83
+CONSTANT: EILSEQ 84
+CONSTANT: ERESTART 85
+CONSTANT: ESTRPIPE 86
+CONSTANT: EUSERS 87
+CONSTANT: ENOTSOCK 88
+CONSTANT: EDESTADDRREQ 89
+CONSTANT: EMSGSIZE 90
+CONSTANT: EPROTOTYPE 91
+CONSTANT: ENOPROTOOPT 92
+CONSTANT: EPROTONOSUPPORT 93
+CONSTANT: ESOCKTNOSUPPORT 94
+CONSTANT: EOPNOTSUPP 95
+CONSTANT: EPFNOSUPPORT 96
+CONSTANT: EAFNOSUPPORT 97
+CONSTANT: EADDRINUSE 98
+CONSTANT: EADDRNOTAVAIL 99
+CONSTANT: ENETDOWN 100
+CONSTANT: ENETUNREACH 101
+CONSTANT: ENETRESET 102
+CONSTANT: ECONNABORTED 103
+CONSTANT: ECONNRESET 104
+CONSTANT: ENOBUFS 105
+CONSTANT: EISCONN 106
+CONSTANT: ENOTCONN 107
+CONSTANT: ESHUTDOWN 108
+CONSTANT: ETOOMANYREFS 109
+CONSTANT: ETIMEDOUT 110
+CONSTANT: ECONNREFUSED 111
+CONSTANT: EHOSTDOWN 112
+CONSTANT: EHOSTUNREACH 113
+CONSTANT: EALREADY 114
+CONSTANT: EINPROGRESS 115
+CONSTANT: ESTALE 116
+CONSTANT: EUCLEAN 117
+CONSTANT: ENOTNAM 118
+CONSTANT: ENAVAIL 119
+CONSTANT: EISNAM 120
+CONSTANT: EREMOTEIO 121
+CONSTANT: EDQUOT 122
+CONSTANT: ENOMEDIUM 123
+CONSTANT: EMEDIUMTYPE 124
+CONSTANT: ECANCELED 125
+CONSTANT: ENOKEY 126
+CONSTANT: EKEYEXPIRED 127
+CONSTANT: EKEYREVOKED 128
+CONSTANT: EKEYREJECTED 129
+CONSTANT: EOWNERDEAD 130
+CONSTANT: ENOTRECOVERABLE 131
USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
vectors kernel namespaces continuations threads assocs vectors
-io.unix.backend io.encodings.utf8 unix.utilities ;
+io.backend.unix io.encodings.utf8 unix.utilities ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
[ [ fork-process dup zero? ] dip [ drop ] prepose ] dip
if ; inline
-: SIGKILL 9 ; inline
-: SIGTERM 15 ; inline
+CONSTANT: SIGKILL 9
+CONSTANT: SIGTERM 15
FUNCTION: int kill ( pid_t pid, int sig ) ;
-: PRIO_PROCESS 0 ; inline
-: PRIO_PGRP 1 ; inline
-: PRIO_USER 2 ; inline
+CONSTANT: PRIO_PROCESS 0
+CONSTANT: PRIO_PGRP 1
+CONSTANT: PRIO_USER 2
-: PRIO_MIN -20 ; inline
-: PRIO_MAX 20 ; inline
+CONSTANT: PRIO_MIN -20
+CONSTANT: PRIO_MAX 20
! which/who = 0 for current process
FUNCTION: int getpriority ( int which, int who ) ;
FUNCTION: int setpriority ( int which, int who, int prio ) ;
: set-priority ( n -- )
- 0 0 rot setpriority io-error ;
+ [ 0 0 ] dip setpriority io-error ;
! Flags for waitpid
-: WNOHANG 1 ; inline
-: WUNTRACED 2 ; inline
+CONSTANT: WNOHANG 1
+CONSTANT: WUNTRACED 2
-: WSTOPPED 2 ; inline
-: WEXITED 4 ; inline
-: WCONTINUED 8 ; inline
-: WNOWAIT HEX: 1000000 ; inline
+CONSTANT: WSTOPPED 2
+CONSTANT: WEXITED 4
+CONSTANT: WCONTINUED 8
+CONSTANT: WNOWAIT HEX: 1000000
! Examining status
! Copyright (C) 2006 Patrick Mauritz.
! See http://factorcode.org/license.txt for BSD license.
IN: unix
-USING: alien.syntax system kernel ;
+USING: alien.syntax system kernel layouts ;
! Solaris.
-: O_RDONLY HEX: 0000 ; inline
-: O_WRONLY HEX: 0001 ; inline
-: O_RDWR HEX: 0002 ; inline
-: O_APPEND HEX: 0008 ; inline
-: O_CREAT HEX: 0100 ; inline
-: O_TRUNC HEX: 0200 ; inline
+CONSTANT: O_RDONLY HEX: 0000
+CONSTANT: O_WRONLY HEX: 0001
+CONSTANT: O_RDWR HEX: 0002
+CONSTANT: O_APPEND HEX: 0008
+CONSTANT: O_CREAT HEX: 0100
+CONSTANT: O_TRUNC HEX: 0200
-: SEEK_END 2 ; inline
+CONSTANT: SEEK_END 2
-: SOL_SOCKET HEX: ffff ; inline
+CONSTANT: SOL_SOCKET HEX: ffff
-: FD_SETSIZE cell 4 = 1024 65536 ? ; inline
+: FD_SETSIZE ( -- n ) cell 4 = 1024 65536 ? ;
-: SO_REUSEADDR 4 ; inline
-: SO_OOBINLINE HEX: 0100 ; inline
-: SO_SNDTIMEO HEX: 1005 ; inline
-: SO_RCVTIMEO HEX: 1006 ; inline
+CONSTANT: SO_REUSEADDR 4
+CONSTANT: SO_OOBINLINE HEX: 0100
+CONSTANT: SO_SNDTIMEO HEX: 1005
+CONSTANT: SO_RCVTIMEO HEX: 1006
-: F_SETFL 4 ; ! set file status flags
-: O_NONBLOCK HEX: 80 ; ! no delay
+CONSTANT: F_SETFL 4 ! set file status flags
+CONSTANT: O_NONBLOCK HEX: 80 ! no delay
C-STRUCT: addrinfo
{ "int" "flags" }
{ "ushort" "family" }
{ { "char" max-un-path } "path" } ;
-: EINTR 4 ; inline
-: EAGAIN 11 ; inline
-: EINPROGRESS 150 ; inline
+CONSTANT: EINTR 4
+CONSTANT: EAGAIN 11
+CONSTANT: EINPROGRESS 150
-: SOCK_STREAM 2 ; inline
-: SOCK_DGRAM 1 ; inline
+CONSTANT: SOCK_STREAM 2
+CONSTANT: SOCK_DGRAM 1
-: AF_UNSPEC 0 ; inline
-: AF_UNIX 1 ; inline
-: AF_INET 2 ; inline
-: AF_INET6 26 ; inline
+CONSTANT: AF_UNSPEC 0
+CONSTANT: AF_UNIX 1
+CONSTANT: AF_INET 2
+CONSTANT: AF_INET6 26
-: PF_UNSPEC AF_UNSPEC ; inline
-: PF_UNIX AF_UNIX ; inline
-: PF_INET AF_INET ; inline
-: PF_INET6 AF_INET6 ; inline
+ALIAS: PF_UNSPEC AF_UNSPEC
+ALIAS: PF_UNIX AF_UNIX
+ALIAS: PF_INET AF_INET
+ALIAS: PF_INET6 AF_INET6
-: IPPROTO_TCP 6 ; inline
-: IPPROTO_UDP 17 ; inline
+CONSTANT: IPPROTO_TCP 6
+CONSTANT: IPPROTO_UDP 17
-: AI_PASSIVE 8 ; inline
+CONSTANT: AI_PASSIVE 8
FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
-: stat ( pathname buf -- int ) 3 -rot __xstat ;
-: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
+: stat ( pathname buf -- int ) [ 3 ] 2dip __xstat ;
+: lstat ( pathname buf -- int ) [ 3 ] 2dip __lxstat ;
FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
-: stat ( pathname buf -- int ) 1 -rot __xstat ;
-: lstat ( pathname buf -- int ) 1 -rot __lxstat ;
+: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat ;
+: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat ;
FUNCTION: int __stat30 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat30 ( char* pathname, stat* buf ) ;
-: stat ( pathname buf -- n ) __stat30 ; inline
-: lstat ( pathname buf -- n ) __lstat30 ; inline
+: stat ( pathname buf -- n ) __stat30 ;
+: lstat ( pathname buf -- n ) __lstat30 ;
FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ;
-: stat ( pathname buf -- n ) __stat13 ; inline
-: lstat ( pathname buf -- n ) __lstat13 ; inline
+: stat ( pathname buf -- n ) __stat13 ;
+: lstat ( pathname buf -- n ) __lstat13 ;
USING: kernel system combinators alien.syntax alien.c-types
-math io.unix.backend vocabs.loader unix ;
+math io.backend.unix vocabs.loader unix ;
IN: unix.stat
! File Types
-: S_IFMT OCT: 170000 ; ! These bits determine file type.
+CONSTANT: S_IFMT OCT: 170000 ! These bits determine file type.
-: S_IFDIR OCT: 40000 ; inline ! Directory.
-: S_IFCHR OCT: 20000 ; inline ! Character device.
-: S_IFBLK OCT: 60000 ; inline ! Block device.
-: S_IFREG OCT: 100000 ; inline ! Regular file.
-: S_IFIFO OCT: 010000 ; inline ! FIFO.
-: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
-: S_IFSOCK OCT: 140000 ; inline ! Socket.
-: S_IFWHT OCT: 160000 ; inline ! Whiteout.
+CONSTANT: S_IFDIR OCT: 40000 ! Directory.
+CONSTANT: S_IFCHR OCT: 20000 ! Character device.
+CONSTANT: S_IFBLK OCT: 60000 ! Block device.
+CONSTANT: S_IFREG OCT: 100000 ! Regular file.
+CONSTANT: S_IFIFO OCT: 010000 ! FIFO.
+CONSTANT: S_IFLNK OCT: 120000 ! Symbolic link.
+CONSTANT: S_IFSOCK OCT: 140000 ! Socket.
+CONSTANT: S_IFWHT OCT: 160000 ! Whiteout.
FUNCTION: int chmod ( char* path, mode_t mode ) ;
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
C-STRUCT: fsid
{ { "int" 2 } "__val" } ;
- TYPEDEF: fsid __fsid_t
- TYPEDEF: fsid fsid_t
+TYPEDEF: fsid __fsid_t
+TYPEDEF: fsid fsid_t
<< os {
{ linux [ "unix.stat.linux" require ] }
USING: alien.syntax ;
IN: unix.statfs.freebsd
-: MFSNAMELEN 16 ; inline ! length of type name including null */
-: MNAMELEN 88 ; inline ! size of on/from name bufs
-: STATFS_VERSION HEX: 20030518 ; inline ! current version number
+CONSTANT: MFSNAMELEN 16 ! length of type name including null */
+CONSTANT: MNAMELEN 88 ! size of on/from name bufs
+CONSTANT: STATFS_VERSION HEX: 20030518 ! current version number
C-STRUCT: statfs
{ "uint32_t" "f_version" }
grouping system alien.strings math.bitwise alien.syntax ;
IN: unix.statfs.macosx
-: MNT_RDONLY HEX: 00000001 ; inline
-: MNT_SYNCHRONOUS HEX: 00000002 ; inline
-: MNT_NOEXEC HEX: 00000004 ; inline
-: MNT_NOSUID HEX: 00000008 ; inline
-: MNT_NODEV HEX: 00000010 ; inline
-: MNT_UNION HEX: 00000020 ; inline
-: MNT_ASYNC HEX: 00000040 ; inline
-: MNT_EXPORTED HEX: 00000100 ; inline
-: MNT_QUARANTINE HEX: 00000400 ; inline
-: MNT_LOCAL HEX: 00001000 ; inline
-: MNT_QUOTA HEX: 00002000 ; inline
-: MNT_ROOTFS HEX: 00004000 ; inline
-: MNT_DOVOLFS HEX: 00008000 ; inline
-: MNT_DONTBROWSE HEX: 00100000 ; inline
-: MNT_IGNORE_OWNERSHIP HEX: 00200000 ; inline
-: MNT_AUTOMOUNTED HEX: 00400000 ; inline
-: MNT_JOURNALED HEX: 00800000 ; inline
-: MNT_NOUSERXATTR HEX: 01000000 ; inline
-: MNT_DEFWRITE HEX: 02000000 ; inline
-: MNT_MULTILABEL HEX: 04000000 ; inline
-: MNT_NOATIME HEX: 10000000 ; inline
-: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP ; inline
+CONSTANT: MNT_RDONLY HEX: 00000001
+CONSTANT: MNT_SYNCHRONOUS HEX: 00000002
+CONSTANT: MNT_NOEXEC HEX: 00000004
+CONSTANT: MNT_NOSUID HEX: 00000008
+CONSTANT: MNT_NODEV HEX: 00000010
+CONSTANT: MNT_UNION HEX: 00000020
+CONSTANT: MNT_ASYNC HEX: 00000040
+CONSTANT: MNT_EXPORTED HEX: 00000100
+CONSTANT: MNT_QUARANTINE HEX: 00000400
+CONSTANT: MNT_LOCAL HEX: 00001000
+CONSTANT: MNT_QUOTA HEX: 00002000
+CONSTANT: MNT_ROOTFS HEX: 00004000
+CONSTANT: MNT_DOVOLFS HEX: 00008000
+CONSTANT: MNT_DONTBROWSE HEX: 00100000
+CONSTANT: MNT_IGNORE_OWNERSHIP HEX: 00200000
+CONSTANT: MNT_AUTOMOUNTED HEX: 00400000
+CONSTANT: MNT_JOURNALED HEX: 00800000
+CONSTANT: MNT_NOUSERXATTR HEX: 01000000
+CONSTANT: MNT_DEFWRITE HEX: 02000000
+CONSTANT: MNT_MULTILABEL HEX: 04000000
+CONSTANT: MNT_NOATIME HEX: 10000000
+ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP
: MNT_VISFLAGMASK ( -- n )
{
MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
} flags ; inline
-: MNT_UPDATE HEX: 00010000 ; inline
-: MNT_RELOAD HEX: 00040000 ; inline
-: MNT_FORCE HEX: 00080000 ; inline
-: MNT_CMDFLAGS { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
+CONSTANT: MNT_UPDATE HEX: 00010000
+CONSTANT: MNT_RELOAD HEX: 00040000
+CONSTANT: MNT_FORCE HEX: 00080000
-: VFS_GENERIC 0 ; inline
-: VFS_NUMMNTOPS 1 ; inline
-: VFS_MAXTYPENUM 1 ; inline
-: VFS_CONF 2 ; inline
-: VFS_SET_PACKAGE_EXTS 3 ; inline
+: MNT_CMDFLAGS ( -- n )
+ { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
-: MNT_WAIT 1 ; inline
-: MNT_NOWAIT 2 ; inline
+CONSTANT: VFS_GENERIC 0
+CONSTANT: VFS_NUMMNTOPS 1
+CONSTANT: VFS_MAXTYPENUM 1
+CONSTANT: VFS_CONF 2
+CONSTANT: VFS_SET_PACKAGE_EXTS 3
-: VFS_CTL_VERS1 HEX: 01 ; inline
+CONSTANT: MNT_WAIT 1
+CONSTANT: MNT_NOWAIT 2
-: VFS_CTL_STATFS HEX: 00010001 ; inline
-: VFS_CTL_UMOUNT HEX: 00010002 ; inline
-: VFS_CTL_QUERY HEX: 00010003 ; inline
-: VFS_CTL_NEWADDR HEX: 00010004 ; inline
-: VFS_CTL_TIMEO HEX: 00010005 ; inline
-: VFS_CTL_NOLOCKS HEX: 00010006 ; inline
+CONSTANT: VFS_CTL_VERS1 HEX: 01
+
+CONSTANT: VFS_CTL_STATFS HEX: 00010001
+CONSTANT: VFS_CTL_UMOUNT HEX: 00010002
+CONSTANT: VFS_CTL_QUERY HEX: 00010003
+CONSTANT: VFS_CTL_NEWADDR HEX: 00010004
+CONSTANT: VFS_CTL_TIMEO HEX: 00010005
+CONSTANT: VFS_CTL_NOLOCKS HEX: 00010006
C-STRUCT: vfsquery
{ "uint32_t" "vq_flags" }
{ { "uint32_t" 31 } "vq_spare" } ;
-: VQ_NOTRESP HEX: 0001 ; inline
-: VQ_NEEDAUTH HEX: 0002 ; inline
-: VQ_LOWDISK HEX: 0004 ; inline
-: VQ_MOUNT HEX: 0008 ; inline
-: VQ_UNMOUNT HEX: 0010 ; inline
-: VQ_DEAD HEX: 0020 ; inline
-: VQ_ASSIST HEX: 0040 ; inline
-: VQ_NOTRESPLOCK HEX: 0080 ; inline
-: VQ_UPDATE HEX: 0100 ; inline
-: VQ_FLAG0200 HEX: 0200 ; inline
-: VQ_FLAG0400 HEX: 0400 ; inline
-: VQ_FLAG0800 HEX: 0800 ; inline
-: VQ_FLAG1000 HEX: 1000 ; inline
-: VQ_FLAG2000 HEX: 2000 ; inline
-: VQ_FLAG4000 HEX: 4000 ; inline
-: VQ_FLAG8000 HEX: 8000 ; inline
+CONSTANT: VQ_NOTRESP HEX: 0001
+CONSTANT: VQ_NEEDAUTH HEX: 0002
+CONSTANT: VQ_LOWDISK HEX: 0004
+CONSTANT: VQ_MOUNT HEX: 0008
+CONSTANT: VQ_UNMOUNT HEX: 0010
+CONSTANT: VQ_DEAD HEX: 0020
+CONSTANT: VQ_ASSIST HEX: 0040
+CONSTANT: VQ_NOTRESPLOCK HEX: 0080
+CONSTANT: VQ_UPDATE HEX: 0100
+CONSTANT: VQ_FLAG0200 HEX: 0200
+CONSTANT: VQ_FLAG0400 HEX: 0400
+CONSTANT: VQ_FLAG0800 HEX: 0800
+CONSTANT: VQ_FLAG1000 HEX: 1000
+CONSTANT: VQ_FLAG2000 HEX: 2000
+CONSTANT: VQ_FLAG4000 HEX: 4000
+CONSTANT: VQ_FLAG8000 HEX: 8000
-: NFSV4_MAX_FH_SIZE 128 ; inline
-: NFSV3_MAX_FH_SIZE 64 ; inline
-: NFSV2_MAX_FH_SIZE 32 ; inline
-: NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE ; inline
+CONSTANT: NFSV4_MAX_FH_SIZE 128
+CONSTANT: NFSV3_MAX_FH_SIZE 64
+CONSTANT: NFSV2_MAX_FH_SIZE 32
+ALIAS: NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE
-: MFSNAMELEN 15 ; inline
-: MNAMELEN 90 ; inline
-: MFSTYPENAMELEN 16 ; inline
+CONSTANT: MFSNAMELEN 15
+CONSTANT: MNAMELEN 90
+CONSTANT: MFSTYPENAMELEN 16
C-STRUCT: fsid_t
{ { "int32_t" 2 } "val" } ;
USING: alien.syntax ;
IN: unix.statfs.openbsd
-: MFSNAMELEN 16 ; inline
-: MNAMELEN 90 ; inline
+CONSTANT: MFSNAMELEN 16
+CONSTANT: MNAMELEN 90
C-STRUCT: statfs
{ "u_int32_t" "f_flags" }
{ "ulong" "f_namemax" } ;
! Flags
-: ST_RDONLY HEX: 1 ; inline ! Read-only file system
-: ST_NOSUID HEX: 2 ; inline ! Does not honor setuid/setgid
+CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system
+CONSTANT: ST_NOSUID HEX: 2 ! Does not honor setuid/setgid
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
FUNCTION: int statvfs64 ( char* path, statvfs64* buf ) ;
-: ST_RDONLY 1 ; inline ! Mount read-only.
-: ST_NOSUID 2 ; inline ! Ignore suid and sgid bits.
-: ST_NODEV 4 ; inline ! Disallow access to device special files.
-: ST_NOEXEC 8 ; inline ! Disallow program execution.
-: ST_SYNCHRONOUS 16 ; inline ! Writes are synced at once.
-: ST_MANDLOCK 64 ; inline ! Allow mandatory locks on an FS.
-: ST_WRITE 128 ; inline ! Write on file/directory/symlink.
-: ST_APPEND 256 ; inline ! Append-only file.
-: ST_IMMUTABLE 512 ; inline ! Immutable file.
-: ST_NOATIME 1024 ; inline ! Do not update access times.
+CONSTANT: ST_RDONLY 1 ! Mount read-only.
+CONSTANT: ST_NOSUID 2 ! Ignore suid and sgid bits.
+CONSTANT: ST_NODEV 4 ! Disallow access to device special files.
+CONSTANT: ST_NOEXEC 8 ! Disallow program execution.
+CONSTANT: ST_SYNCHRONOUS 16 ! Writes are synced at once.
+CONSTANT: ST_MANDLOCK 64 ! Allow mandatory locks on an FS.
+CONSTANT: ST_WRITE 128 ! Write on file/directory/symlink.
+CONSTANT: ST_APPEND 256 ! Append-only file.
+CONSTANT: ST_IMMUTABLE 512 ! Immutable file.
+CONSTANT: ST_NOATIME 1024 ! Do not update access times.
{ "ulong" "f_namemax" } ;
! Flags
-: ST_RDONLY HEX: 1 ; inline ! Read-only file system
-: ST_NOSUID HEX: 2 ; inline ! Does not honor setuid/setgid
+CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system
+CONSTANT: ST_NOSUID HEX: 2 ! Does not honor setuid/setgid
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
USING: alien.syntax ;
IN: unix.statvfs.netbsd
-: _VFS_NAMELEN 32 ; inline
-: _VFS_MNAMELEN 1024 ; inline
+CONSTANT: _VFS_NAMELEN 32
+CONSTANT: _VFS_MNAMELEN 1024
C-STRUCT: statvfs
- { "ulong" "f_flag" }
+ { "ulong" "f_flag" }
{ "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "ulong" "f_iosize" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_bavail" }
- { "fsblkcnt_t" "f_bresvd" }
+ { "ulong" "f_frsize" }
+ { "ulong" "f_iosize" }
+ { "fsblkcnt_t" "f_blocks" }
+ { "fsblkcnt_t" "f_bfree" }
+ { "fsblkcnt_t" "f_bavail" }
+ { "fsblkcnt_t" "f_bresvd" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_favail" }
- { "fsfilcnt_t" "f_fresvd" }
- { "uint64_t" "f_syncreads" }
- { "uint64_t" "f_syncwrites" }
- { "uint64_t" "f_asyncreads" }
- { "uint64_t" "f_asyncwrites" }
+ { "fsfilcnt_t" "f_favail" }
+ { "fsfilcnt_t" "f_fresvd" }
+ { "uint64_t" "f_syncreads" }
+ { "uint64_t" "f_syncwrites" }
+ { "uint64_t" "f_asyncreads" }
+ { "uint64_t" "f_asyncwrites" }
{ "fsid_t" "f_fsidx" }
{ "ulong" "f_fsid" }
- { "ulong" "f_namemax" }
+ { "ulong" "f_namemax" }
{ "uid_t" "f_owner" }
- { { "uint32_t" 4 } "f_spare" }
+ { { "uint32_t" 4 } "f_spare" }
{ { "char" _VFS_NAMELEN } "f_fstypename" }
{ { "char" _VFS_MNAMELEN } "f_mntonname" }
{ { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" } ;
-: ST_RDONLY 1 ; inline
-: ST_NOSUID 2 ; inline
+CONSTANT: ST_RDONLY 1
+CONSTANT: ST_NOSUID 2
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel libc
sequences continuations byte-arrays strings math namespaces
-system combinators vocabs.loader qualified accessors
+system combinators vocabs.loader accessors
stack-checker macros locals generalizations unix.types
-io io.files vocabs vocabs.loader ;
+io vocabs vocabs.loader ;
IN: unix
-: PROT_NONE 0 ; inline
-: PROT_READ 1 ; inline
-: PROT_WRITE 2 ; inline
-: PROT_EXEC 4 ; inline
-
-: MAP_FILE 0 ; inline
-: MAP_SHARED 1 ; inline
-: MAP_PRIVATE 2 ; inline
-
-: MAP_FAILED -1 <alien> ; inline
-
-: NGROUPS_MAX 16 ; inline
-
-: DT_UNKNOWN 0 ; inline
-: DT_FIFO 1 ; inline
-: DT_CHR 2 ; inline
-: DT_DIR 4 ; inline
-: DT_BLK 6 ; inline
-: DT_REG 8 ; inline
-: DT_LNK 10 ; inline
-: DT_SOCK 12 ; inline
-: DT_WHT 14 ; inline
-
-: dirent-type>file-type ( ch -- type )
- {
- { DT_BLK [ +block-device+ ] }
- { DT_CHR [ +character-device+ ] }
- { DT_DIR [ +directory+ ] }
- { DT_LNK [ +symbolic-link+ ] }
- { DT_SOCK [ +socket+ ] }
- { DT_FIFO [ +fifo+ ] }
- { DT_REG [ +regular-file+ ] }
- { DT_WHT [ +whiteout+ ] }
- [ drop +unknown+ ]
- } case ;
+CONSTANT: PROT_NONE 0
+CONSTANT: PROT_READ 1
+CONSTANT: PROT_WRITE 2
+CONSTANT: PROT_EXEC 4
+
+CONSTANT: MAP_FILE 0
+CONSTANT: MAP_SHARED 1
+CONSTANT: MAP_PRIVATE 2
+
+: MAP_FAILED ( -- alien ) -1 <alien> ; inline
+
+CONSTANT: NGROUPS_MAX 16
+
+CONSTANT: DT_UNKNOWN 0
+CONSTANT: DT_FIFO 1
+CONSTANT: DT_CHR 2
+CONSTANT: DT_DIR 4
+CONSTANT: DT_BLK 6
+CONSTANT: DT_REG 8
+CONSTANT: DT_LNK 10
+CONSTANT: DT_SOCK 12
+CONSTANT: DT_WHT 14
C-STRUCT: group
{ "char*" "gr_name" }
FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
-: PATH_MAX 1024 ; inline
+CONSTANT: PATH_MAX 1024
: read-symbolic-link ( path -- path )
PATH_MAX <byte-array> dup [
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings io.encodings.utf8
-io.unix.backend kernel math sequences splitting unix strings
+io.backend.unix kernel math sequences splitting unix strings
combinators.short-circuit grouping byte-arrays combinators
accessors math.parser fry assocs namespaces continuations
vocabs.loader system ;
vocabs.loader ;
IN: unix.utmpx
-: EMPTY 0 ; inline
-: RUN_LVL 1 ; inline
-: BOOT_TIME 2 ; inline
-: OLD_TIME 3 ; inline
-: NEW_TIME 4 ; inline
-: INIT_PROCESS 5 ; inline
-: LOGIN_PROCESS 6 ; inline
-: USER_PROCESS 7 ; inline
-: DEAD_PROCESS 8 ; inline
-: ACCOUNTING 9 ; inline
-: SIGNATURE 10 ; inline
-: SHUTDOWN_TIME 11 ; inline
+CONSTANT: EMPTY 0
+CONSTANT: RUN_LVL 1
+CONSTANT: BOOT_TIME 2
+CONSTANT: OLD_TIME 3
+CONSTANT: NEW_TIME 4
+CONSTANT: INIT_PROCESS 5
+CONSTANT: LOGIN_PROCESS 6
+CONSTANT: USER_PROCESS 7
+CONSTANT: DEAD_PROCESS 8
+CONSTANT: ACCOUNTING 9
+CONSTANT: SIGNATURE 10
+CONSTANT: SHUTDOWN_TIME 11
FUNCTION: void setutxent ( ) ;
FUNCTION: void endutxent ( ) ;
USING: assocs hashtables help.markup help.syntax
-io.streams.string io.files kernel strings present math multiline
-;
+io.streams.string io.files io.pathnames kernel strings present
+math multiline ;
IN: urls
HELP: url
<PRIVATE
-: >vlist< [ length>> ] [ vector>> ] bi ; inline
+: >vlist< ( vlist -- len vec )
+ [ length>> ] [ vector>> ] bi ; inline
: unshare ( len vec -- len vec' )
clone [ set-length ] 2keep ; inline
-USING: alias alien.syntax kernel math windows.types math.bitwise ;
+USING: alien.syntax kernel math windows.types math.bitwise ;
IN: windows.advapi32
LIBRARY: advapi32
-: PROV_RSA_FULL 1 ; inline
-: PROV_RSA_SIG 2 ; inline
-: PROV_DSS 3 ; inline
-: PROV_FORTEZZA 4 ; inline
-: PROV_MS_EXCHANGE 5 ; inline
-: PROV_SSL 6 ; inline
-: PROV_RSA_SCHANNEL 12 ; inline
-: PROV_DSS_DH 13 ; inline
-: PROV_EC_ECDSA_SIG 14 ; inline
-: PROV_EC_ECNRA_SIG 15 ; inline
-: PROV_EC_ECDSA_FULL 16 ; inline
-: PROV_EC_ECNRA_FULL 17 ; inline
-: PROV_DH_SCHANNEL 18 ; inline
-: PROV_SPYRUS_LYNKS 20 ; inline
-: PROV_RNG 21 ; inline
-: PROV_INTEL_SEC 22 ; inline
-: PROV_REPLACE_OWF 23 ; inline
-: PROV_RSA_AES 24 ; inline
-
-: MS_DEF_DH_SCHANNEL_PROV
- "Microsoft DH Schannel Cryptographic Provider" ; inline
-
-: MS_DEF_DSS_DH_PROV
- "Microsoft Base DSS and Diffie-Hellman Cryptographic Provider" ; inline
-
-: MS_DEF_DSS_PROV
- "Microsoft Base DSS Cryptographic Provider" ; inline
-
-: MS_DEF_PROV
- "Microsoft Base Cryptographic Provider v1.0" ; inline
-
-: MS_DEF_RSA_SCHANNEL_PROV
- "Microsoft RSA Schannel Cryptographic Provider" ; inline
+CONSTANT: PROV_RSA_FULL 1
+CONSTANT: PROV_RSA_SIG 2
+CONSTANT: PROV_DSS 3
+CONSTANT: PROV_FORTEZZA 4
+CONSTANT: PROV_MS_EXCHANGE 5
+CONSTANT: PROV_SSL 6
+CONSTANT: PROV_RSA_SCHANNEL 12
+CONSTANT: PROV_DSS_DH 13
+CONSTANT: PROV_EC_ECDSA_SIG 14
+CONSTANT: PROV_EC_ECNRA_SIG 15
+CONSTANT: PROV_EC_ECDSA_FULL 16
+CONSTANT: PROV_EC_ECNRA_FULL 17
+CONSTANT: PROV_DH_SCHANNEL 18
+CONSTANT: PROV_SPYRUS_LYNKS 20
+CONSTANT: PROV_RNG 21
+CONSTANT: PROV_INTEL_SEC 22
+CONSTANT: PROV_REPLACE_OWF 23
+CONSTANT: PROV_RSA_AES 24
+
+CONSTANT: MS_DEF_DH_SCHANNEL_PROV "Microsoft DH Schannel Cryptographic Provider"
+
+CONSTANT: MS_DEF_DSS_DH_PROV
+ "Microsoft Base DSS and Diffie-Hellman Cryptographic Provider"
+
+CONSTANT: MS_DEF_DSS_PROV
+ "Microsoft Base DSS Cryptographic Provider"
+
+CONSTANT: MS_DEF_PROV
+ "Microsoft Base Cryptographic Provider v1.0"
+
+CONSTANT: MS_DEF_RSA_SCHANNEL_PROV
+ "Microsoft RSA Schannel Cryptographic Provider"
! Unsupported (!)
-: MS_DEF_RSA_SIG_PROV
- "Microsoft RSA Signature Cryptographic Provider" ; inline
+CONSTANT: MS_DEF_RSA_SIG_PROV
+ "Microsoft RSA Signature Cryptographic Provider"
-: MS_ENH_DSS_DH_PROV
- "Microsoft Enhanced DSS and Diffie-Hellman Cryptographic Provider" ; inline
+CONSTANT: MS_ENH_DSS_DH_PROV
+ "Microsoft Enhanced DSS and Diffie-Hellman Cryptographic Provider"
-: MS_ENH_RSA_AES_PROV
- "Microsoft Enhanced RSA and AES Cryptographic Provider" ; inline
+CONSTANT: MS_ENH_RSA_AES_PROV
+ "Microsoft Enhanced RSA and AES Cryptographic Provider"
-: MS_ENHANCED_PROV
- "Microsoft Enhanced Cryptographic Provider v1.0" ; inline
+CONSTANT: MS_ENHANCED_PROV
+ "Microsoft Enhanced Cryptographic Provider v1.0"
-: MS_SCARD_PROV
- "Microsoft Base Smart Card Crypto Provider" ; inline
+CONSTANT: MS_SCARD_PROV
+ "Microsoft Base Smart Card Crypto Provider"
-: MS_STRONG_PROV
- "Microsoft Strong Cryptographic Provider" ; inline
+CONSTANT: MS_STRONG_PROV
+ "Microsoft Strong Cryptographic Provider"
-: CRYPT_VERIFYCONTEXT HEX: F0000000 ; inline
-: CRYPT_NEWKEYSET HEX: 8 ; inline
-: CRYPT_DELETEKEYSET HEX: 10 ; inline
-: CRYPT_MACHINE_KEYSET HEX: 20 ; inline
-: CRYPT_SILENT HEX: 40 ; inline
+CONSTANT: CRYPT_VERIFYCONTEXT HEX: F0000000
+CONSTANT: CRYPT_NEWKEYSET HEX: 8
+CONSTANT: CRYPT_DELETEKEYSET HEX: 10
+CONSTANT: CRYPT_MACHINE_KEYSET HEX: 20
+CONSTANT: CRYPT_SILENT HEX: 40
C-STRUCT: ACL
{ "BYTE" "AclRevision" }
TYPEDEF: ACL* PACL
-: ACCESS_ALLOWED_ACE_TYPE 0 ; inline
-: ACCESS_DENIED_ACE_TYPE 1 ; inline
-: SYSTEM_AUDIT_ACE_TYPE 2 ; inline
-: SYSTEM_ALARM_ACE_TYPE 3 ; inline
+CONSTANT: ACCESS_ALLOWED_ACE_TYPE 0
+CONSTANT: ACCESS_DENIED_ACE_TYPE 1
+CONSTANT: SYSTEM_AUDIT_ACE_TYPE 2
+CONSTANT: SYSTEM_ALARM_ACE_TYPE 3
-: OBJECT_INHERIT_ACE HEX: 1 ; inline
-: CONTAINER_INHERIT_ACE HEX: 2 ; inline
-: NO_PROPAGATE_INHERIT_ACE HEX: 4 ; inline
-: INHERIT_ONLY_ACE HEX: 8 ; inline
-: VALID_INHERIT_FLAGS HEX: f ; inline
+CONSTANT: OBJECT_INHERIT_ACE HEX: 1
+CONSTANT: CONTAINER_INHERIT_ACE HEX: 2
+CONSTANT: NO_PROPAGATE_INHERIT_ACE HEX: 4
+CONSTANT: INHERIT_ONLY_ACE HEX: 8
+CONSTANT: VALID_INHERIT_FLAGS HEX: f
C-STRUCT: ACE_HEADER
{ "BYTE" "AceType" }
! typedef enum _TOKEN_INFORMATION_CLASS {
-: TokenUser 1 ; inline
-: TokenGroups 2 ; inline
-: TokenPrivileges 3 ; inline
-: TokenOwner 4 ; inline
-: TokenPrimaryGroup 5 ; inline
-: TokenDefaultDacl 6 ; inline
-: TokenSource 7 ; inline
-: TokenType 8 ; inline
-: TokenImpersonationLevel 9 ; inline
-: TokenStatistics 10 ; inline
-: TokenRestrictedSids 11 ; inline
-: TokenSessionId 12 ; inline
-: TokenGroupsAndPrivileges 13 ; inline
-: TokenSessionReference 14 ; inline
-: TokenSandBoxInert 15 ; inline
+CONSTANT: TokenUser 1
+CONSTANT: TokenGroups 2
+CONSTANT: TokenPrivileges 3
+CONSTANT: TokenOwner 4
+CONSTANT: TokenPrimaryGroup 5
+CONSTANT: TokenDefaultDacl 6
+CONSTANT: TokenSource 7
+CONSTANT: TokenType 8
+CONSTANT: TokenImpersonationLevel 9
+CONSTANT: TokenStatistics 10
+CONSTANT: TokenRestrictedSids 11
+CONSTANT: TokenSessionId 12
+CONSTANT: TokenGroupsAndPrivileges 13
+CONSTANT: TokenSessionReference 14
+CONSTANT: TokenSandBoxInert 15
! } TOKEN_INFORMATION_CLASS;
-: DELETE HEX: 00010000 ; inline
-: READ_CONTROL HEX: 00020000 ; inline
-: WRITE_DAC HEX: 00040000 ; inline
-: WRITE_OWNER HEX: 00080000 ; inline
-: SYNCHRONIZE HEX: 00100000 ; inline
-: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
-
-: STANDARD_RIGHTS_READ READ_CONTROL ; inline
-: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
-: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
-
-: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
-: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
-: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
-: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
-: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
-: TOKEN_DUPLICATE HEX: 0002 ; inline
-: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
-: TOKEN_IMPERSONATE HEX: 0004 ; inline
-: TOKEN_QUERY HEX: 0008 ; inline
-: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
-: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
-: TOKEN_READ ( -- n ) STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
+CONSTANT: DELETE HEX: 00010000
+CONSTANT: READ_CONTROL HEX: 00020000
+CONSTANT: WRITE_DAC HEX: 00040000
+CONSTANT: WRITE_OWNER HEX: 00080000
+CONSTANT: SYNCHRONIZE HEX: 00100000
+CONSTANT: STANDARD_RIGHTS_REQUIRED HEX: 000f0000
+
+ALIAS: STANDARD_RIGHTS_READ READ_CONTROL
+ALIAS: STANDARD_RIGHTS_WRITE READ_CONTROL
+ALIAS: STANDARD_RIGHTS_EXECUTE READ_CONTROL
+
+CONSTANT: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080
+CONSTANT: TOKEN_ADJUST_GROUPS HEX: 0040
+CONSTANT: TOKEN_ADJUST_PRIVILEGES HEX: 0020
+CONSTANT: TOKEN_ADJUST_SESSIONID HEX: 0100
+CONSTANT: TOKEN_ASSIGN_PRIMARY HEX: 0001
+CONSTANT: TOKEN_DUPLICATE HEX: 0002
+ALIAS: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE
+CONSTANT: TOKEN_IMPERSONATE HEX: 0004
+CONSTANT: TOKEN_QUERY HEX: 0008
+CONSTANT: TOKEN_QUERY_SOURCE HEX: 0010
+CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080
+: TOKEN_READ ( -- n ) { STANDARD_RIGHTS_READ TOKEN_QUERY } flags ;
: TOKEN_WRITE ( -- n )
{
: (make-callbacks) ( implementations -- sequence )
dup [ first ] map (make-iunknown-methods)
- [ >r >r first2 r> r> swap (make-interface-callbacks) ]
+ [ [ first2 ] 2dip swap (make-interface-callbacks) ]
curry map-index ;
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
USING: windows.dinput windows.kernel32 windows.ole32 windows.com
windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
-combinators sequences symbols fry math accessors macros words quotations
+combinators sequences fry math accessors macros words quotations
libc continuations generalizations splitting locals assocs init
struct-arrays ;
IN: windows.dinput.constants
FUNCTION: HRESULT DirectInput8Create ( HINSTANCE hinst, DWORD dwVersion, REFIID riidtlf, LPVOID* ppvOut, LPUNKNOWN punkOuter ) ;
-: DIRECTINPUT_VERSION HEX: 0800 ; inline
-
-: DI8DEVCLASS_ALL 0 ; inline
-: DI8DEVCLASS_DEVICE 1 ; inline
-: DI8DEVCLASS_POINTER 2 ; inline
-: DI8DEVCLASS_KEYBOARD 3 ; inline
-: DI8DEVCLASS_GAMECTRL 4 ; inline
-
-: DIEDFL_ALLDEVICES HEX: 00000000 ; inline
-: DIEDFL_ATTACHEDONLY HEX: 00000001 ; inline
-: DIEDFL_FORCEFEEDBACK HEX: 00000100 ; inline
-: DIEDFL_INCLUDEALIASES HEX: 00010000 ; inline
-: DIEDFL_INCLUDEPHANTOMS HEX: 00020000 ; inline
-: DIEDFL_INCLUDEHIDDEN HEX: 00040000 ; inline
-
-: DIENUM_STOP 0 ; inline
-: DIENUM_CONTINUE 1 ; inline
-
-: DIDF_ABSAXIS 1 ;
-: DIDF_RELAXIS 2 ;
-
-: DIDFT_ALL HEX: 00000000 ; inline
-
-: DIDFT_RELAXIS HEX: 00000001 ; inline
-: DIDFT_ABSAXIS HEX: 00000002 ; inline
-: DIDFT_AXIS HEX: 00000003 ; inline
-
-: DIDFT_PSHBUTTON HEX: 00000004 ; inline
-: DIDFT_TGLBUTTON HEX: 00000008 ; inline
-: DIDFT_BUTTON HEX: 0000000C ; inline
-
-: DIDFT_POV HEX: 00000010 ; inline
-: DIDFT_COLLECTION HEX: 00000040 ; inline
-: DIDFT_NODATA HEX: 00000080 ; inline
-
-: DIDFT_ANYINSTANCE HEX: 00FFFF00 ; inline
-: DIDFT_INSTANCEMASK DIDFT_ANYINSTANCE ; inline
+CONSTANT: DIRECTINPUT_VERSION HEX: 0800
+
+CONSTANT: DI8DEVCLASS_ALL 0
+CONSTANT: DI8DEVCLASS_DEVICE 1
+CONSTANT: DI8DEVCLASS_POINTER 2
+CONSTANT: DI8DEVCLASS_KEYBOARD 3
+CONSTANT: DI8DEVCLASS_GAMECTRL 4
+
+CONSTANT: DIEDFL_ALLDEVICES HEX: 00000000
+CONSTANT: DIEDFL_ATTACHEDONLY HEX: 00000001
+CONSTANT: DIEDFL_FORCEFEEDBACK HEX: 00000100
+CONSTANT: DIEDFL_INCLUDEALIASES HEX: 00010000
+CONSTANT: DIEDFL_INCLUDEPHANTOMS HEX: 00020000
+CONSTANT: DIEDFL_INCLUDEHIDDEN HEX: 00040000
+
+CONSTANT: DIENUM_STOP 0
+CONSTANT: DIENUM_CONTINUE 1
+
+CONSTANT: DIDF_ABSAXIS 1
+CONSTANT: DIDF_RELAXIS 2
+
+CONSTANT: DIDFT_ALL HEX: 00000000
+
+CONSTANT: DIDFT_RELAXIS HEX: 00000001
+CONSTANT: DIDFT_ABSAXIS HEX: 00000002
+CONSTANT: DIDFT_AXIS HEX: 00000003
+
+CONSTANT: DIDFT_PSHBUTTON HEX: 00000004
+CONSTANT: DIDFT_TGLBUTTON HEX: 00000008
+CONSTANT: DIDFT_BUTTON HEX: 0000000C
+
+CONSTANT: DIDFT_POV HEX: 00000010
+CONSTANT: DIDFT_COLLECTION HEX: 00000040
+CONSTANT: DIDFT_NODATA HEX: 00000080
+
+CONSTANT: DIDFT_ANYINSTANCE HEX: 00FFFF00
+ALIAS: DIDFT_INSTANCEMASK DIDFT_ANYINSTANCE
: DIDFT_MAKEINSTANCE ( n -- instance ) 8 shift ; inline
: DIDFT_GETTYPE ( n -- type ) HEX: FF bitand ; inline
: DIDFT_GETINSTANCE ( n -- instance ) -8 shift HEX: FFFF bitand ; inline
-: DIDFT_FFACTUATOR HEX: 01000000 ; inline
-: DIDFT_FFEFFECTTRIGGER HEX: 02000000 ; inline
-: DIDFT_OUTPUT HEX: 10000000 ; inline
-: DIDFT_VENDORDEFINED HEX: 04000000 ; inline
-: DIDFT_ALIAS HEX: 08000000 ; inline
-: DIDFT_OPTIONAL HEX: 80000000 ; inline
+CONSTANT: DIDFT_FFACTUATOR HEX: 01000000
+CONSTANT: DIDFT_FFEFFECTTRIGGER HEX: 02000000
+CONSTANT: DIDFT_OUTPUT HEX: 10000000
+CONSTANT: DIDFT_VENDORDEFINED HEX: 04000000
+CONSTANT: DIDFT_ALIAS HEX: 08000000
+CONSTANT: DIDFT_OPTIONAL HEX: 80000000
: DIDFT_ENUMCOLLECTION ( n -- instance ) 8 shift HEX: FFFF bitand ; inline
-: DIDFT_NOCOLLECTION HEX: 00FFFF00 ; inline
-
-: DIDOI_FFACTUATOR HEX: 00000001 ; inline
-: DIDOI_FFEFFECTTRIGGER HEX: 00000002 ; inline
-: DIDOI_POLLED HEX: 00008000 ; inline
-: DIDOI_ASPECTPOSITION HEX: 00000100 ; inline
-: DIDOI_ASPECTVELOCITY HEX: 00000200 ; inline
-: DIDOI_ASPECTACCEL HEX: 00000300 ; inline
-: DIDOI_ASPECTFORCE HEX: 00000400 ; inline
-: DIDOI_ASPECTMASK HEX: 00000F00 ; inline
-: DIDOI_GUIDISUSAGE HEX: 00010000 ; inline
-
-: DISCL_EXCLUSIVE HEX: 00000001 ; inline
-: DISCL_NONEXCLUSIVE HEX: 00000002 ; inline
-: DISCL_FOREGROUND HEX: 00000004 ; inline
-: DISCL_BACKGROUND HEX: 00000008 ; inline
-: DISCL_NOWINKEY HEX: 00000010 ; inline
-
-: DIK_ESCAPE HEX: 01 ; inline
-: DIK_1 HEX: 02 ; inline
-: DIK_2 HEX: 03 ; inline
-: DIK_3 HEX: 04 ; inline
-: DIK_4 HEX: 05 ; inline
-: DIK_5 HEX: 06 ; inline
-: DIK_6 HEX: 07 ; inline
-: DIK_7 HEX: 08 ; inline
-: DIK_8 HEX: 09 ; inline
-: DIK_9 HEX: 0A ; inline
-: DIK_0 HEX: 0B ; inline
-: DIK_MINUS HEX: 0C ; inline
-: DIK_EQUALS HEX: 0D ; inline
-: DIK_BACK HEX: 0E ; inline
-: DIK_TAB HEX: 0F ; inline
-: DIK_Q HEX: 10 ; inline
-: DIK_W HEX: 11 ; inline
-: DIK_E HEX: 12 ; inline
-: DIK_R HEX: 13 ; inline
-: DIK_T HEX: 14 ; inline
-: DIK_Y HEX: 15 ; inline
-: DIK_U HEX: 16 ; inline
-: DIK_I HEX: 17 ; inline
-: DIK_O HEX: 18 ; inline
-: DIK_P HEX: 19 ; inline
-: DIK_LBRACKET HEX: 1A ; inline
-: DIK_RBRACKET HEX: 1B ; inline
-: DIK_RETURN HEX: 1C ; inline
-: DIK_LCONTROL HEX: 1D ; inline
-: DIK_A HEX: 1E ; inline
-: DIK_S HEX: 1F ; inline
-: DIK_D HEX: 20 ; inline
-: DIK_F HEX: 21 ; inline
-: DIK_G HEX: 22 ; inline
-: DIK_H HEX: 23 ; inline
-: DIK_J HEX: 24 ; inline
-: DIK_K HEX: 25 ; inline
-: DIK_L HEX: 26 ; inline
-: DIK_SEMICOLON HEX: 27 ; inline
-: DIK_APOSTROPHE HEX: 28 ; inline
-: DIK_GRAVE HEX: 29 ; inline
-: DIK_LSHIFT HEX: 2A ; inline
-: DIK_BACKSLASH HEX: 2B ; inline
-: DIK_Z HEX: 2C ; inline
-: DIK_X HEX: 2D ; inline
-: DIK_C HEX: 2E ; inline
-: DIK_V HEX: 2F ; inline
-: DIK_B HEX: 30 ; inline
-: DIK_N HEX: 31 ; inline
-: DIK_M HEX: 32 ; inline
-: DIK_COMMA HEX: 33 ; inline
-: DIK_PERIOD HEX: 34 ; inline
-: DIK_SLASH HEX: 35 ; inline
-: DIK_RSHIFT HEX: 36 ; inline
-: DIK_MULTIPLY HEX: 37 ; inline
-: DIK_LMENU HEX: 38 ; inline
-: DIK_SPACE HEX: 39 ; inline
-: DIK_CAPITAL HEX: 3A ; inline
-: DIK_F1 HEX: 3B ; inline
-: DIK_F2 HEX: 3C ; inline
-: DIK_F3 HEX: 3D ; inline
-: DIK_F4 HEX: 3E ; inline
-: DIK_F5 HEX: 3F ; inline
-: DIK_F6 HEX: 40 ; inline
-: DIK_F7 HEX: 41 ; inline
-: DIK_F8 HEX: 42 ; inline
-: DIK_F9 HEX: 43 ; inline
-: DIK_F10 HEX: 44 ; inline
-: DIK_NUMLOCK HEX: 45 ; inline
-: DIK_SCROLL HEX: 46 ; inline
-: DIK_NUMPAD7 HEX: 47 ; inline
-: DIK_NUMPAD8 HEX: 48 ; inline
-: DIK_NUMPAD9 HEX: 49 ; inline
-: DIK_SUBTRACT HEX: 4A ; inline
-: DIK_NUMPAD4 HEX: 4B ; inline
-: DIK_NUMPAD5 HEX: 4C ; inline
-: DIK_NUMPAD6 HEX: 4D ; inline
-: DIK_ADD HEX: 4E ; inline
-: DIK_NUMPAD1 HEX: 4F ; inline
-: DIK_NUMPAD2 HEX: 50 ; inline
-: DIK_NUMPAD3 HEX: 51 ; inline
-: DIK_NUMPAD0 HEX: 52 ; inline
-: DIK_DECIMAL HEX: 53 ; inline
-: DIK_OEM_102 HEX: 56 ; inline
-: DIK_F11 HEX: 57 ; inline
-: DIK_F12 HEX: 58 ; inline
-: DIK_F13 HEX: 64 ; inline
-: DIK_F14 HEX: 65 ; inline
-: DIK_F15 HEX: 66 ; inline
-: DIK_KANA HEX: 70 ; inline
-: DIK_ABNT_C1 HEX: 73 ; inline
-: DIK_CONVERT HEX: 79 ; inline
-: DIK_NOCONVERT HEX: 7B ; inline
-: DIK_YEN HEX: 7D ; inline
-: DIK_ABNT_C2 HEX: 7E ; inline
-: DIK_NUMPADEQUALS HEX: 8D ; inline
-: DIK_PREVTRACK HEX: 90 ; inline
-: DIK_AT HEX: 91 ; inline
-: DIK_COLON HEX: 92 ; inline
-: DIK_UNDERLINE HEX: 93 ; inline
-: DIK_KANJI HEX: 94 ; inline
-: DIK_STOP HEX: 95 ; inline
-: DIK_AX HEX: 96 ; inline
-: DIK_UNLABELED HEX: 97 ; inline
-: DIK_NEXTTRACK HEX: 99 ; inline
-: DIK_NUMPADENTER HEX: 9C ; inline
-: DIK_RCONTROL HEX: 9D ; inline
-: DIK_MUTE HEX: A0 ; inline
-: DIK_CALCULATOR HEX: A1 ; inline
-: DIK_PLAYPAUSE HEX: A2 ; inline
-: DIK_MEDIASTOP HEX: A4 ; inline
-: DIK_VOLUMEDOWN HEX: AE ; inline
-: DIK_VOLUMEUP HEX: B0 ; inline
-: DIK_WEBHOME HEX: B2 ; inline
-: DIK_NUMPADCOMMA HEX: B3 ; inline
-: DIK_DIVIDE HEX: B5 ; inline
-: DIK_SYSRQ HEX: B7 ; inline
-: DIK_RMENU HEX: B8 ; inline
-: DIK_PAUSE HEX: C5 ; inline
-: DIK_HOME HEX: C7 ; inline
-: DIK_UP HEX: C8 ; inline
-: DIK_PRIOR HEX: C9 ; inline
-: DIK_LEFT HEX: CB ; inline
-: DIK_RIGHT HEX: CD ; inline
-: DIK_END HEX: CF ; inline
-: DIK_DOWN HEX: D0 ; inline
-: DIK_NEXT HEX: D1 ; inline
-: DIK_INSERT HEX: D2 ; inline
-: DIK_DELETE HEX: D3 ; inline
-: DIK_LWIN HEX: DB ; inline
-: DIK_RWIN HEX: DC ; inline
-: DIK_APPS HEX: DD ; inline
-: DIK_POWER HEX: DE ; inline
-: DIK_SLEEP HEX: DF ; inline
-: DIK_WAKE HEX: E3 ; inline
-: DIK_WEBSEARCH HEX: E5 ; inline
-: DIK_WEBFAVORITES HEX: E6 ; inline
-: DIK_WEBREFRESH HEX: E7 ; inline
-: DIK_WEBSTOP HEX: E8 ; inline
-: DIK_WEBFORWARD HEX: E9 ; inline
-: DIK_WEBBACK HEX: EA ; inline
-: DIK_MYCOMPUTER HEX: EB ; inline
-: DIK_MAIL HEX: EC ; inline
-: DIK_MEDIASELECT HEX: ED ; inline
-
-: DIK_BACKSPACE DIK_BACK ; inline
-: DIK_NUMPADSTAR DIK_MULTIPLY ; inline
-: DIK_LALT DIK_LMENU ; inline
-: DIK_CAPSLOCK DIK_CAPITAL ; inline
-: DIK_NUMPADMINUS DIK_SUBTRACT ; inline
-: DIK_NUMPADPLUS DIK_ADD ; inline
-: DIK_NUMPADPERIOD DIK_DECIMAL ; inline
-: DIK_NUMPADSLASH DIK_DIVIDE ; inline
-: DIK_RALT DIK_RMENU ; inline
-: DIK_UPARROW DIK_UP ; inline
-: DIK_PGUP DIK_PRIOR ; inline
-: DIK_LEFTARROW DIK_LEFT ; inline
-: DIK_RIGHTARROW DIK_RIGHT ; inline
-: DIK_DOWNARROW DIK_DOWN ; inline
-: DIK_PGDN DIK_NEXT ; inline
-
-: DIK_CIRCUMFLEX DIK_PREVTRACK ; inline
-
-: DI8DEVTYPE_DEVICE HEX: 11 ; inline
-: DI8DEVTYPE_MOUSE HEX: 12 ; inline
-: DI8DEVTYPE_KEYBOARD HEX: 13 ; inline
-: DI8DEVTYPE_JOYSTICK HEX: 14 ; inline
-: DI8DEVTYPE_GAMEPAD HEX: 15 ; inline
-: DI8DEVTYPE_DRIVING HEX: 16 ; inline
-: DI8DEVTYPE_FLIGHT HEX: 17 ; inline
-: DI8DEVTYPE_1STPERSON HEX: 18 ; inline
-: DI8DEVTYPE_DEVICECTRL HEX: 19 ; inline
-: DI8DEVTYPE_SCREENPOINTER HEX: 1A ; inline
-: DI8DEVTYPE_REMOTE HEX: 1B ; inline
-: DI8DEVTYPE_SUPPLEMENTAL HEX: 1C ; inline
+CONSTANT: DIDFT_NOCOLLECTION HEX: 00FFFF00
+
+CONSTANT: DIDOI_FFACTUATOR HEX: 00000001
+CONSTANT: DIDOI_FFEFFECTTRIGGER HEX: 00000002
+CONSTANT: DIDOI_POLLED HEX: 00008000
+CONSTANT: DIDOI_ASPECTPOSITION HEX: 00000100
+CONSTANT: DIDOI_ASPECTVELOCITY HEX: 00000200
+CONSTANT: DIDOI_ASPECTACCEL HEX: 00000300
+CONSTANT: DIDOI_ASPECTFORCE HEX: 00000400
+CONSTANT: DIDOI_ASPECTMASK HEX: 00000F00
+CONSTANT: DIDOI_GUIDISUSAGE HEX: 00010000
+
+CONSTANT: DISCL_EXCLUSIVE HEX: 00000001
+CONSTANT: DISCL_NONEXCLUSIVE HEX: 00000002
+CONSTANT: DISCL_FOREGROUND HEX: 00000004
+CONSTANT: DISCL_BACKGROUND HEX: 00000008
+CONSTANT: DISCL_NOWINKEY HEX: 00000010
+
+CONSTANT: DIK_ESCAPE HEX: 01
+CONSTANT: DIK_1 HEX: 02
+CONSTANT: DIK_2 HEX: 03
+CONSTANT: DIK_3 HEX: 04
+CONSTANT: DIK_4 HEX: 05
+CONSTANT: DIK_5 HEX: 06
+CONSTANT: DIK_6 HEX: 07
+CONSTANT: DIK_7 HEX: 08
+CONSTANT: DIK_8 HEX: 09
+CONSTANT: DIK_9 HEX: 0A
+CONSTANT: DIK_0 HEX: 0B
+CONSTANT: DIK_MINUS HEX: 0C
+CONSTANT: DIK_EQUALS HEX: 0D
+CONSTANT: DIK_BACK HEX: 0E
+CONSTANT: DIK_TAB HEX: 0F
+CONSTANT: DIK_Q HEX: 10
+CONSTANT: DIK_W HEX: 11
+CONSTANT: DIK_E HEX: 12
+CONSTANT: DIK_R HEX: 13
+CONSTANT: DIK_T HEX: 14
+CONSTANT: DIK_Y HEX: 15
+CONSTANT: DIK_U HEX: 16
+CONSTANT: DIK_I HEX: 17
+CONSTANT: DIK_O HEX: 18
+CONSTANT: DIK_P HEX: 19
+CONSTANT: DIK_LBRACKET HEX: 1A
+CONSTANT: DIK_RBRACKET HEX: 1B
+CONSTANT: DIK_RETURN HEX: 1C
+CONSTANT: DIK_LCONTROL HEX: 1D
+CONSTANT: DIK_A HEX: 1E
+CONSTANT: DIK_S HEX: 1F
+CONSTANT: DIK_D HEX: 20
+CONSTANT: DIK_F HEX: 21
+CONSTANT: DIK_G HEX: 22
+CONSTANT: DIK_H HEX: 23
+CONSTANT: DIK_J HEX: 24
+CONSTANT: DIK_K HEX: 25
+CONSTANT: DIK_L HEX: 26
+CONSTANT: DIK_SEMICOLON HEX: 27
+CONSTANT: DIK_APOSTROPHE HEX: 28
+CONSTANT: DIK_GRAVE HEX: 29
+CONSTANT: DIK_LSHIFT HEX: 2A
+CONSTANT: DIK_BACKSLASH HEX: 2B
+CONSTANT: DIK_Z HEX: 2C
+CONSTANT: DIK_X HEX: 2D
+CONSTANT: DIK_C HEX: 2E
+CONSTANT: DIK_V HEX: 2F
+CONSTANT: DIK_B HEX: 30
+CONSTANT: DIK_N HEX: 31
+CONSTANT: DIK_M HEX: 32
+CONSTANT: DIK_COMMA HEX: 33
+CONSTANT: DIK_PERIOD HEX: 34
+CONSTANT: DIK_SLASH HEX: 35
+CONSTANT: DIK_RSHIFT HEX: 36
+CONSTANT: DIK_MULTIPLY HEX: 37
+CONSTANT: DIK_LMENU HEX: 38
+CONSTANT: DIK_SPACE HEX: 39
+CONSTANT: DIK_CAPITAL HEX: 3A
+CONSTANT: DIK_F1 HEX: 3B
+CONSTANT: DIK_F2 HEX: 3C
+CONSTANT: DIK_F3 HEX: 3D
+CONSTANT: DIK_F4 HEX: 3E
+CONSTANT: DIK_F5 HEX: 3F
+CONSTANT: DIK_F6 HEX: 40
+CONSTANT: DIK_F7 HEX: 41
+CONSTANT: DIK_F8 HEX: 42
+CONSTANT: DIK_F9 HEX: 43
+CONSTANT: DIK_F10 HEX: 44
+CONSTANT: DIK_NUMLOCK HEX: 45
+CONSTANT: DIK_SCROLL HEX: 46
+CONSTANT: DIK_NUMPAD7 HEX: 47
+CONSTANT: DIK_NUMPAD8 HEX: 48
+CONSTANT: DIK_NUMPAD9 HEX: 49
+CONSTANT: DIK_SUBTRACT HEX: 4A
+CONSTANT: DIK_NUMPAD4 HEX: 4B
+CONSTANT: DIK_NUMPAD5 HEX: 4C
+CONSTANT: DIK_NUMPAD6 HEX: 4D
+CONSTANT: DIK_ADD HEX: 4E
+CONSTANT: DIK_NUMPAD1 HEX: 4F
+CONSTANT: DIK_NUMPAD2 HEX: 50
+CONSTANT: DIK_NUMPAD3 HEX: 51
+CONSTANT: DIK_NUMPAD0 HEX: 52
+CONSTANT: DIK_DECIMAL HEX: 53
+CONSTANT: DIK_OEM_102 HEX: 56
+CONSTANT: DIK_F11 HEX: 57
+CONSTANT: DIK_F12 HEX: 58
+CONSTANT: DIK_F13 HEX: 64
+CONSTANT: DIK_F14 HEX: 65
+CONSTANT: DIK_F15 HEX: 66
+CONSTANT: DIK_KANA HEX: 70
+CONSTANT: DIK_ABNT_C1 HEX: 73
+CONSTANT: DIK_CONVERT HEX: 79
+CONSTANT: DIK_NOCONVERT HEX: 7B
+CONSTANT: DIK_YEN HEX: 7D
+CONSTANT: DIK_ABNT_C2 HEX: 7E
+CONSTANT: DIK_NUMPADEQUALS HEX: 8D
+CONSTANT: DIK_PREVTRACK HEX: 90
+CONSTANT: DIK_AT HEX: 91
+CONSTANT: DIK_COLON HEX: 92
+CONSTANT: DIK_UNDERLINE HEX: 93
+CONSTANT: DIK_KANJI HEX: 94
+CONSTANT: DIK_STOP HEX: 95
+CONSTANT: DIK_AX HEX: 96
+CONSTANT: DIK_UNLABELED HEX: 97
+CONSTANT: DIK_NEXTTRACK HEX: 99
+CONSTANT: DIK_NUMPADENTER HEX: 9C
+CONSTANT: DIK_RCONTROL HEX: 9D
+CONSTANT: DIK_MUTE HEX: A0
+CONSTANT: DIK_CALCULATOR HEX: A1
+CONSTANT: DIK_PLAYPAUSE HEX: A2
+CONSTANT: DIK_MEDIASTOP HEX: A4
+CONSTANT: DIK_VOLUMEDOWN HEX: AE
+CONSTANT: DIK_VOLUMEUP HEX: B0
+CONSTANT: DIK_WEBHOME HEX: B2
+CONSTANT: DIK_NUMPADCOMMA HEX: B3
+CONSTANT: DIK_DIVIDE HEX: B5
+CONSTANT: DIK_SYSRQ HEX: B7
+CONSTANT: DIK_RMENU HEX: B8
+CONSTANT: DIK_PAUSE HEX: C5
+CONSTANT: DIK_HOME HEX: C7
+CONSTANT: DIK_UP HEX: C8
+CONSTANT: DIK_PRIOR HEX: C9
+CONSTANT: DIK_LEFT HEX: CB
+CONSTANT: DIK_RIGHT HEX: CD
+CONSTANT: DIK_END HEX: CF
+CONSTANT: DIK_DOWN HEX: D0
+CONSTANT: DIK_NEXT HEX: D1
+CONSTANT: DIK_INSERT HEX: D2
+CONSTANT: DIK_DELETE HEX: D3
+CONSTANT: DIK_LWIN HEX: DB
+CONSTANT: DIK_RWIN HEX: DC
+CONSTANT: DIK_APPS HEX: DD
+CONSTANT: DIK_POWER HEX: DE
+CONSTANT: DIK_SLEEP HEX: DF
+CONSTANT: DIK_WAKE HEX: E3
+CONSTANT: DIK_WEBSEARCH HEX: E5
+CONSTANT: DIK_WEBFAVORITES HEX: E6
+CONSTANT: DIK_WEBREFRESH HEX: E7
+CONSTANT: DIK_WEBSTOP HEX: E8
+CONSTANT: DIK_WEBFORWARD HEX: E9
+CONSTANT: DIK_WEBBACK HEX: EA
+CONSTANT: DIK_MYCOMPUTER HEX: EB
+CONSTANT: DIK_MAIL HEX: EC
+CONSTANT: DIK_MEDIASELECT HEX: ED
+
+ALIAS: DIK_BACKSPACE DIK_BACK
+ALIAS: DIK_NUMPADSTAR DIK_MULTIPLY
+ALIAS: DIK_LALT DIK_LMENU
+ALIAS: DIK_CAPSLOCK DIK_CAPITAL
+ALIAS: DIK_NUMPADMINUS DIK_SUBTRACT
+ALIAS: DIK_NUMPADPLUS DIK_ADD
+ALIAS: DIK_NUMPADPERIOD DIK_DECIMAL
+ALIAS: DIK_NUMPADSLASH DIK_DIVIDE
+ALIAS: DIK_RALT DIK_RMENU
+ALIAS: DIK_UPARROW DIK_UP
+ALIAS: DIK_PGUP DIK_PRIOR
+ALIAS: DIK_LEFTARROW DIK_LEFT
+ALIAS: DIK_RIGHTARROW DIK_RIGHT
+ALIAS: DIK_DOWNARROW DIK_DOWN
+ALIAS: DIK_PGDN DIK_NEXT
+
+ALIAS: DIK_CIRCUMFLEX DIK_PREVTRACK
+
+CONSTANT: DI8DEVTYPE_DEVICE HEX: 11
+CONSTANT: DI8DEVTYPE_MOUSE HEX: 12
+CONSTANT: DI8DEVTYPE_KEYBOARD HEX: 13
+CONSTANT: DI8DEVTYPE_JOYSTICK HEX: 14
+CONSTANT: DI8DEVTYPE_GAMEPAD HEX: 15
+CONSTANT: DI8DEVTYPE_DRIVING HEX: 16
+CONSTANT: DI8DEVTYPE_FLIGHT HEX: 17
+CONSTANT: DI8DEVTYPE_1STPERSON HEX: 18
+CONSTANT: DI8DEVTYPE_DEVICECTRL HEX: 19
+CONSTANT: DI8DEVTYPE_SCREENPOINTER HEX: 1A
+CONSTANT: DI8DEVTYPE_REMOTE HEX: 1B
+CONSTANT: DI8DEVTYPE_SUPPLEMENTAL HEX: 1C
: GET_DIDEVICE_TYPE ( dwType -- type ) HEX: FF bitand ; inline
-: DIPROPRANGE_NOMIN HEX: 80000000 ; inline
-: DIPROPRANGE_NOMAX HEX: 7FFFFFFF ; inline
-: MAXCPOINTSNUM 8 ; inline
-
-: DIPH_DEVICE 0 ; inline
-: DIPH_BYOFFSET 1 ; inline
-: DIPH_BYID 2 ; inline
-: DIPH_BYUSAGE 3 ; inline
+CONSTANT: DIPROPRANGE_NOMIN HEX: 80000000
+CONSTANT: DIPROPRANGE_NOMAX HEX: 7FFFFFFF
+CONSTANT: MAXCPOINTSNUM 8
+CONSTANT: DIPH_DEVICE 0
+CONSTANT: DIPH_BYOFFSET 1
+CONSTANT: DIPH_BYID 2
+CONSTANT: DIPH_BYUSAGE 3
+
: DIMAKEUSAGEDWORD ( UsagePage Usage -- DWORD ) 16 shift bitor ; inline
-: DIPROP_BUFFERSIZE
1 <alien> ; inline
-: DIPROP_AXISMODE
2 <alien> ; inline
-
-: DIPROPAXISMODE_ABS 0 ; inline
-: DIPROPAXISMODE_REL 1 ; inline
-
-: DIPROP_GRANULARITY
3 <alien> ; inline
-: DIPROP_RANGE
4 <alien> ; inline
-: DIPROP_DEADZONE
5 <alien> ; inline
-: DIPROP_SATURATION
6 <alien> ; inline
-: DIPROP_FFGAIN
7 <alien> ; inline
-: DIPROP_FFLOAD
8 <alien> ; inline
-: DIPROP_AUTOCENTER
9 <alien> ; inline
-
-: DIPROPAUTOCENTER_OFF 0 ; inline
-: DIPROPAUTOCENTER_ON 1 ; inline
-
-: DIPROP_CALIBRATIONMODE
10 <alien> ; inline
-
-: DIPROPCALIBRATIONMODE_COOKED 0 ; inline
-: DIPROPCALIBRATIONMODE_RAW 1 ; inline
-
-: DIPROP_CALIBRATION 11 <alien> ; inline
-: DIPROP_GUIDANDPATH 12 <alien> ; inline
-: DIPROP_INSTANCENAME 13 <alien> ; inline
-: DIPROP_PRODUCTNAME 14 <alien> ; inline
-: DIPROP_JOYSTICKID 15 <alien> ; inline
-: DIPROP_GETPORTDISPLAYNAME 16 <alien> ; inline
-: DIPROP_PHYSICALRANGE 18 <alien> ; inline
-: DIPROP_LOGICALRANGE 19 <alien> ; inline
-: DIPROP_KEYNAME 20 <alien> ; inline
-: DIPROP_CPOINTS 21 <alien> ; inline
-: DIPROP_APPDATA 22 <alien> ; inline
-: DIPROP_SCANCODE 23 <alien> ; inline
-: DIPROP_VIDPID 24 <alien> ; inline
-: DIPROP_USERNAME 25 <alien> ; inline
-: DIPROP_TYPENAME 26 <alien> ; inline
-
-: GUID_XAxis GUID: {A36D02E0-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_YAxis GUID: {A36D02E1-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_ZAxis GUID: {A36D02E2-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_RxAxis GUID: {A36D02F4-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_RyAxis GUID: {A36D02F5-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_RzAxis GUID: {A36D02E3-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_Slider GUID: {A36D02E4-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_Button GUID: {A36D02F0-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_Key GUID: {55728220-D33C-11CF-BFC7-444553540000} ; inline
-: GUID_POV GUID: {A36D02F2-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_Unknown GUID: {A36D02F3-C9F3-11CF-BFC7-444553540000} ; inline
-: GUID_SysMouse GUID: {6F1D2B60-D5A0-11CF-BFC7-444553540000} ; inline
-: GUID_SysKeyboard GUID: {6F1D2B61-D5A0-11CF-BFC7-444553540000} ; inline
-: GUID_Joystick GUID: {6F1D2B70-D5A0-11CF-BFC7-444553540000} ; inline
-: GUID_SysMouseEm GUID: {6F1D2B80-D5A0-11CF-BFC7-444553540000} ; inline
-: GUID_SysMouseEm2 GUID: {6F1D2B81-D5A0-11CF-BFC7-444553540000} ; inline
-: GUID_SysKeyboardEm GUID: {6F1D2B82-D5A0-11CF-BFC7-444553540000} ; inline
-: GUID_SysKeyboardEm2 GUID: {6F1D2B83-D5A0-11CF-BFC7-444553540000} ; inline
+: DIPROP_BUFFERSIZE
( -- alien ) 1 <alien> ; inline
+: DIPROP_AXISMODE
( -- alien ) 2 <alien> ; inline
+
+CONSTANT: DIPROPAXISMODE_ABS 0
+CONSTANT: DIPROPAXISMODE_REL 1
+
+: DIPROP_GRANULARITY
( -- alien ) 3 <alien> ; inline
+: DIPROP_RANGE
( -- alien ) 4 <alien> ; inline
+: DIPROP_DEADZONE
( -- alien ) 5 <alien> ; inline
+: DIPROP_SATURATION
( -- alien ) 6 <alien> ; inline
+: DIPROP_FFGAIN
( -- alien ) 7 <alien> ; inline
+: DIPROP_FFLOAD
( -- alien ) 8 <alien> ; inline
+: DIPROP_AUTOCENTER
( -- alien ) 9 <alien> ; inline
+
+CONSTANT: DIPROPAUTOCENTER_OFF 0
+CONSTANT: DIPROPAUTOCENTER_ON 1
+
+: DIPROP_CALIBRATIONMODE
( -- alien ) 10 <alien> ; inline
+
+CONSTANT: DIPROPCALIBRATIONMODE_COOKED 0
+CONSTANT: DIPROPCALIBRATIONMODE_RAW 1
+
+: DIPROP_CALIBRATION
( -- alien ) 11 <alien> ; inline
+: DIPROP_GUIDANDPATH
( -- alien ) 12 <alien> ; inline
+: DIPROP_INSTANCENAME
( -- alien ) 13 <alien> ; inline
+: DIPROP_PRODUCTNAME
( -- alien ) 14 <alien> ; inline
+: DIPROP_JOYSTICKID
( -- alien ) 15 <alien> ; inline
+: DIPROP_GETPORTDISPLAYNAME
( -- alien ) 16 <alien> ; inline
+: DIPROP_PHYSICALRANGE
( -- alien ) 18 <alien> ; inline
+: DIPROP_LOGICALRANGE
( -- alien ) 19 <alien> ; inline
+: DIPROP_KEYNAME
( -- alien ) 20 <alien> ; inline
+: DIPROP_CPOINTS
( -- alien ) 21 <alien> ; inline
+: DIPROP_APPDATA
( -- alien ) 22 <alien> ; inline
+: DIPROP_SCANCODE
( -- alien ) 23 <alien> ; inline
+: DIPROP_VIDPID
( -- alien ) 24 <alien> ; inline
+: DIPROP_USERNAME
( -- alien ) 25 <alien> ; inline
+: DIPROP_TYPENAME
( -- alien ) 26 <alien> ; inline
+
+CONSTANT: GUID_XAxis GUID: {A36D02E0-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_YAxis GUID: {A36D02E1-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_ZAxis GUID: {A36D02E2-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_RxAxis GUID: {A36D02F4-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_RyAxis GUID: {A36D02F5-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_RzAxis GUID: {A36D02E3-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_Slider GUID: {A36D02E4-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_Button GUID: {A36D02F0-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_Key GUID: {55728220-D33C-11CF-BFC7-444553540000}
+CONSTANT: GUID_POV GUID: {A36D02F2-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_Unknown GUID: {A36D02F3-C9F3-11CF-BFC7-444553540000}
+CONSTANT: GUID_SysMouse GUID: {6F1D2B60-D5A0-11CF-BFC7-444553540000}
+CONSTANT: GUID_SysKeyboard GUID: {6F1D2B61-D5A0-11CF-BFC7-444553540000}
+CONSTANT: GUID_Joystick GUID: {6F1D2B70-D5A0-11CF-BFC7-444553540000}
+CONSTANT: GUID_SysMouseEm GUID: {6F1D2B80-D5A0-11CF-BFC7-444553540000}
+CONSTANT: GUID_SysMouseEm2 GUID: {6F1D2B81-D5A0-11CF-BFC7-444553540000}
+CONSTANT: GUID_SysKeyboardEm GUID: {6F1D2B82-D5A0-11CF-BFC7-444553540000}
+CONSTANT: GUID_SysKeyboardEm2 GUID: {6F1D2B83-D5A0-11CF-BFC7-444553540000}
-USING: kernel ;
IN: windows.errors
-: ERROR_SUCCESS 0 ; inline
-: ERROR_NO_MORE_FILES 18 ; inline
-: ERROR_HANDLE_EOF 38 ; inline
-: ERROR_BROKEN_PIPE 109 ; inline
-: ERROR_ENVVAR_NOT_FOUND 203 ; inline
-: ERROR_IO_INCOMPLETE 996 ; inline
-: ERROR_IO_PENDING 997 ; inline
+CONSTANT: ERROR_SUCCESS 0
+CONSTANT: ERROR_NO_MORE_FILES 18
+CONSTANT: ERROR_HANDLE_EOF 38
+CONSTANT: ERROR_BROKEN_PIPE 109
+CONSTANT: ERROR_ENVVAR_NOT_FOUND 203
+CONSTANT: ERROR_IO_INCOMPLETE 996
+CONSTANT: ERROR_IO_PENDING 997
! FUNCTION: AbortDoc
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types alias ;
+USING: alien alien.syntax kernel windows.types ;
IN: windows.gdi32
! Stock Logical Objects
-: WHITE_BRUSH 0 ; inline
-: LTGRAY_BRUSH 1 ; inline
-: GRAY_BRUSH 2 ; inline
-: DKGRAY_BRUSH 3 ; inline
-: BLACK_BRUSH 4 ; inline
-: NULL_BRUSH 5 ; inline
-: HOLLOW_BRUSH NULL_BRUSH ; inline
-: WHITE_PEN 6 ; inline
-: BLACK_PEN 7 ; inline
-: NULL_PEN 8 ; inline
-: OEM_FIXED_FONT 10 ; inline
-: ANSI_FIXED_FONT 11 ; inline
-: ANSI_VAR_FONT 12 ; inline
-: SYSTEM_FONT 13 ; inline
-: DEVICE_DEFAULT_FONT 14 ; inline
-: DEFAULT_PALETTE 15 ; inline
-: SYSTEM_FIXED_FONT 16 ; inline
-: DEFAULT_GUI_FONT 17 ; inline
-: DC_BRUSH 18 ; inline
-: DC_PEN 19 ; inline
+CONSTANT: WHITE_BRUSH 0
+CONSTANT: LTGRAY_BRUSH 1
+CONSTANT: GRAY_BRUSH 2
+CONSTANT: DKGRAY_BRUSH 3
+CONSTANT: BLACK_BRUSH 4
+CONSTANT: NULL_BRUSH 5
+ALIAS: HOLLOW_BRUSH NULL_BRUSH
+CONSTANT: WHITE_PEN 6
+CONSTANT: BLACK_PEN 7
+CONSTANT: NULL_PEN 8
+CONSTANT: OEM_FIXED_FONT 10
+CONSTANT: ANSI_FIXED_FONT 11
+CONSTANT: ANSI_VAR_FONT 12
+CONSTANT: SYSTEM_FONT 13
+CONSTANT: DEVICE_DEFAULT_FONT 14
+CONSTANT: DEFAULT_PALETTE 15
+CONSTANT: SYSTEM_FIXED_FONT 16
+CONSTANT: DEFAULT_GUI_FONT 17
+CONSTANT: DC_BRUSH 18
+CONSTANT: DC_PEN 19
+
+CONSTANT: BI_RGB 0
+CONSTANT: BI_RLE8 1
+CONSTANT: BI_RLE4 2
+CONSTANT: BI_BITFIELDS 3
-: BI_RGB 0 ; inline
-: BI_RLE8 1 ; inline
-: BI_RLE4 2 ; inline
-: BI_BITFIELDS 3 ; inline
-
-: DIB_RGB_COLORS 0 ; inline
-: DIB_PAL_COLORS 1 ; inline
+CONSTANT: DIB_RGB_COLORS 0
+CONSTANT: DIB_PAL_COLORS 1
LIBRARY: gdi32
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types alias ;
+USING: alien alien.syntax kernel windows.types ;
IN: windows.kernel32
-: MAX_PATH 260 ; inline
+CONSTANT: MAX_PATH 260
-: GHND HEX: 40 ; inline
-: GMEM_FIXED 0 ; inline
-: GMEM_MOVEABLE 2 ; inline
-: GMEM_ZEROINIT HEX: 40 ; inline
-: GPTR HEX: 40 ; inline
+CONSTANT: GHND HEX: 40
+CONSTANT: GMEM_FIXED 0
+CONSTANT: GMEM_MOVEABLE 2
+CONSTANT: GMEM_ZEROINIT HEX: 40
+CONSTANT: GPTR HEX: 40
-: GENERIC_READ HEX: 80000000 ; inline
-: GENERIC_WRITE HEX: 40000000 ; inline
-: GENERIC_EXECUTE HEX: 20000000 ; inline
-: GENERIC_ALL HEX: 10000000 ; inline
+CONSTANT: GENERIC_READ HEX: 80000000
+CONSTANT: GENERIC_WRITE HEX: 40000000
+CONSTANT: GENERIC_EXECUTE HEX: 20000000
+CONSTANT: GENERIC_ALL HEX: 10000000
-: CREATE_NEW 1 ; inline
-: CREATE_ALWAYS 2 ; inline
-: OPEN_EXISTING 3 ; inline
-: OPEN_ALWAYS 4 ; inline
-: TRUNCATE_EXISTING 5 ; inline
+CONSTANT: CREATE_NEW 1
+CONSTANT: CREATE_ALWAYS 2
+CONSTANT: OPEN_EXISTING 3
+CONSTANT: OPEN_ALWAYS 4
+CONSTANT: TRUNCATE_EXISTING 5
-: FILE_LIST_DIRECTORY HEX: 00000001 ; inline
-: FILE_READ_DAT HEX: 00000001 ; inline
-: FILE_ADD_FILE HEX: 00000002 ; inline
-: FILE_WRITE_DATA HEX: 00000002 ; inline
-: FILE_ADD_SUBDIRECTORY HEX: 00000004 ; inline
-: FILE_APPEND_DATA HEX: 00000004 ; inline
-: FILE_CREATE_PIPE_INSTANCE HEX: 00000004 ; inline
-: FILE_READ_EA HEX: 00000008 ; inline
-: FILE_READ_PROPERTIES HEX: 00000008 ; inline
-: FILE_WRITE_EA HEX: 00000010 ; inline
-: FILE_WRITE_PROPERTIES HEX: 00000010 ; inline
-: FILE_EXECUTE HEX: 00000020 ; inline
-: FILE_TRAVERSE HEX: 00000020 ; inline
-: FILE_DELETE_CHILD HEX: 00000040 ; inline
-: FILE_READ_ATTRIBUTES HEX: 00000080 ; inline
-: FILE_WRITE_ATTRIBUTES HEX: 00000100 ; inline
-
-: FILE_SHARE_READ 1 ; inline
-: FILE_SHARE_WRITE 2 ; inline
-: FILE_SHARE_DELETE 4 ; inline
-: FILE_SHARE_VALID_FLAGS 7 ; inline
-
-: FILE_FLAG_WRITE_THROUGH HEX: 80000000 ; inline
-: FILE_FLAG_OVERLAPPED HEX: 40000000 ; inline
-: FILE_FLAG_NO_BUFFERING HEX: 20000000 ; inline
-: FILE_FLAG_RANDOM_ACCESS HEX: 10000000 ; inline
-: FILE_FLAG_SEQUENTIAL_SCAN HEX: 08000000 ; inline
-: FILE_FLAG_DELETE_ON_CLOSE HEX: 04000000 ; inline
-: FILE_FLAG_BACKUP_SEMANTICS HEX: 02000000 ; inline
-: FILE_FLAG_POSIX_SEMANTICS HEX: 01000000 ; inline
-: FILE_FLAG_OPEN_REPARSE_POINT HEX: 00200000 ; inline
-: FILE_FLAG_OPEN_NO_RECALL HEX: 00100000 ; inline
-: FILE_FLAG_FIRST_PIPE_INSTANCE HEX: 00080000 ; inline
-
-: FILE_ATTRIBUTE_READONLY HEX: 00000001 ; inline
-: FILE_ATTRIBUTE_HIDDEN HEX: 00000002 ; inline
-: FILE_ATTRIBUTE_SYSTEM HEX: 00000004 ; inline
-: FILE_ATTRIBUTE_DIRECTORY HEX: 00000010 ; inline
-: FILE_ATTRIBUTE_ARCHIVE HEX: 00000020 ; inline
-: FILE_ATTRIBUTE_DEVICE HEX: 00000040 ; inline
-: FILE_ATTRIBUTE_NORMAL HEX: 00000080 ; inline
-: FILE_ATTRIBUTE_TEMPORARY HEX: 00000100 ; inline
-: FILE_ATTRIBUTE_SPARSE_FILE HEX: 00000200 ; inline
-: FILE_ATTRIBUTE_REPARSE_POINT HEX: 00000400 ; inline
-: FILE_ATTRIBUTE_COMPRESSED HEX: 00000800 ; inline
-: FILE_ATTRIBUTE_OFFLINE HEX: 00001000 ; inline
-: FILE_ATTRIBUTE_NOT_CONTENT_INDEXED HEX: 00002000 ; inline
-: FILE_ATTRIBUTE_ENCRYPTED HEX: 00004000 ; inline
-
-: FILE_NOTIFY_CHANGE_FILE HEX: 001 ; inline
-: FILE_NOTIFY_CHANGE_DIR_NAME HEX: 002 ; inline
-: FILE_NOTIFY_CHANGE_ATTRIBUTES HEX: 004 ; inline
-: FILE_NOTIFY_CHANGE_SIZE HEX: 008 ; inline
-: FILE_NOTIFY_CHANGE_LAST_WRITE HEX: 010 ; inline
-: FILE_NOTIFY_CHANGE_LAST_ACCESS HEX: 020 ; inline
-: FILE_NOTIFY_CHANGE_CREATION HEX: 040 ; inline
-: FILE_NOTIFY_CHANGE_EA HEX: 080 ; inline
-: FILE_NOTIFY_CHANGE_SECURITY HEX: 100 ; inline
-: FILE_NOTIFY_CHANGE_FILE_NAME HEX: 200 ; inline
-: FILE_NOTIFY_CHANGE_ALL HEX: 3ff ; inline
-
-: FILE_ACTION_ADDED 1 ; inline
-: FILE_ACTION_REMOVED 2 ; inline
-: FILE_ACTION_MODIFIED 3 ; inline
-: FILE_ACTION_RENAMED_OLD_NAME 4 ; inline
-: FILE_ACTION_RENAMED_NEW_NAME 5 ; inline
+CONSTANT: FILE_LIST_DIRECTORY HEX: 00000001
+CONSTANT: FILE_READ_DAT HEX: 00000001
+CONSTANT: FILE_ADD_FILE HEX: 00000002
+CONSTANT: FILE_WRITE_DATA HEX: 00000002
+CONSTANT: FILE_ADD_SUBDIRECTORY HEX: 00000004
+CONSTANT: FILE_APPEND_DATA HEX: 00000004
+CONSTANT: FILE_CREATE_PIPE_INSTANCE HEX: 00000004
+CONSTANT: FILE_READ_EA HEX: 00000008
+CONSTANT: FILE_READ_PROPERTIES HEX: 00000008
+CONSTANT: FILE_WRITE_EA HEX: 00000010
+CONSTANT: FILE_WRITE_PROPERTIES HEX: 00000010
+CONSTANT: FILE_EXECUTE HEX: 00000020
+CONSTANT: FILE_TRAVERSE HEX: 00000020
+CONSTANT: FILE_DELETE_CHILD HEX: 00000040
+CONSTANT: FILE_READ_ATTRIBUTES HEX: 00000080
+CONSTANT: FILE_WRITE_ATTRIBUTES HEX: 00000100
+
+CONSTANT: FILE_SHARE_READ 1
+CONSTANT: FILE_SHARE_WRITE 2
+CONSTANT: FILE_SHARE_DELETE 4
+CONSTANT: FILE_SHARE_VALID_FLAGS 7
+
+CONSTANT: FILE_FLAG_WRITE_THROUGH HEX: 80000000
+CONSTANT: FILE_FLAG_OVERLAPPED HEX: 40000000
+CONSTANT: FILE_FLAG_NO_BUFFERING HEX: 20000000
+CONSTANT: FILE_FLAG_RANDOM_ACCESS HEX: 10000000
+CONSTANT: FILE_FLAG_SEQUENTIAL_SCAN HEX: 08000000
+CONSTANT: FILE_FLAG_DELETE_ON_CLOSE HEX: 04000000
+CONSTANT: FILE_FLAG_BACKUP_SEMANTICS HEX: 02000000
+CONSTANT: FILE_FLAG_POSIX_SEMANTICS HEX: 01000000
+CONSTANT: FILE_FLAG_OPEN_REPARSE_POINT HEX: 00200000
+CONSTANT: FILE_FLAG_OPEN_NO_RECALL HEX: 00100000
+CONSTANT: FILE_FLAG_FIRST_PIPE_INSTANCE HEX: 00080000
+
+CONSTANT: FILE_ATTRIBUTE_READONLY HEX: 00000001
+CONSTANT: FILE_ATTRIBUTE_HIDDEN HEX: 00000002
+CONSTANT: FILE_ATTRIBUTE_SYSTEM HEX: 00000004
+CONSTANT: FILE_ATTRIBUTE_DIRECTORY HEX: 00000010
+CONSTANT: FILE_ATTRIBUTE_ARCHIVE HEX: 00000020
+CONSTANT: FILE_ATTRIBUTE_DEVICE HEX: 00000040
+CONSTANT: FILE_ATTRIBUTE_NORMAL HEX: 00000080
+CONSTANT: FILE_ATTRIBUTE_TEMPORARY HEX: 00000100
+CONSTANT: FILE_ATTRIBUTE_SPARSE_FILE HEX: 00000200
+CONSTANT: FILE_ATTRIBUTE_REPARSE_POINT HEX: 00000400
+CONSTANT: FILE_ATTRIBUTE_COMPRESSED HEX: 00000800
+CONSTANT: FILE_ATTRIBUTE_OFFLINE HEX: 00001000
+CONSTANT: FILE_ATTRIBUTE_NOT_CONTENT_INDEXED HEX: 00002000
+CONSTANT: FILE_ATTRIBUTE_ENCRYPTED HEX: 00004000
+
+CONSTANT: FILE_NOTIFY_CHANGE_FILE HEX: 001
+CONSTANT: FILE_NOTIFY_CHANGE_DIR_NAME HEX: 002
+CONSTANT: FILE_NOTIFY_CHANGE_ATTRIBUTES HEX: 004
+CONSTANT: FILE_NOTIFY_CHANGE_SIZE HEX: 008
+CONSTANT: FILE_NOTIFY_CHANGE_LAST_WRITE HEX: 010
+CONSTANT: FILE_NOTIFY_CHANGE_LAST_ACCESS HEX: 020
+CONSTANT: FILE_NOTIFY_CHANGE_CREATION HEX: 040
+CONSTANT: FILE_NOTIFY_CHANGE_EA HEX: 080
+CONSTANT: FILE_NOTIFY_CHANGE_SECURITY HEX: 100
+CONSTANT: FILE_NOTIFY_CHANGE_FILE_NAME HEX: 200
+CONSTANT: FILE_NOTIFY_CHANGE_ALL HEX: 3ff
+
+CONSTANT: FILE_ACTION_ADDED 1
+CONSTANT: FILE_ACTION_REMOVED 2
+CONSTANT: FILE_ACTION_MODIFIED 3
+CONSTANT: FILE_ACTION_RENAMED_OLD_NAME 4
+CONSTANT: FILE_ACTION_RENAMED_NEW_NAME 5
C-STRUCT: FILE_NOTIFY_INFORMATION
{ "DWORD" "NextEntryOffset" }
{ "WCHAR[1]" "FileName" } ;
TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
-: STD_INPUT_HANDLE -10 ; inline
-: STD_OUTPUT_HANDLE -11 ; inline
-: STD_ERROR_HANDLE -12 ; inline
-
-: INVALID_HANDLE_VALUE -1 <alien> ; inline
-: INVALID_FILE_SIZE HEX: FFFFFFFF ; inline
-: INVALID_SET_FILE_POINTER HEX: ffffffff ; inline
-
-: FILE_BEGIN 0 ; inline
-: FILE_CURRENT 1 ; inline
-: FILE_END 2 ; inline
-
-: OF_READ 0 ;
-: OF_READWRITE 2 ;
-: OF_WRITE 1 ;
-: OF_SHARE_COMPAT 0 ;
-: OF_SHARE_DENY_NONE 64 ;
-: OF_SHARE_DENY_READ 48 ;
-: OF_SHARE_DENY_WRITE 32 ;
-: OF_SHARE_EXCLUSIVE 16 ;
-: OF_CANCEL 2048 ;
-: OF_CREATE 4096 ;
-: OF_DELETE 512 ;
-: OF_EXIST 16384 ;
-: OF_PARSE 256 ;
-: OF_PROMPT 8192 ;
-: OF_REOPEN 32768 ;
-: OF_VERIFY 1024 ;
-
-: INFINITE HEX: FFFFFFFF ; inline
+CONSTANT: STD_INPUT_HANDLE -10
+CONSTANT: STD_OUTPUT_HANDLE -11
+CONSTANT: STD_ERROR_HANDLE -12
+
+: INVALID_HANDLE_VALUE
( -- alien ) -1 <alien> ; inline
+CONSTANT: INVALID_FILE_SIZE HEX: FFFFFFFF
+CONSTANT: INVALID_SET_FILE_POINTER HEX: ffffffff
+
+CONSTANT: FILE_BEGIN 0
+CONSTANT: FILE_CURRENT 1
+CONSTANT: FILE_END 2
+
+CONSTANT: OF_READ 0
+CONSTANT: OF_READWRITE 2
+CONSTANT: OF_WRITE 1
+CONSTANT: OF_SHARE_COMPAT 0
+CONSTANT: OF_SHARE_DENY_NONE 64
+CONSTANT: OF_SHARE_DENY_READ 48
+CONSTANT: OF_SHARE_DENY_WRITE 32
+CONSTANT: OF_SHARE_EXCLUSIVE 16
+CONSTANT: OF_CANCEL 2048
+CONSTANT: OF_CREATE 4096
+CONSTANT: OF_DELETE 512
+CONSTANT: OF_EXIST 16384
+CONSTANT: OF_PARSE 256
+CONSTANT: OF_PROMPT 8192
+CONSTANT: OF_REOPEN 32768
+CONSTANT: OF_VERIFY 1024
+
+CONSTANT: INFINITE HEX: FFFFFFFF
! From C:\cygwin\usr\include\w32api\winbase.h
-: FILE_TYPE_UNKNOWN 0 ;
-: FILE_TYPE_DISK 1 ;
-: FILE_TYPE_CHAR 2 ;
-: FILE_TYPE_PIPE 3 ;
-: FILE_TYPE_REMOTE HEX: 8000 ;
-
-: TIME_ZONE_ID_UNKNOWN 0 ; inline
-: TIME_ZONE_ID_STANDARD 1 ; inline
-: TIME_ZONE_ID_DAYLIGHT 2 ; inline
-: TIME_ZONE_ID_INVALID HEX: FFFFFFFF ; inline
-
-
-: PF_XMMI64_INSTRUCTIONS_AVAILABLE 10 ; inline
-: PF_SSE3_INSTRUCTIONS_AVAILABLE 13 ; inline
-
-: MAX_COMPUTERNAME_LENGTH 15 ; inline
-: UNLEN 256 ; inline
-
-: PROCESS_TERMINATE ( -- n ) HEX: 1 ; inline
-: PROCESS_CREATE_THREAD ( -- n ) HEX: 2 ; inline
-: PROCESS_VM_OPERATION ( -- n ) HEX: 8 ; inline
-: PROCESS_VM_READ ( -- n ) HEX: 10 ; inline
-: PROCESS_VM_WRITE ( -- n ) HEX: 20 ; inline
-: PROCESS_DUP_HANDLE ( -- n ) HEX: 40 ; inline
-: PROCESS_CREATE_PROCESS ( -- n ) HEX: 80 ; inline
-: PROCESS_SET_QUOTA ( -- n ) HEX: 100 ; inline
-: PROCESS_SET_INFORMATION ( -- n ) HEX: 200 ; inline
-: PROCESS_QUERY_INFORMATION ( -- n ) HEX: 400 ; inline
-
-: MEM_COMMIT ( -- n ) HEX: 1000 ; inline
-: MEM_RELEASE ( -- n ) HEX: 8000 ; inline
-
-: PAGE_NOACCESS 1 ; inline
-: PAGE_READONLY 2 ; inline
-: PAGE_READWRITE 4 ; inline
-: PAGE_WRITECOPY 8 ; inline
-: PAGE_EXECUTE HEX: 10 ; inline
-: PAGE_EXECUTE_READ HEX: 20 ; inline
-: PAGE_EXECUTE_READWRITE HEX: 40 ; inline
-: PAGE_EXECUTE_WRITECOPY HEX: 80 ; inline
-: PAGE_GUARD HEX: 100 ; inline
-: PAGE_NOCACHE HEX: 200 ; inline
-
-: SEC_BASED HEX: 00200000 ; inline
-: SEC_NO_CHANGE HEX: 00400000 ; inline
-: SEC_FILE HEX: 00800000 ; inline
-: SEC_IMAGE HEX: 01000000 ; inline
-: SEC_VLM HEX: 02000000 ; inline
-: SEC_RESERVE HEX: 04000000 ; inline
-: SEC_COMMIT HEX: 08000000 ; inline
-: SEC_NOCACHE HEX: 10000000 ; inline
-: MEM_IMAGE SEC_IMAGE ; inline
-
-: ERROR_ALREADY_EXISTS 183 ; inline
-
-: FILE_MAP_ALL_ACCESS HEX: f001f ;
-: FILE_MAP_READ 4 ;
-: FILE_MAP_WRITE 2 ;
-: FILE_MAP_COPY 1 ;
-
-: THREAD_MODE_BACKGROUND_BEGIN HEX: 10000 ; inline
-: THREAD_MODE_BACKGROUND_END HEX: 20000 ; inline
-: THREAD_PRIORITY_ABOVE_NORMAL 1 ; inline
-: THREAD_PRIORITY_BELOW_NORMAL -1 ; inline
-: THREAD_PRIORITY_HIGHEST 2 ; inline
-: THREAD_PRIORITY_IDLE -15 ; inline
-: THREAD_PRIORITY_LOWEST -2 ; inline
-: THREAD_PRIORITY_NORMAL 0 ; inline
-: THREAD_PRIORITY_TIME_CRITICAL 15 ; inline
+CONSTANT: FILE_TYPE_UNKNOWN 0
+CONSTANT: FILE_TYPE_DISK 1
+CONSTANT: FILE_TYPE_CHAR 2
+CONSTANT: FILE_TYPE_PIPE 3
+CONSTANT: FILE_TYPE_REMOTE HEX: 8000
+
+CONSTANT: TIME_ZONE_ID_UNKNOWN 0
+CONSTANT: TIME_ZONE_ID_STANDARD 1
+CONSTANT: TIME_ZONE_ID_DAYLIGHT 2
+CONSTANT: TIME_ZONE_ID_INVALID HEX: FFFFFFFF
+
+CONSTANT: PF_XMMI64_INSTRUCTIONS_AVAILABLE 10
+CONSTANT: PF_SSE3_INSTRUCTIONS_AVAILABLE 13
+
+CONSTANT: MAX_COMPUTERNAME_LENGTH 15
+CONSTANT: UNLEN 256
+
+CONSTANT: PROCESS_TERMINATE HEX: 1
+CONSTANT: PROCESS_CREATE_THREAD HEX: 2
+CONSTANT: PROCESS_VM_OPERATION HEX: 8
+CONSTANT: PROCESS_VM_READ HEX: 10
+CONSTANT: PROCESS_VM_WRITE HEX: 20
+CONSTANT: PROCESS_DUP_HANDLE HEX: 40
+CONSTANT: PROCESS_CREATE_PROCESS HEX: 80
+CONSTANT: PROCESS_SET_QUOTA HEX: 100
+CONSTANT: PROCESS_SET_INFORMATION HEX: 200
+CONSTANT: PROCESS_QUERY_INFORMATION HEX: 400
+
+CONSTANT: MEM_COMMIT HEX: 1000
+CONSTANT: MEM_RELEASE HEX: 8000
+
+CONSTANT: PAGE_NOACCESS 1
+CONSTANT: PAGE_READONLY 2
+CONSTANT: PAGE_READWRITE 4
+CONSTANT: PAGE_WRITECOPY 8
+CONSTANT: PAGE_EXECUTE HEX: 10
+CONSTANT: PAGE_EXECUTE_READ HEX: 20
+CONSTANT: PAGE_EXECUTE_READWRITE HEX: 40
+CONSTANT: PAGE_EXECUTE_WRITECOPY HEX: 80
+CONSTANT: PAGE_GUARD HEX: 100
+CONSTANT: PAGE_NOCACHE HEX: 200
+
+CONSTANT: SEC_BASED HEX: 00200000
+CONSTANT: SEC_NO_CHANGE HEX: 00400000
+CONSTANT: SEC_FILE HEX: 00800000
+CONSTANT: SEC_IMAGE HEX: 01000000
+CONSTANT: SEC_VLM HEX: 02000000
+CONSTANT: SEC_RESERVE HEX: 04000000
+CONSTANT: SEC_COMMIT HEX: 08000000
+CONSTANT: SEC_NOCACHE HEX: 10000000
+ALIAS: MEM_IMAGE SEC_IMAGE
+
+CONSTANT: ERROR_ALREADY_EXISTS 183
+
+CONSTANT: FILE_MAP_ALL_ACCESS HEX: f001f
+CONSTANT: FILE_MAP_READ 4
+CONSTANT: FILE_MAP_WRITE 2
+CONSTANT: FILE_MAP_COPY 1
+
+CONSTANT: THREAD_MODE_BACKGROUND_BEGIN HEX: 10000
+CONSTANT: THREAD_MODE_BACKGROUND_END HEX: 20000
+CONSTANT: THREAD_PRIORITY_ABOVE_NORMAL 1
+CONSTANT: THREAD_PRIORITY_BELOW_NORMAL -1
+CONSTANT: THREAD_PRIORITY_HIGHEST 2
+CONSTANT: THREAD_PRIORITY_IDLE -15
+CONSTANT: THREAD_PRIORITY_LOWEST -2
+CONSTANT: THREAD_PRIORITY_NORMAL 0
+CONSTANT: THREAD_PRIORITY_TIME_CRITICAL 15
C-STRUCT: OVERLAPPED
{ "UINT_PTR" "internal" }
{ { "UCHAR" 8 } "Data4" } ;
-: SE_CREATE_TOKEN_NAME "SeCreateTokenPrivilege" ;
-: SE_ASSIGNPRIMARYTOKEN_NAME "SeAssignPrimaryTokenPrivilege" ;
-: SE_LOCK_MEMORY_NAME "SeLockMemoryPrivilege" ;
-: SE_INCREASE_QUOTA_NAME "SeIncreaseQuotaPrivilege" ;
-: SE_UNSOLICITED_INPUT_NAME "SeUnsolicitedInputPrivilege" ;
-: SE_MACHINE_ACCOUNT_NAME "SeMachineAccountPrivilege" ;
-: SE_TCB_NAME "SeTcbPrivilege" ;
-: SE_SECURITY_NAME "SeSecurityPrivilege" ;
-: SE_TAKE_OWNERSHIP_NAME "SeTakeOwnershipPrivilege" ;
-: SE_LOAD_DRIVER_NAME "SeLoadDriverPrivilege" ;
-: SE_SYSTEM_PROFILE_NAME "SeSystemProfilePrivilege" ;
-: SE_SYSTEMTIME_NAME "SeSystemtimePrivilege" ;
-: SE_PROF_SINGLE_PROCESS_NAME "SeProfileSingleProcessPrivilege" ;
-: SE_INC_BASE_PRIORITY_NAME "SeIncreaseBasePriorityPrivilege" ;
-: SE_CREATE_PAGEFILE_NAME "SeCreatePagefilePrivilege" ;
-: SE_CREATE_PERMANENT_NAME "SeCreatePermanentPrivilege" ;
-: SE_BACKUP_NAME "SeBackupPrivilege" ;
-: SE_RESTORE_NAME "SeRestorePrivilege" ;
-: SE_SHUTDOWN_NAME "SeShutdownPrivilege" ;
-: SE_DEBUG_NAME "SeDebugPrivilege" ;
-: SE_AUDIT_NAME "SeAuditPrivilege" ;
-: SE_SYSTEM_ENVIRONMENT_NAME "SeSystemEnvironmentPrivilege" ;
-: SE_CHANGE_NOTIFY_NAME "SeChangeNotifyPrivilege" ;
-: SE_REMOTE_SHUTDOWN_NAME "SeRemoteShutdownPrivilege" ;
-: SE_UNDOCK_NAME "SeUndockPrivilege" ;
-: SE_ENABLE_DELEGATION_NAME "SeEnableDelegationPrivilege" ;
-: SE_MANAGE_VOLUME_NAME "SeManageVolumePrivilege" ;
-: SE_IMPERSONATE_NAME "SeImpersonatePrivilege" ;
-: SE_CREATE_GLOBAL_NAME "SeCreateGlobalPrivilege" ;
-
-: SE_GROUP_MANDATORY HEX: 00000001 ;
-: SE_GROUP_ENABLED_BY_DEFAULT HEX: 00000002 ;
-: SE_GROUP_ENABLED HEX: 00000004 ;
-: SE_GROUP_OWNER HEX: 00000008 ;
-: SE_GROUP_USE_FOR_DENY_ONLY HEX: 00000010 ;
-: SE_GROUP_LOGON_ID HEX: C0000000 ;
-: SE_GROUP_RESOURCE HEX: 20000000 ;
-
-: SE_PRIVILEGE_ENABLED_BY_DEFAULT HEX: 00000001 ;
-: SE_PRIVILEGE_ENABLED HEX: 00000002 ;
-: SE_PRIVILEGE_REMOVE HEX: 00000004 ;
-: SE_PRIVILEGE_USED_FOR_ACCESS HEX: 80000000 ;
-
-: PRIVILEGE_SET_ALL_NECESSARY 1 ;
-
-: SE_OWNER_DEFAULTED HEX: 00000001 ;
-: SE_GROUP_DEFAULTED HEX: 00000002 ;
-: SE_DACL_PRESENT HEX: 00000004 ;
-: SE_DACL_DEFAULTED HEX: 00000008 ;
-: SE_SACL_PRESENT HEX: 00000010 ;
-: SE_SACL_DEFAULTED HEX: 00000020 ;
-: SE_DACL_AUTO_INHERIT_REQ HEX: 00000100 ;
-: SE_SACL_AUTO_INHERIT_REQ HEX: 00000200 ;
-: SE_DACL_AUTO_INHERITED HEX: 00000400 ;
-: SE_SACL_AUTO_INHERITED HEX: 00000800 ;
-: SE_DACL_PROTECTED HEX: 00001000 ;
-: SE_SACL_PROTECTED HEX: 00002000 ;
-: SE_SELF_RELATIVE HEX: 00008000 ;
-
-: ANYSIZE_ARRAY 1 ; inline
-
-: MAXIMUM_WAIT_OBJECTS 64 ; inline
-: MAXIMUM_SUSPEND_COUNT HEX: 7f ; inline
-: WAIT_OBJECT_0 0 ; inline
-: WAIT_ABANDONED_0 128 ; inline
-: WAIT_TIMEOUT 258 ; inline
-: WAIT_IO_COMPLETION HEX: c0 ; inline
-: WAIT_FAILED HEX: ffffffff ; inline
+CONSTANT: SE_CREATE_TOKEN_NAME "SeCreateTokenPrivilege"
+CONSTANT: SE_ASSIGNPRIMARYTOKEN_NAME "SeAssignPrimaryTokenPrivilege"
+CONSTANT: SE_LOCK_MEMORY_NAME "SeLockMemoryPrivilege"
+CONSTANT: SE_INCREASE_QUOTA_NAME "SeIncreaseQuotaPrivilege"
+CONSTANT: SE_UNSOLICITED_INPUT_NAME "SeUnsolicitedInputPrivilege"
+CONSTANT: SE_MACHINE_ACCOUNT_NAME "SeMachineAccountPrivilege"
+CONSTANT: SE_TCB_NAME "SeTcbPrivilege"
+CONSTANT: SE_SECURITY_NAME "SeSecurityPrivilege"
+CONSTANT: SE_TAKE_OWNERSHIP_NAME "SeTakeOwnershipPrivilege"
+CONSTANT: SE_LOAD_DRIVER_NAME "SeLoadDriverPrivilege"
+CONSTANT: SE_SYSTEM_PROFILE_NAME "SeSystemProfilePrivilege"
+CONSTANT: SE_SYSTEMTIME_NAME "SeSystemtimePrivilege"
+CONSTANT: SE_PROF_SINGLE_PROCESS_NAME "SeProfileSingleProcessPrivilege"
+CONSTANT: SE_INC_BASE_PRIORITY_NAME "SeIncreaseBasePriorityPrivilege"
+CONSTANT: SE_CREATE_PAGEFILE_NAME "SeCreatePagefilePrivilege"
+CONSTANT: SE_CREATE_PERMANENT_NAME "SeCreatePermanentPrivilege"
+CONSTANT: SE_BACKUP_NAME "SeBackupPrivilege"
+CONSTANT: SE_RESTORE_NAME "SeRestorePrivilege"
+CONSTANT: SE_SHUTDOWN_NAME "SeShutdownPrivilege"
+CONSTANT: SE_DEBUG_NAME "SeDebugPrivilege"
+CONSTANT: SE_AUDIT_NAME "SeAuditPrivilege"
+CONSTANT: SE_SYSTEM_ENVIRONMENT_NAME "SeSystemEnvironmentPrivilege"
+CONSTANT: SE_CHANGE_NOTIFY_NAME "SeChangeNotifyPrivilege"
+CONSTANT: SE_REMOTE_SHUTDOWN_NAME "SeRemoteShutdownPrivilege"
+CONSTANT: SE_UNDOCK_NAME "SeUndockPrivilege"
+CONSTANT: SE_ENABLE_DELEGATION_NAME "SeEnableDelegationPrivilege"
+CONSTANT: SE_MANAGE_VOLUME_NAME "SeManageVolumePrivilege"
+CONSTANT: SE_IMPERSONATE_NAME "SeImpersonatePrivilege"
+CONSTANT: SE_CREATE_GLOBAL_NAME "SeCreateGlobalPrivilege"
+
+CONSTANT: SE_GROUP_MANDATORY HEX: 00000001
+CONSTANT: SE_GROUP_ENABLED_BY_DEFAULT HEX: 00000002
+CONSTANT: SE_GROUP_ENABLED HEX: 00000004
+CONSTANT: SE_GROUP_OWNER HEX: 00000008
+CONSTANT: SE_GROUP_USE_FOR_DENY_ONLY HEX: 00000010
+CONSTANT: SE_GROUP_LOGON_ID HEX: C0000000
+CONSTANT: SE_GROUP_RESOURCE HEX: 20000000
+
+CONSTANT: SE_PRIVILEGE_ENABLED_BY_DEFAULT HEX: 00000001
+CONSTANT: SE_PRIVILEGE_ENABLED HEX: 00000002
+CONSTANT: SE_PRIVILEGE_REMOVE HEX: 00000004
+CONSTANT: SE_PRIVILEGE_USED_FOR_ACCESS HEX: 80000000
+
+CONSTANT: PRIVILEGE_SET_ALL_NECESSARY 1
+
+CONSTANT: SE_OWNER_DEFAULTED HEX: 00000001
+CONSTANT: SE_GROUP_DEFAULTED HEX: 00000002
+CONSTANT: SE_DACL_PRESENT HEX: 00000004
+CONSTANT: SE_DACL_DEFAULTED HEX: 00000008
+CONSTANT: SE_SACL_PRESENT HEX: 00000010
+CONSTANT: SE_SACL_DEFAULTED HEX: 00000020
+CONSTANT: SE_DACL_AUTO_INHERIT_REQ HEX: 00000100
+CONSTANT: SE_SACL_AUTO_INHERIT_REQ HEX: 00000200
+CONSTANT: SE_DACL_AUTO_INHERITED HEX: 00000400
+CONSTANT: SE_SACL_AUTO_INHERITED HEX: 00000800
+CONSTANT: SE_DACL_PROTECTED HEX: 00001000
+CONSTANT: SE_SACL_PROTECTED HEX: 00002000
+CONSTANT: SE_SELF_RELATIVE HEX: 00008000
+
+CONSTANT: ANYSIZE_ARRAY 1
+
+CONSTANT: MAXIMUM_WAIT_OBJECTS 64
+CONSTANT: MAXIMUM_SUSPEND_COUNT HEX: 7f
+CONSTANT: WAIT_OBJECT_0 0
+CONSTANT: WAIT_ABANDONED_0 128
+CONSTANT: WAIT_TIMEOUT 258
+CONSTANT: WAIT_IO_COMPLETION HEX: c0
+CONSTANT: WAIT_FAILED HEX: ffffffff
C-STRUCT: LUID
{ "DWORD" "LowPart" }
{ "DWORD" "nFileIndexLow" } ;
TYPEDEF: BY_HANDLE_FILE_INFORMATION* LPBY_HANDLE_FILE_INFORMATION
-: OFS_MAXPATHNAME 128 ;
+CONSTANT: OFS_MAXPATHNAME 128
C-STRUCT: OFSTRUCT
{ "BYTE" "cBytes" }
{ "LPVOID" "lpSecurityDescriptor" }
{ "BOOL" "bInheritHandle" } ;
-: HANDLE_FLAG_INHERIT 1 ; inline
-: HANDLE_FLAG_PROTECT_FROM_CLOSE 2 ; inline
+CONSTANT: HANDLE_FLAG_INHERIT 1
+CONSTANT: HANDLE_FLAG_PROTECT_FROM_CLOSE 2
-: STARTF_USESHOWWINDOW HEX: 00000001 ; inline
-: STARTF_USESIZE HEX: 00000002 ; inline
-: STARTF_USEPOSITION HEX: 00000004 ; inline
-: STARTF_USECOUNTCHARS HEX: 00000008 ; inline
-: STARTF_USEFILLATTRIBUTE HEX: 00000010 ; inline
-: STARTF_RUNFULLSCREEN HEX: 00000020 ; inline
-: STARTF_FORCEONFEEDBACK HEX: 00000040 ; inline
-: STARTF_FORCEOFFFEEDBACK HEX: 00000080 ; inline
-: STARTF_USESTDHANDLES HEX: 00000100 ; inline
-: STARTF_USEHOTKEY HEX: 00000200 ; inline
+CONSTANT: STARTF_USESHOWWINDOW HEX: 00000001
+CONSTANT: STARTF_USESIZE HEX: 00000002
+CONSTANT: STARTF_USEPOSITION HEX: 00000004
+CONSTANT: STARTF_USECOUNTCHARS HEX: 00000008
+CONSTANT: STARTF_USEFILLATTRIBUTE HEX: 00000010
+CONSTANT: STARTF_RUNFULLSCREEN HEX: 00000020
+CONSTANT: STARTF_FORCEONFEEDBACK HEX: 00000040
+CONSTANT: STARTF_FORCEOFFFEEDBACK HEX: 00000080
+CONSTANT: STARTF_USESTDHANDLES HEX: 00000100
+CONSTANT: STARTF_USEHOTKEY HEX: 00000200
-: PIPE_ACCESS_INBOUND 1 ; inline
-: PIPE_ACCESS_OUTBOUND 2 ; inline
-: PIPE_ACCESS_DUPLEX 3 ; inline
+CONSTANT: PIPE_ACCESS_INBOUND 1
+CONSTANT: PIPE_ACCESS_OUTBOUND 2
+CONSTANT: PIPE_ACCESS_DUPLEX 3
-: PIPE_TYPE_BYTE 0 ; inline
-: PIPE_TYPE_MESSAGE 4 ; inline
+CONSTANT: PIPE_TYPE_BYTE 0
+CONSTANT: PIPE_TYPE_MESSAGE 4
-: PIPE_READMODE_BYTE 0 ; inline
-: PIPE_READMODE_MESSAGE 2 ; inline
+CONSTANT: PIPE_READMODE_BYTE 0
+CONSTANT: PIPE_READMODE_MESSAGE 2
-: PIPE_WAIT 0 ; inline
-: PIPE_NOWAIT 1 ; inline
+CONSTANT: PIPE_WAIT 0
+CONSTANT: PIPE_NOWAIT 1
-: PIPE_UNLIMITED_INSTANCES 255 ; inline
+CONSTANT: PIPE_UNLIMITED_INSTANCES 255
LIBRARY: kernel32
! FUNCTION: _hread
! FUNCTION: CreateNlsSecurityDescriptor
FUNCTION: BOOL CreatePipe ( PHANDLE hReadPipe, PHANDLE hWritePipe, LPSECURITY_ATTRIBUTES lpPipeAttributes, DWORD nSize ) ;
-: DEBUG_PROCESS HEX: 00000001 ;
-: DEBUG_ONLY_THIS_PROCESS HEX: 00000002 ;
-: CREATE_SUSPENDED HEX: 00000004 ;
-: DETACHED_PROCESS HEX: 00000008 ;
-: CREATE_NEW_CONSOLE HEX: 00000010 ;
-: NORMAL_PRIORITY_CLASS HEX: 00000020 ;
-: IDLE_PRIORITY_CLASS HEX: 00000040 ;
-: HIGH_PRIORITY_CLASS HEX: 00000080 ;
-: REALTIME_PRIORITY_CLASS HEX: 00000100 ;
-: CREATE_NEW_PROCESS_GROUP HEX: 00000200 ;
-: CREATE_UNICODE_ENVIRONMENT HEX: 00000400 ;
-: CREATE_SEPARATE_WOW_VDM HEX: 00000800 ;
-: CREATE_SHARED_WOW_VDM HEX: 00001000 ;
-: CREATE_FORCEDOS HEX: 00002000 ;
-: BELOW_NORMAL_PRIORITY_CLASS HEX: 00004000 ;
-: ABOVE_NORMAL_PRIORITY_CLASS HEX: 00008000 ;
-: CREATE_BREAKAWAY_FROM_JOB HEX: 01000000 ;
-: CREATE_WITH_USERPROFILE HEX: 02000000 ;
-: CREATE_DEFAULT_ERROR_MODE HEX: 04000000 ;
-: CREATE_NO_WINDOW HEX: 08000000 ;
-: PROFILE_USER HEX: 10000000 ;
-: PROFILE_KERNEL HEX: 20000000 ;
-: PROFILE_SERVER HEX: 40000000 ;
+CONSTANT: DEBUG_PROCESS HEX: 00000001
+CONSTANT: DEBUG_ONLY_THIS_PROCESS HEX: 00000002
+CONSTANT: CREATE_SUSPENDED HEX: 00000004
+CONSTANT: DETACHED_PROCESS HEX: 00000008
+CONSTANT: CREATE_NEW_CONSOLE HEX: 00000010
+CONSTANT: NORMAL_PRIORITY_CLASS HEX: 00000020
+CONSTANT: IDLE_PRIORITY_CLASS HEX: 00000040
+CONSTANT: HIGH_PRIORITY_CLASS HEX: 00000080
+CONSTANT: REALTIME_PRIORITY_CLASS HEX: 00000100
+CONSTANT: CREATE_NEW_PROCESS_GROUP HEX: 00000200
+CONSTANT: CREATE_UNICODE_ENVIRONMENT HEX: 00000400
+CONSTANT: CREATE_SEPARATE_WOW_VDM HEX: 00000800
+CONSTANT: CREATE_SHARED_WOW_VDM HEX: 00001000
+CONSTANT: CREATE_FORCEDOS HEX: 00002000
+CONSTANT: BELOW_NORMAL_PRIORITY_CLASS HEX: 00004000
+CONSTANT: ABOVE_NORMAL_PRIORITY_CLASS HEX: 00008000
+CONSTANT: CREATE_BREAKAWAY_FROM_JOB HEX: 01000000
+CONSTANT: CREATE_WITH_USERPROFILE HEX: 02000000
+CONSTANT: CREATE_DEFAULT_ERROR_MODE HEX: 04000000
+CONSTANT: CREATE_NO_WINDOW HEX: 08000000
+CONSTANT: PROFILE_USER HEX: 10000000
+CONSTANT: PROFILE_KERNEL HEX: 20000000
+CONSTANT: PROFILE_SERVER HEX: 40000000
FUNCTION: BOOL CreateProcessW ( LPCTSTR lpApplicationname,
LPTSTR lpCommandLine,
: windows-message-name ( n -- name )
windows-messages get at "unknown message" or ;
-: WM_NULL HEX: 0000 ; inline
-: WM_CREATE HEX: 0001 ; inline
-: WM_DESTROY HEX: 0002 ; inline
-: WM_MOVE HEX: 0003 ; inline
-: WM_SIZE HEX: 0005 ; inline
-: WM_ACTIVATE HEX: 0006 ; inline
-: WM_SETFOCUS HEX: 0007 ; inline
-: WM_KILLFOCUS HEX: 0008 ; inline
-: WM_ENABLE HEX: 000A ; inline
-: WM_SETREDRAW HEX: 000B ; inline
-: WM_SETTEXT HEX: 000C ; inline
-: WM_GETTEXT HEX: 000D ; inline
-: WM_GETTEXTLENGTH HEX: 000E ; inline
-: WM_PAINT HEX: 000F ; inline
-: WM_CLOSE HEX: 0010 ; inline
-: WM_QUERYENDSESSION HEX: 0011 ; inline
-: WM_QUERYOPEN HEX: 0013 ; inline
-: WM_ENDSESSION HEX: 0016 ; inline
-: WM_QUIT HEX: 0012 ; inline
-: WM_ERASEBKGND HEX: 0014 ; inline
-: WM_SYSCOLORCHANGE HEX: 0015 ; inline
-: WM_SHOWWINDOW HEX: 0018 ; inline
-: WM_WININICHANGE HEX: 001A ; inline
-: WM_SETTINGCHANGE HEX: 001A ; inline
-: WM_DEVMODECHANGE HEX: 001B ; inline
-: WM_ACTIVATEAPP HEX: 001C ; inline
-: WM_FONTCHANGE HEX: 001D ; inline
-: WM_TIMECHANGE HEX: 001E ; inline
-: WM_CANCELMODE HEX: 001F ; inline
-: WM_SETCURSOR HEX: 0020 ; inline
-: WM_MOUSEACTIVATE HEX: 0021 ; inline
-: WM_CHILDACTIVATE HEX: 0022 ; inline
-: WM_QUEUESYNC HEX: 0023 ; inline
-: WM_GETMINMAXINFO HEX: 0024 ; inline
-: WM_PAINTICON HEX: 0026 ; inline
-: WM_ICONERASEBKGND HEX: 0027 ; inline
-: WM_NEXTDLGCTL HEX: 0028 ; inline
-: WM_SPOOLERSTATUS HEX: 002A ; inline
-: WM_DRAWITEM HEX: 002B ; inline
-: WM_MEASUREITEM HEX: 002C ; inline
-: WM_DELETEITEM HEX: 002D ; inline
-: WM_VKEYTOITEM HEX: 002E ; inline
-: WM_CHARTOITEM HEX: 002F ; inline
-: WM_SETFONT HEX: 0030 ; inline
-: WM_GETFONT HEX: 0031 ; inline
-: WM_SETHOTKEY HEX: 0032 ; inline
-: WM_GETHOTKEY HEX: 0033 ; inline
-: WM_QUERYDRAGICON HEX: 0037 ; inline
-: WM_COMPAREITEM HEX: 0039 ; inline
-: WM_GETOBJECT HEX: 003D ; inline
-: WM_COMPACTING HEX: 0041 ; inline
-: WM_COMMNOTIFY HEX: 0044 ; inline
-: WM_WINDOWPOSCHANGING HEX: 0046 ; inline
-: WM_WINDOWPOSCHANGED HEX: 0047 ; inline
-: WM_POWER HEX: 0048 ; inline
-: WM_COPYDATA HEX: 004A ; inline
-: WM_CANCELJOURNAL HEX: 004B ; inline
-: WM_NOTIFY HEX: 004E ; inline
-: WM_INPUTLANGCHANGEREQUEST HEX: 0050 ; inline
-: WM_INPUTLANGCHANGE HEX: 0051 ; inline
-: WM_TCARD HEX: 0052 ; inline
-: WM_HELP HEX: 0053 ; inline
-: WM_USERCHANGED HEX: 0054 ; inline
-: WM_NOTIFYFORMAT HEX: 0055 ; inline
-: WM_CONTEXTMENU HEX: 007B ; inline
-: WM_STYLECHANGING HEX: 007C ; inline
-: WM_STYLECHANGED HEX: 007D ; inline
-: WM_DISPLAYCHANGE HEX: 007E ; inline
-: WM_GETICON HEX: 007F ; inline
-: WM_SETICON HEX: 0080 ; inline
-: WM_NCCREATE HEX: 0081 ; inline
-: WM_NCDESTROY HEX: 0082 ; inline
-: WM_NCCALCSIZE HEX: 0083 ; inline
-: WM_NCHITTEST HEX: 0084 ; inline
-: WM_NCPAINT HEX: 0085 ; inline
-: WM_NCACTIVATE HEX: 0086 ; inline
-: WM_GETDLGCODE HEX: 0087 ; inline
-: WM_SYNCPAINT HEX: 0088 ; inline
-: WM_NCMOUSEMOVE HEX: 00A0 ; inline
-: WM_NCLBUTTONDOWN HEX: 00A1 ; inline
-: WM_NCLBUTTONUP HEX: 00A2 ; inline
-: WM_NCLBUTTONDBLCLK HEX: 00A3 ; inline
-: WM_NCRBUTTONDOWN HEX: 00A4 ; inline
-: WM_NCRBUTTONUP HEX: 00A5 ; inline
-: WM_NCRBUTTONDBLCLK HEX: 00A6 ; inline
-: WM_NCMBUTTONDOWN HEX: 00A7 ; inline
-: WM_NCMBUTTONUP HEX: 00A8 ; inline
-: WM_NCMBUTTONDBLCLK HEX: 00A9 ; inline
-: WM_NCXBUTTONDOWN HEX: 00AB ; inline
-: WM_NCXBUTTONUP HEX: 00AC ; inline
-: WM_NCXBUTTONDBLCLK HEX: 00AD ; inline
-: WM_NCUAHDRAWCAPTION HEX: 00AE ; inline ! undocumented
-: WM_NCUAHDRAWFRAME HEX: 00AF ; inline ! undocumented
-: WM_INPUT HEX: 00FF ; inline
-: WM_KEYFIRST HEX: 0100 ; inline
-: WM_KEYDOWN HEX: 0100 ; inline
-: WM_KEYUP HEX: 0101 ; inline
-: WM_CHAR HEX: 0102 ; inline
-: WM_DEADCHAR HEX: 0103 ; inline
-: WM_SYSKEYDOWN HEX: 0104 ; inline
-: WM_SYSKEYUP HEX: 0105 ; inline
-: WM_SYSCHAR HEX: 0106 ; inline
-: WM_SYSDEADCHAR HEX: 0107 ; inline
-: WM_UNICHAR HEX: 0109 ; inline
-: WM_KEYLAST_NT501 HEX: 0109 ; inline
-: UNICODE_NOCHAR HEX: FFFF ; inline
-: WM_KEYLAST_PRE501 HEX: 0108 ; inline
-: WM_IME_STARTCOMPOSITION HEX: 010D ; inline
-: WM_IME_ENDCOMPOSITION HEX: 010E ; inline
-: WM_IME_COMPOSITION HEX: 010F ; inline
-: WM_IME_KEYLAST HEX: 010F ; inline
-: WM_INITDIALOG HEX: 0110 ; inline
-: WM_COMMAND HEX: 0111 ; inline
-: WM_SYSCOMMAND HEX: 0112 ; inline
-: WM_TIMER HEX: 0113 ; inline
-: WM_HSCROLL HEX: 0114 ; inline
-: WM_VSCROLL HEX: 0115 ; inline
-: WM_INITMENU HEX: 0116 ; inline
-: WM_INITMENUPOPUP HEX: 0117 ; inline
-: WM_MENUSELECT HEX: 011F ; inline
-: WM_MENUCHAR HEX: 0120 ; inline
-: WM_ENTERIDLE HEX: 0121 ; inline
-: WM_MENURBUTTONUP HEX: 0122 ; inline
-: WM_MENUDRAG HEX: 0123 ; inline
-: WM_MENUGETOBJECT HEX: 0124 ; inline
-: WM_UNINITMENUPOPUP HEX: 0125 ; inline
-: WM_MENUCOMMAND HEX: 0126 ; inline
-: WM_CHANGEUISTATE HEX: 0127 ; inline
-: WM_UPDATEUISTATE HEX: 0128 ; inline
-: WM_QUERYUISTATE HEX: 0129 ; inline
-: WM_CTLCOLORMSGBOX HEX: 0132 ; inline
-: WM_CTLCOLOREDIT HEX: 0133 ; inline
-: WM_CTLCOLORLISTBOX HEX: 0134 ; inline
-: WM_CTLCOLORBTN HEX: 0135 ; inline
-: WM_CTLCOLORDLG HEX: 0136 ; inline
-: WM_CTLCOLORSCROLLBAR HEX: 0137 ; inline
-: WM_CTLCOLORSTATIC HEX: 0138 ; inline
-: WM_MOUSEFIRST HEX: 0200 ; inline
-: WM_MOUSEMOVE HEX: 0200 ; inline
-: WM_LBUTTONDOWN HEX: 0201 ; inline
-: WM_LBUTTONUP HEX: 0202 ; inline
-: WM_LBUTTONDBLCLK HEX: 0203 ; inline
-: WM_RBUTTONDOWN HEX: 0204 ; inline
-: WM_RBUTTONUP HEX: 0205 ; inline
-: WM_RBUTTONDBLCLK HEX: 0206 ; inline
-: WM_MBUTTONDOWN HEX: 0207 ; inline
-: WM_MBUTTONUP HEX: 0208 ; inline
-: WM_MBUTTONDBLCLK HEX: 0209 ; inline
-: WM_MOUSEWHEEL HEX: 020A ; inline
-: WM_XBUTTONDOWN HEX: 020B ; inline
-: WM_XBUTTONUP HEX: 020C ; inline
-: WM_XBUTTONDBLCLK HEX: 020D ; inline
-: WM_MOUSELAST_5 HEX: 020D ; inline
-: WM_MOUSELAST_4 HEX: 020A ; inline
-: WM_MOUSELAST_PRE_4 HEX: 0209 ; inline
-: WM_PARENTNOTIFY HEX: 0210 ; inline
-: WM_ENTERMENULOOP HEX: 0211 ; inline
-: WM_EXITMENULOOP HEX: 0212 ; inline
-: WM_NEXTMENU HEX: 0213 ; inline
-: WM_SIZING HEX: 0214 ; inline
-: WM_CAPTURECHANGED HEX: 0215 ; inline
-: WM_MOVING HEX: 0216 ; inline
-: WM_POWERBROADCAST HEX: 0218 ; inline
-: WM_DEVICECHANGE HEX: 0219 ; inline
-: WM_MDICREATE HEX: 0220 ; inline
-: WM_MDIDESTROY HEX: 0221 ; inline
-: WM_MDIACTIVATE HEX: 0222 ; inline
-: WM_MDIRESTORE HEX: 0223 ; inline
-: WM_MDINEXT HEX: 0224 ; inline
-: WM_MDIMAXIMIZE HEX: 0225 ; inline
-: WM_MDITILE HEX: 0226 ; inline
-: WM_MDICASCADE HEX: 0227 ; inline
-: WM_MDIICONARRANGE HEX: 0228 ; inline
-: WM_MDIGETACTIVE HEX: 0229 ; inline
-: WM_MDISETMENU HEX: 0230 ; inline
-: WM_ENTERSIZEMOVE HEX: 0231 ; inline
-: WM_EXITSIZEMOVE HEX: 0232 ; inline
-: WM_DROPFILES HEX: 0233 ; inline
-: WM_MDIREFRESHMENU HEX: 0234 ; inline
-: WM_IME_SETCONTEXT HEX: 0281 ; inline
-: WM_IME_NOTIFY HEX: 0282 ; inline
-: WM_IME_CONTROL HEX: 0283 ; inline
-: WM_IME_COMPOSITIONFULL HEX: 0284 ; inline
-: WM_IME_SELECT HEX: 0285 ; inline
-: WM_IME_CHAR HEX: 0286 ; inline
-: WM_IME_REQUEST HEX: 0288 ; inline
-: WM_IME_KEYDOWN HEX: 0290 ; inline
-: WM_IME_KEYUP HEX: 0291 ; inline
-: WM_MOUSEHOVER HEX: 02A1 ; inline
-: WM_MOUSELEAVE HEX: 02A3 ; inline
-: WM_NCMOUSEHOVER HEX: 02A0 ; inline
-: WM_NCMOUSELEAVE HEX: 02A2 ; inline
-: WM_WTSSESSION_CHANGE HEX: 02B1 ; inline
-: WM_TABLET_FIRST HEX: 02c0 ; inline
-: WM_TABLET_LAST HEX: 02df ; inline
-: WM_CUT HEX: 0300 ; inline
-: WM_COPY HEX: 0301 ; inline
-: WM_PASTE HEX: 0302 ; inline
-: WM_CLEAR HEX: 0303 ; inline
-: WM_UNDO HEX: 0304 ; inline
-: WM_RENDERFORMAT HEX: 0305 ; inline
-: WM_RENDERALLFORMATS HEX: 0306 ; inline
-: WM_DESTROYCLIPBOARD HEX: 0307 ; inline
-: WM_DRAWCLIPBOARD HEX: 0308 ; inline
-: WM_PAINTCLIPBOARD HEX: 0309 ; inline
-: WM_VSCROLLCLIPBOARD HEX: 030A ; inline
-: WM_SIZECLIPBOARD HEX: 030B ; inline
-: WM_ASKCBFORMATNAME HEX: 030C ; inline
-: WM_CHANGECBCHAIN HEX: 030D ; inline
-: WM_HSCROLLCLIPBOARD HEX: 030E ; inline
-: WM_QUERYNEWPALETTE HEX: 030F ; inline
-: WM_PALETTEISCHANGING HEX: 0310 ; inline
-: WM_PALETTECHANGED HEX: 0311 ; inline
-: WM_HOTKEY HEX: 0312 ; inline
-: WM_PRINT HEX: 0317 ; inline
-: WM_PRINTCLIENT HEX: 0318 ; inline
-: WM_APPCOMMAND HEX: 0319 ; inline
-: WM_THEMECHANGED HEX: 031A ; inline
-: WM_HANDHELDFIRST HEX: 0358 ; inline
-: WM_HANDHELDLAST HEX: 035F ; inline
-: WM_AFXFIRST HEX: 0360 ; inline
-: WM_AFXLAST HEX: 037F ; inline
-: WM_PENWINFIRST HEX: 0380 ; inline
-: WM_PENWINLAST HEX: 038F ; inline
-: WM_APP HEX: 8000 ; inline
-: WM_USER HEX: 0400 ; inline
-: EM_GETSEL HEX: 00B0 ; inline
-: EM_SETSEL HEX: 00B1 ; inline
-: EM_GETRECT HEX: 00B2 ; inline
-: EM_SETRECT HEX: 00B3 ; inline
-: EM_SETRECTNP HEX: 00B4 ; inline
-: EM_SCROLL HEX: 00B5 ; inline
-: EM_LINESCROLL HEX: 00B6 ; inline
-: EM_SCROLLCARET HEX: 00B7 ; inline
-: EM_GETMODIFY HEX: 00B8 ; inline
-: EM_SETMODIFY HEX: 00B9 ; inline
-: EM_GETLINECOUNT HEX: 00BA ; inline
-: EM_LINEINDEX HEX: 00BB ; inline
-: EM_SETHANDLE HEX: 00BC ; inline
-: EM_GETHANDLE HEX: 00BD ; inline
-: EM_GETTHUMB HEX: 00BE ; inline
-: EM_LINELENGTH HEX: 00C1 ; inline
-: EM_REPLACESEL HEX: 00C2 ; inline
-: EM_GETLINE HEX: 00C4 ; inline
-: EM_LIMITTEXT HEX: 00C5 ; inline
-: EM_CANUNDO HEX: 00C6 ; inline
-: EM_UNDO HEX: 00C7 ; inline
-: EM_FMTLINES HEX: 00C8 ; inline
-: EM_LINEFROMCHAR HEX: 00C9 ; inline
-: EM_SETTABSTOPS HEX: 00CB ; inline
-: EM_SETPASSWORDCHAR HEX: 00CC ; inline
-: EM_EMPTYUNDOBUFFER HEX: 00CD ; inline
-: EM_GETFIRSTVISIBLELINE HEX: 00CE ; inline
-: EM_SETREADONLY HEX: 00CF ; inline
-: EM_SETWORDBREAKPROC HEX: 00D0 ; inline
-: EM_GETWORDBREAKPROC HEX: 00D1 ; inline
-: EM_GETPASSWORDCHAR HEX: 00D2 ; inline
-: EM_SETMARGINS HEX: 00D3 ; inline
-: EM_GETMARGINS HEX: 00D4 ; inline
-: EM_SETLIMITTEXT EM_LIMITTEXT ; inline
-: EM_GETLIMITTEXT HEX: 00D5 ; inline
-: EM_POSFROMCHAR HEX: 00D6 ; inline
-: EM_CHARFROMPOS HEX: 00D7 ; inline
-: EM_SETIMESTATUS HEX: 00D8 ; inline
-: EM_GETIMESTATUS HEX: 00D9 ; inline
-: BM_GETCHECK HEX: 00F0 ; inline
-: BM_SETCHECK HEX: 00F1 ; inline
-: BM_GETSTATE HEX: 00F2 ; inline
-: BM_SETSTATE HEX: 00F3 ; inline
-: BM_SETSTYLE HEX: 00F4 ; inline
-: BM_CLICK HEX: 00F5 ; inline
-: BM_GETIMAGE HEX: 00F6 ; inline
-: BM_SETIMAGE HEX: 00F7 ; inline
-: STM_SETICON HEX: 0170 ; inline
-: STM_GETICON HEX: 0171 ; inline
-: STM_SETIMAGE HEX: 0172 ; inline
-: STM_GETIMAGE HEX: 0173 ; inline
-: STM_MSGMAX HEX: 0174 ; inline
-: DM_GETDEFID WM_USER ; inline
-: DM_SETDEFID WM_USER 1 + ; inline
-: DM_REPOSITION WM_USER 2 + ; inline
-: LB_ADDSTRING HEX: 0180 ; inline
-: LB_INSERTSTRING HEX: 0181 ; inline
-: LB_DELETESTRING HEX: 0182 ; inline
-: LB_SELITEMRANGEEX HEX: 0183 ; inline
-: LB_RESETCONTENT HEX: 0184 ; inline
-: LB_SETSEL HEX: 0185 ; inline
-: LB_SETCURSEL HEX: 0186 ; inline
-: LB_GETSEL HEX: 0187 ; inline
-: LB_GETCURSEL HEX: 0188 ; inline
-: LB_GETTEXT HEX: 0189 ; inline
-: LB_GETTEXTLEN HEX: 018A ; inline
-: LB_GETCOUNT HEX: 018B ; inline
-: LB_SELECTSTRING HEX: 018C ; inline
-: LB_DIR HEX: 018D ; inline
-: LB_GETTOPINDEX HEX: 018E ; inline
-: LB_FINDSTRING HEX: 018F ; inline
-: LB_GETSELCOUNT HEX: 0190 ; inline
-: LB_GETSELITEMS HEX: 0191 ; inline
-: LB_SETTABSTOPS HEX: 0192 ; inline
-: LB_GETHORIZONTALEXTENT HEX: 0193 ; inline
-: LB_SETHORIZONTALEXTENT HEX: 0194 ; inline
-: LB_SETCOLUMNWIDTH HEX: 0195 ; inline
-: LB_ADDFILE HEX: 0196 ; inline
-: LB_SETTOPINDEX HEX: 0197 ; inline
-: LB_GETITEMRECT HEX: 0198 ; inline
-: LB_GETITEMDATA HEX: 0199 ; inline
-: LB_SETITEMDATA HEX: 019A ; inline
-: LB_SELITEMRANGE HEX: 019B ; inline
-: LB_SETANCHORINDEX HEX: 019C ; inline
-: LB_GETANCHORINDEX HEX: 019D ; inline
-: LB_SETCARETINDEX HEX: 019E ; inline
-: LB_GETCARETINDEX HEX: 019F ; inline
-: LB_SETITEMHEIGHT HEX: 01A0 ; inline
-: LB_GETITEMHEIGHT HEX: 01A1 ; inline
-: LB_FINDSTRINGEXACT HEX: 01A2 ; inline
-: LB_SETLOCALE HEX: 01A5 ; inline
-: LB_GETLOCALE HEX: 01A6 ; inline
-: LB_SETCOUNT HEX: 01A7 ; inline
-: LB_INITSTORAGE HEX: 01A8 ; inline
-: LB_ITEMFROMPOINT HEX: 01A9 ; inline
-: LB_MULTIPLEADDSTRING HEX: 01B1 ; inline
-: LB_GETLISTBOXINFO HEX: 01B2 ; inline
-: LB_MSGMAX_501 HEX: 01B3 ; inline
-: LB_MSGMAX_WCE4 HEX: 01B1 ; inline
-: LB_MSGMAX_4 HEX: 01B0 ; inline
-: LB_MSGMAX_PRE4 HEX: 01A8 ; inline
-: CB_GETEDITSEL HEX: 0140 ; inline
-: CB_LIMITTEXT HEX: 0141 ; inline
-: CB_SETEDITSEL HEX: 0142 ; inline
-: CB_ADDSTRING HEX: 0143 ; inline
-: CB_DELETESTRING HEX: 0144 ; inline
-: CB_DIR HEX: 0145 ; inline
-: CB_GETCOUNT HEX: 0146 ; inline
-: CB_GETCURSEL HEX: 0147 ; inline
-: CB_GETLBTEXT HEX: 0148 ; inline
-: CB_GETLBTEXTLEN HEX: 0149 ; inline
-: CB_INSERTSTRING HEX: 014A ; inline
-: CB_RESETCONTENT HEX: 014B ; inline
-: CB_FINDSTRING HEX: 014C ; inline
-: CB_SELECTSTRING HEX: 014D ; inline
-: CB_SETCURSEL HEX: 014E ; inline
-: CB_SHOWDROPDOWN HEX: 014F ; inline
-: CB_GETITEMDATA HEX: 0150 ; inline
-: CB_SETITEMDATA HEX: 0151 ; inline
-: CB_GETDROPPEDCONTROLRECT HEX: 0152 ; inline
-: CB_SETITEMHEIGHT HEX: 0153 ; inline
-: CB_GETITEMHEIGHT HEX: 0154 ; inline
-: CB_SETEXTENDEDUI HEX: 0155 ; inline
-: CB_GETEXTENDEDUI HEX: 0156 ; inline
-: CB_GETDROPPEDSTATE HEX: 0157 ; inline
-: CB_FINDSTRINGEXACT HEX: 0158 ; inline
-: CB_SETLOCALE HEX: 0159 ; inline
-: CB_GETLOCALE HEX: 015A ; inline
-: CB_GETTOPINDEX HEX: 015B ; inline
-: CB_SETTOPINDEX HEX: 015C ; inline
-: CB_GETHORIZONTALEXTENT HEX: 015d ; inline
-: CB_SETHORIZONTALEXTENT HEX: 015e ; inline
-: CB_GETDROPPEDWIDTH HEX: 015f ; inline
-: CB_SETDROPPEDWIDTH HEX: 0160 ; inline
-: CB_INITSTORAGE HEX: 0161 ; inline
-: CB_MULTIPLEADDSTRING HEX: 0163 ; inline
-: CB_GETCOMBOBOXINFO HEX: 0164 ; inline
-: CB_MSGMAX_501 HEX: 0165 ; inline
-: CB_MSGMAX_WCE400 HEX: 0163 ; inline
-: CB_MSGMAX_400 HEX: 0162 ; inline
-: CB_MSGMAX_PRE400 HEX: 015B ; inline
-: SBM_SETPOS HEX: 00E0 ; inline
-: SBM_GETPOS HEX: 00E1 ; inline
-: SBM_SETRANGE HEX: 00E2 ; inline
-: SBM_SETRANGEREDRAW HEX: 00E6 ; inline
-: SBM_GETRANGE HEX: 00E3 ; inline
-: SBM_ENABLE_ARROWS HEX: 00E4 ; inline
-: SBM_SETSCROLLINFO HEX: 00E9 ; inline
-: SBM_GETSCROLLINFO HEX: 00EA ; inline
-: SBM_GETSCROLLBARINFO HEX: 00EB ; inline
-: LVM_FIRST HEX: 1000 ; inline ! ListView messages
-: TV_FIRST HEX: 1100 ; inline ! TreeView messages
-: HDM_FIRST HEX: 1200 ; inline ! Header messages
-: TCM_FIRST HEX: 1300 ; inline ! Tab control messages
-: PGM_FIRST HEX: 1400 ; inline ! Pager control messages
-: ECM_FIRST HEX: 1500 ; inline ! Edit control messages
-: BCM_FIRST HEX: 1600 ; inline ! Button control messages
-: CBM_FIRST HEX: 1700 ; inline ! Combobox control messages
-: CCM_FIRST HEX: 2000 ; inline ! Common control shared messages
-: CCM_LAST CCM_FIRST HEX: 0200 + ; inline
-: CCM_SETBKCOLOR CCM_FIRST 1 + ; inline
-: CCM_SETCOLORSCHEME CCM_FIRST 2 + ; inline
-: CCM_GETCOLORSCHEME CCM_FIRST 3 + ; inline
-: CCM_GETDROPTARGET CCM_FIRST 4 + ; inline
-: CCM_SETUNICODEFORMAT CCM_FIRST 5 + ; inline
-: CCM_GETUNICODEFORMAT CCM_FIRST 6 + ; inline
-: CCM_SETVERSION CCM_FIRST 7 + ; inline
-: CCM_GETVERSION CCM_FIRST 8 + ; inline
-: CCM_SETNOTIFYWINDOW CCM_FIRST 9 + ; inline
-: CCM_SETWINDOWTHEME CCM_FIRST HEX: b + ; inline
-: CCM_DPISCALE CCM_FIRST HEX: c + ; inline
-: HDM_GETITEMCOUNT HDM_FIRST 0 + ; inline
-: HDM_INSERTITEMA HDM_FIRST 1 + ; inline
-: HDM_INSERTITEMW HDM_FIRST 10 + ; inline
-: HDM_DELETEITEM HDM_FIRST 2 + ; inline
-: HDM_GETITEMA HDM_FIRST 3 + ; inline
-: HDM_GETITEMW HDM_FIRST 11 + ; inline
-: HDM_SETITEMA HDM_FIRST 4 + ; inline
-: HDM_SETITEMW HDM_FIRST 12 + ; inline
-: HDM_LAYOUT HDM_FIRST 5 + ; inline
-: HDM_HITTEST HDM_FIRST 6 + ; inline
-: HDM_GETITEMRECT HDM_FIRST 7 + ; inline
-: HDM_SETIMAGELIST HDM_FIRST 8 + ; inline
-: HDM_GETIMAGELIST HDM_FIRST 9 + ; inline
-: HDM_ORDERTOINDEX HDM_FIRST 15 + ; inline
-: HDM_CREATEDRAGIMAGE HDM_FIRST 16 + ; inline
-: HDM_GETORDERARRAY HDM_FIRST 17 + ; inline
-: HDM_SETORDERARRAY HDM_FIRST 18 + ; inline
-: HDM_SETHOTDIVIDER HDM_FIRST 19 + ; inline
-: HDM_SETBITMAPMARGIN HDM_FIRST 20 + ; inline
-: HDM_GETBITMAPMARGIN HDM_FIRST 21 + ; inline
-: HDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: HDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: HDM_SETFILTERCHANGETIMEOUT HDM_FIRST 22 + ; inline
-: HDM_EDITFILTER HDM_FIRST 23 + ; inline
-: HDM_CLEARFILTER HDM_FIRST 24 + ; inline
-: TB_ENABLEBUTTON WM_USER 1 + ; inline
-: TB_CHECKBUTTON WM_USER 2 + ; inline
-: TB_PRESSBUTTON WM_USER 3 + ; inline
-: TB_HIDEBUTTON WM_USER 4 + ; inline
-: TB_INDETERMINATE WM_USER 5 + ; inline
-: TB_MARKBUTTON WM_USER 6 + ; inline
-: TB_ISBUTTONENABLED WM_USER 9 + ; inline
-: TB_ISBUTTONCHECKED WM_USER 10 + ; inline
-: TB_ISBUTTONPRESSED WM_USER 11 + ; inline
-: TB_ISBUTTONHIDDEN WM_USER 12 + ; inline
-: TB_ISBUTTONINDETERMINATE WM_USER 13 + ; inline
-: TB_ISBUTTONHIGHLIGHTED WM_USER 14 + ; inline
-: TB_SETSTATE WM_USER 17 + ; inline
-: TB_GETSTATE WM_USER 18 + ; inline
-: TB_ADDBITMAP WM_USER 19 + ; inline
-: TB_ADDBUTTONSA WM_USER 20 + ; inline
-: TB_INSERTBUTTONA WM_USER 21 + ; inline
-: TB_ADDBUTTONS WM_USER 20 + ; inline
-: TB_INSERTBUTTON WM_USER 21 + ; inline
-: TB_DELETEBUTTON WM_USER 22 + ; inline
-: TB_GETBUTTON WM_USER 23 + ; inline
-: TB_BUTTONCOUNT WM_USER 24 + ; inline
-: TB_COMMANDTOINDEX WM_USER 25 + ; inline
-: TB_SAVERESTOREA WM_USER 26 + ; inline
-: TB_SAVERESTOREW WM_USER 76 + ; inline
-: TB_CUSTOMIZE WM_USER 27 + ; inline
-: TB_ADDSTRINGA WM_USER 28 + ; inline
-: TB_ADDSTRINGW WM_USER 77 + ; inline
-: TB_GETITEMRECT WM_USER 29 + ; inline
-: TB_BUTTONSTRUCTSIZE WM_USER 30 + ; inline
-: TB_SETBUTTONSIZE WM_USER 31 + ; inline
-: TB_SETBITMAPSIZE WM_USER 32 + ; inline
-: TB_AUTOSIZE WM_USER 33 + ; inline
-: TB_GETTOOLTIPS WM_USER 35 + ; inline
-: TB_SETTOOLTIPS WM_USER 36 + ; inline
-: TB_SETPARENT WM_USER 37 + ; inline
-: TB_SETROWS WM_USER 39 + ; inline
-: TB_GETROWS WM_USER 40 + ; inline
-: TB_SETCMDID WM_USER 42 + ; inline
-: TB_CHANGEBITMAP WM_USER 43 + ; inline
-: TB_GETBITMAP WM_USER 44 + ; inline
-: TB_GETBUTTONTEXTA WM_USER 45 + ; inline
-: TB_GETBUTTONTEXTW WM_USER 75 + ; inline
-: TB_REPLACEBITMAP WM_USER 46 + ; inline
-: TB_SETINDENT WM_USER 47 + ; inline
-: TB_SETIMAGELIST WM_USER 48 + ; inline
-: TB_GETIMAGELIST WM_USER 49 + ; inline
-: TB_LOADIMAGES WM_USER 50 + ; inline
-: TB_GETRECT WM_USER 51 + ; inline
-: TB_SETHOTIMAGELIST WM_USER 52 + ; inline
-: TB_GETHOTIMAGELIST WM_USER 53 + ; inline
-: TB_SETDISABLEDIMAGELIST WM_USER 54 + ; inline
-: TB_GETDISABLEDIMAGELIST WM_USER 55 + ; inline
-: TB_SETSTYLE WM_USER 56 + ; inline
-: TB_GETSTYLE WM_USER 57 + ; inline
-: TB_GETBUTTONSIZE WM_USER 58 + ; inline
-: TB_SETBUTTONWIDTH WM_USER 59 + ; inline
-: TB_SETMAXTEXTROWS WM_USER 60 + ; inline
-: TB_GETTEXTROWS WM_USER 61 + ; inline
-: TB_GETOBJECT WM_USER 62 + ; inline
-: TB_GETHOTITEM WM_USER 71 + ; inline
-: TB_SETHOTITEM WM_USER 72 + ; inline
-: TB_SETANCHORHIGHLIGHT WM_USER 73 + ; inline
-: TB_GETANCHORHIGHLIGHT WM_USER 74 + ; inline
-: TB_MAPACCELERATORA WM_USER 78 + ; inline
-: TB_GETINSERTMARK WM_USER 79 + ; inline
-: TB_SETINSERTMARK WM_USER 80 + ; inline
-: TB_INSERTMARKHITTEST WM_USER 81 + ; inline
-: TB_MOVEBUTTON WM_USER 82 + ; inline
-: TB_GETMAXSIZE WM_USER 83 + ; inline
-: TB_SETEXTENDEDSTYLE WM_USER 84 + ; inline
-: TB_GETEXTENDEDSTYLE WM_USER 85 + ; inline
-: TB_GETPADDING WM_USER 86 + ; inline
-: TB_SETPADDING WM_USER 87 + ; inline
-: TB_SETINSERTMARKCOLOR WM_USER 88 + ; inline
-: TB_GETINSERTMARKCOLOR WM_USER 89 + ; inline
-: TB_SETCOLORSCHEME CCM_SETCOLORSCHEME ; inline
-: TB_GETCOLORSCHEME CCM_GETCOLORSCHEME ; inline
-: TB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: TB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: TB_MAPACCELERATORW WM_USER 90 + ; inline
-: TB_GETBITMAPFLAGS WM_USER 41 + ; inline
-: TB_GETBUTTONINFOW WM_USER 63 + ; inline
-: TB_SETBUTTONINFOW WM_USER 64 + ; inline
-: TB_GETBUTTONINFOA WM_USER 65 + ; inline
-: TB_SETBUTTONINFOA WM_USER 66 + ; inline
-: TB_INSERTBUTTONW WM_USER 67 + ; inline
-: TB_ADDBUTTONSW WM_USER 68 + ; inline
-: TB_HITTEST WM_USER 69 + ; inline
-: TB_SETDRAWTEXTFLAGS WM_USER 70 + ; inline
-: TB_GETSTRINGW WM_USER 91 + ; inline
-: TB_GETSTRINGA WM_USER 92 + ; inline
-: TB_GETMETRICS WM_USER 101 + ; inline
-: TB_SETMETRICS WM_USER 102 + ; inline
-: TB_SETWINDOWTHEME CCM_SETWINDOWTHEME ; inline
-: RB_INSERTBANDA WM_USER 1 + ; inline
-: RB_DELETEBAND WM_USER 2 + ; inline
-: RB_GETBARINFO WM_USER 3 + ; inline
-: RB_SETBARINFO WM_USER 4 + ; inline
-: RB_GETBANDINFO WM_USER 5 + ; inline
-: RB_SETBANDINFOA WM_USER 6 + ; inline
-: RB_SETPARENT WM_USER 7 + ; inline
-: RB_HITTEST WM_USER 8 + ; inline
-: RB_GETRECT WM_USER 9 + ; inline
-: RB_INSERTBANDW WM_USER 10 + ; inline
-: RB_SETBANDINFOW WM_USER 11 + ; inline
-: RB_GETBANDCOUNT WM_USER 12 + ; inline
-: RB_GETROWCOUNT WM_USER 13 + ; inline
-: RB_GETROWHEIGHT WM_USER 14 + ; inline
-: RB_IDTOINDEX WM_USER 16 + ; inline
-: RB_GETTOOLTIPS WM_USER 17 + ; inline
-: RB_SETTOOLTIPS WM_USER 18 + ; inline
-: RB_SETBKCOLOR WM_USER 19 + ; inline
-: RB_GETBKCOLOR WM_USER 20 + ; inline
-: RB_SETTEXTCOLOR WM_USER 21 + ; inline
-: RB_GETTEXTCOLOR WM_USER 22 + ; inline
-: RB_SIZETORECT WM_USER 23 + ; inline
-: RB_SETCOLORSCHEME CCM_SETCOLORSCHEME ; inline
-: RB_GETCOLORSCHEME CCM_GETCOLORSCHEME ; inline
-: RB_BEGINDRAG WM_USER 24 + ; inline
-: RB_ENDDRAG WM_USER 25 + ; inline
-: RB_DRAGMOVE WM_USER 26 + ; inline
-: RB_GETBARHEIGHT WM_USER 27 + ; inline
-: RB_GETBANDINFOW WM_USER 28 + ; inline
-: RB_GETBANDINFOA WM_USER 29 + ; inline
-: RB_MINIMIZEBAND WM_USER 30 + ; inline
-: RB_MAXIMIZEBAND WM_USER 31 + ; inline
-: RB_GETDROPTARGET CCM_GETDROPTARGET ; inline
-: RB_GETBANDBORDERS WM_USER 34 + ; inline
-: RB_SHOWBAND WM_USER 35 + ; inline
-: RB_SETPALETTE WM_USER 37 + ; inline
-: RB_GETPALETTE WM_USER 38 + ; inline
-: RB_MOVEBAND WM_USER 39 + ; inline
-: RB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: RB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: RB_GETBANDMARGINS WM_USER 40 + ; inline
-: RB_SETWINDOWTHEME CCM_SETWINDOWTHEME ; inline
-: RB_PUSHCHEVRON WM_USER 43 + ; inline
-: TTM_ACTIVATE WM_USER 1 + ; inline
-: TTM_SETDELAYTIME WM_USER 3 + ; inline
-: TTM_ADDTOOLA WM_USER 4 + ; inline
-: TTM_ADDTOOLW WM_USER 50 + ; inline
-: TTM_DELTOOLA WM_USER 5 + ; inline
-: TTM_DELTOOLW WM_USER 51 + ; inline
-: TTM_NEWTOOLRECTA WM_USER 6 + ; inline
-: TTM_NEWTOOLRECTW WM_USER 52 + ; inline
-: TTM_RELAYEVENT WM_USER 7 + ; inline
-: TTM_GETTOOLINFOA WM_USER 8 + ; inline
-: TTM_GETTOOLINFOW WM_USER 53 + ; inline
-: TTM_SETTOOLINFOA WM_USER 9 + ; inline
-: TTM_SETTOOLINFOW WM_USER 54 + ; inline
-: TTM_HITTESTA WM_USER 10 + ; inline
-: TTM_HITTESTW WM_USER 55 + ; inline
-: TTM_GETTEXTA WM_USER 11 + ; inline
-: TTM_GETTEXTW WM_USER 56 + ; inline
-: TTM_UPDATETIPTEXTA WM_USER 12 + ; inline
-: TTM_UPDATETIPTEXTW WM_USER 57 + ; inline
-: TTM_GETTOOLCOUNT WM_USER 13 + ; inline
-: TTM_ENUMTOOLSA WM_USER 14 + ; inline
-: TTM_ENUMTOOLSW WM_USER 58 + ; inline
-: TTM_GETCURRENTTOOLA WM_USER 15 + ; inline
-: TTM_GETCURRENTTOOLW WM_USER 59 + ; inline
-: TTM_WINDOWFROMPOINT WM_USER 16 + ; inline
-: TTM_TRACKACTIVATE WM_USER 17 + ; inline
-: TTM_TRACKPOSITION WM_USER 18 + ; inline
-: TTM_SETTIPBKCOLOR WM_USER 19 + ; inline
-: TTM_SETTIPTEXTCOLOR WM_USER 20 + ; inline
-: TTM_GETDELAYTIME WM_USER 21 + ; inline
-: TTM_GETTIPBKCOLOR WM_USER 22 + ; inline
-: TTM_GETTIPTEXTCOLOR WM_USER 23 + ; inline
-: TTM_SETMAXTIPWIDTH WM_USER 24 + ; inline
-: TTM_GETMAXTIPWIDTH WM_USER 25 + ; inline
-: TTM_SETMARGIN WM_USER 26 + ; inline
-: TTM_GETMARGIN WM_USER 27 + ; inline
-: TTM_POP WM_USER 28 + ; inline
-: TTM_UPDATE WM_USER 29 + ; inline
-: TTM_GETBUBBLESIZE WM_USER 30 + ; inline
-: TTM_ADJUSTRECT WM_USER 31 + ; inline
-: TTM_SETTITLEA WM_USER 32 + ; inline
-: TTM_SETTITLEW WM_USER 33 + ; inline
-: TTM_POPUP WM_USER 34 + ; inline
-: TTM_GETTITLE WM_USER 35 + ; inline
-: TTM_SETWINDOWTHEME CCM_SETWINDOWTHEME ; inline
-: SB_SETTEXTA WM_USER 1+ ; inline
-: SB_SETTEXTW WM_USER 11 + ; inline
-: SB_GETTEXTA WM_USER 2 + ; inline
-: SB_GETTEXTW WM_USER 13 + ; inline
-: SB_GETTEXTLENGTHA WM_USER 3 + ; inline
-: SB_GETTEXTLENGTHW WM_USER 12 + ; inline
-: SB_SETPARTS WM_USER 4 + ; inline
-: SB_GETPARTS WM_USER 6 + ; inline
-: SB_GETBORDERS WM_USER 7 + ; inline
-: SB_SETMINHEIGHT WM_USER 8 + ; inline
-: SB_SIMPLE WM_USER 9 + ; inline
-: SB_GETRECT WM_USER 10 + ; inline
-: SB_ISSIMPLE WM_USER 14 + ; inline
-: SB_SETICON WM_USER 15 + ; inline
-: SB_SETTIPTEXTA WM_USER 16 + ; inline
-: SB_SETTIPTEXTW WM_USER 17 + ; inline
-: SB_GETTIPTEXTA WM_USER 18 + ; inline
-: SB_GETTIPTEXTW WM_USER 19 + ; inline
-: SB_GETICON WM_USER 20 + ; inline
-: SB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: SB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: SB_SETBKCOLOR CCM_SETBKCOLOR ; inline
-: SB_SIMPLEID HEX: 00ff ; inline
-: TBM_GETPOS WM_USER ; inline
-: TBM_GETRANGEMIN WM_USER 1 + ; inline
-: TBM_GETRANGEMAX WM_USER 2 + ; inline
-: TBM_GETTIC WM_USER 3 + ; inline
-: TBM_SETTIC WM_USER 4 + ; inline
-: TBM_SETPOS WM_USER 5 + ; inline
-: TBM_SETRANGE WM_USER 6 + ; inline
-: TBM_SETRANGEMIN WM_USER 7 + ; inline
-: TBM_SETRANGEMAX WM_USER 8 + ; inline
-: TBM_CLEARTICS WM_USER 9 + ; inline
-: TBM_SETSEL WM_USER 10 + ; inline
-: TBM_SETSELSTART WM_USER 11 + ; inline
-: TBM_SETSELEND WM_USER 12 + ; inline
-: TBM_GETPTICS WM_USER 14 + ; inline
-: TBM_GETTICPOS WM_USER 15 + ; inline
-: TBM_GETNUMTICS WM_USER 16 + ; inline
-: TBM_GETSELSTART WM_USER 17 + ; inline
-: TBM_GETSELEND WM_USER 18 + ; inline
-: TBM_CLEARSEL WM_USER 19 + ; inline
-: TBM_SETTICFREQ WM_USER 20 + ; inline
-: TBM_SETPAGESIZE WM_USER 21 + ; inline
-: TBM_GETPAGESIZE WM_USER 22 + ; inline
-: TBM_SETLINESIZE WM_USER 23 + ; inline
-: TBM_GETLINESIZE WM_USER 24 + ; inline
-: TBM_GETTHUMBRECT WM_USER 25 + ; inline
-: TBM_GETCHANNELRECT WM_USER 26 + ; inline
-: TBM_SETTHUMBLENGTH WM_USER 27 + ; inline
-: TBM_GETTHUMBLENGTH WM_USER 28 + ; inline
-: TBM_SETTOOLTIPS WM_USER 29 + ; inline
-: TBM_GETTOOLTIPS WM_USER 30 + ; inline
-: TBM_SETTIPSIDE WM_USER 31 + ; inline
-: TBM_SETBUDDY WM_USER 32 + ; inline
-: TBM_GETBUDDY WM_USER 33 + ; inline
-: TBM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: TBM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: DL_BEGINDRAG WM_USER 133 + ; inline
-: DL_DRAGGING WM_USER 134 + ; inline
-: DL_DROPPED WM_USER 135 + ; inline
-: DL_CANCELDRAG WM_USER 136 + ; inline
-: UDM_SETRANGE WM_USER 101 + ; inline
-: UDM_GETRANGE WM_USER 102 + ; inline
-: UDM_SETPOS WM_USER 103 + ; inline
-: UDM_GETPOS WM_USER 104 + ; inline
-: UDM_SETBUDDY WM_USER 105 + ; inline
-: UDM_GETBUDDY WM_USER 106 + ; inline
-: UDM_SETACCEL WM_USER 107 + ; inline
-: UDM_GETACCEL WM_USER 108 + ; inline
-: UDM_SETBASE WM_USER 109 + ; inline
-: UDM_GETBASE WM_USER 110 + ; inline
-: UDM_SETRANGE32 WM_USER 111 + ; inline
-: UDM_GETRANGE32 WM_USER 112 + ; inline
-: UDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: UDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: UDM_SETPOS32 WM_USER 113 + ; inline
-: UDM_GETPOS32 WM_USER 114 + ; inline
-: PBM_SETRANGE WM_USER 1 + ; inline
-: PBM_SETPOS WM_USER 2 + ; inline
-: PBM_DELTAPOS WM_USER 3 + ; inline
-: PBM_SETSTEP WM_USER 4 + ; inline
-: PBM_STEPIT WM_USER 5 + ; inline
-: PBM_SETRANGE32 WM_USER 6 + ; inline
-: PBM_GETRANGE WM_USER 7 + ; inline
-: PBM_GETPOS WM_USER 8 + ; inline
-: PBM_SETBARCOLOR WM_USER 9 + ; inline
-: PBM_SETBKCOLOR CCM_SETBKCOLOR ; inline
-: HKM_SETHOTKEY WM_USER 1 + ; inline
-: HKM_GETHOTKEY WM_USER 2 + ; inline
-: HKM_SETRULES WM_USER 3 + ; inline
-: LVM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: LVM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: LVM_GETBKCOLOR LVM_FIRST 0 + ; inline
-: LVM_SETBKCOLOR LVM_FIRST 1 + ; inline
-: LVM_GETIMAGELIST LVM_FIRST 2 + ; inline
-: LVM_SETIMAGELIST LVM_FIRST 3 + ; inline
-: LVM_GETITEMCOUNT LVM_FIRST 4 + ; inline
-: LVM_GETITEMA LVM_FIRST 5 + ; inline
-: LVM_GETITEMW LVM_FIRST 75 + ; inline
-: LVM_SETITEMA LVM_FIRST 6 + ; inline
-: LVM_SETITEMW LVM_FIRST 76 + ; inline
-: LVM_INSERTITEMA LVM_FIRST 7 + ; inline
-: LVM_INSERTITEMW LVM_FIRST 77 + ; inline
-: LVM_DELETEITEM LVM_FIRST 8 + ; inline
-: LVM_DELETEALLITEMS LVM_FIRST 9 + ; inline
-: LVM_GETCALLBACKMASK LVM_FIRST 10 + ; inline
-: LVM_SETCALLBACKMASK LVM_FIRST 11 + ; inline
-: LVM_FINDITEMA LVM_FIRST 13 + ; inline
-: LVM_FINDITEMW LVM_FIRST 83 + ; inline
-: LVM_GETITEMRECT LVM_FIRST 14 + ; inline
-: LVM_SETITEMPOSITION LVM_FIRST 15 + ; inline
-: LVM_GETITEMPOSITION LVM_FIRST 16 + ; inline
-: LVM_GETSTRINGWIDTHA LVM_FIRST 17 + ; inline
-: LVM_GETSTRINGWIDTHW LVM_FIRST 87 + ; inline
-: LVM_HITTEST LVM_FIRST 18 + ; inline
-: LVM_ENSUREVISIBLE LVM_FIRST 19 + ; inline
-: LVM_SCROLL LVM_FIRST 20 + ; inline
-: LVM_REDRAWITEMS LVM_FIRST 21 + ; inline
-: LVM_ARRANGE LVM_FIRST 22 + ; inline
-: LVM_EDITLABELA LVM_FIRST 23 + ; inline
-: LVM_EDITLABELW LVM_FIRST 118 + ; inline
-: LVM_GETEDITCONTROL LVM_FIRST 24 + ; inline
-: LVM_GETCOLUMNA LVM_FIRST 25 + ; inline
-: LVM_GETCOLUMNW LVM_FIRST 95 + ; inline
-: LVM_SETCOLUMNA LVM_FIRST 26 + ; inline
-: LVM_SETCOLUMNW LVM_FIRST 96 + ; inline
-: LVM_INSERTCOLUMNA LVM_FIRST 27 + ; inline
-: LVM_INSERTCOLUMNW LVM_FIRST 97 + ; inline
-: LVM_DELETECOLUMN LVM_FIRST 28 + ; inline
-: LVM_GETCOLUMNWIDTH LVM_FIRST 29 + ; inline
-: LVM_SETCOLUMNWIDTH LVM_FIRST 30 + ; inline
-: LVM_CREATEDRAGIMAGE LVM_FIRST 33 + ; inline
-: LVM_GETVIEWRECT LVM_FIRST 34 + ; inline
-: LVM_GETTEXTCOLOR LVM_FIRST 35 + ; inline
-: LVM_SETTEXTCOLOR LVM_FIRST 36 + ; inline
-: LVM_GETTEXTBKCOLOR LVM_FIRST 37 + ; inline
-: LVM_SETTEXTBKCOLOR LVM_FIRST 38 + ; inline
-: LVM_GETTOPINDEX LVM_FIRST 39 + ; inline
-: LVM_GETCOUNTPERPAGE LVM_FIRST 40 + ; inline
-: LVM_GETORIGIN LVM_FIRST 41 + ; inline
-: LVM_UPDATE LVM_FIRST 42 + ; inline
-: LVM_SETITEMSTATE LVM_FIRST 43 + ; inline
-: LVM_GETITEMSTATE LVM_FIRST 44 + ; inline
-: LVM_GETITEMTEXTA LVM_FIRST 45 + ; inline
-: LVM_GETITEMTEXTW LVM_FIRST 115 + ; inline
-: LVM_SETITEMTEXTA LVM_FIRST 46 + ; inline
-: LVM_SETITEMTEXTW LVM_FIRST 116 + ; inline
-: LVM_SETITEMCOUNT LVM_FIRST 47 + ; inline
-: LVM_SORTITEMS LVM_FIRST 48 + ; inline
-: LVM_SETITEMPOSITION32 LVM_FIRST 49 + ; inline
-: LVM_GETSELECTEDCOUNT LVM_FIRST 50 + ; inline
-: LVM_GETITEMSPACING LVM_FIRST 51 + ; inline
-: LVM_GETISEARCHSTRINGA LVM_FIRST 52 + ; inline
-: LVM_GETISEARCHSTRINGW LVM_FIRST 117 + ; inline
-: LVM_SETICONSPACING LVM_FIRST 53 + ; inline
-: LVM_SETEXTENDEDLISTVIEWSTYLE LVM_FIRST 54 + ; inline
-: LVM_GETEXTENDEDLISTVIEWSTYLE LVM_FIRST 55 + ; inline
-: LVM_GETSUBITEMRECT LVM_FIRST 56 + ; inline
-: LVM_SUBITEMHITTEST LVM_FIRST 57 + ; inline
-: LVM_SETCOLUMNORDERARRAY LVM_FIRST 58 + ; inline
-: LVM_GETCOLUMNORDERARRAY LVM_FIRST 59 + ; inline
-: LVM_SETHOTITEM LVM_FIRST 60 + ; inline
-: LVM_GETHOTITEM LVM_FIRST 61 + ; inline
-: LVM_SETHOTCURSOR LVM_FIRST 62 + ; inline
-: LVM_GETHOTCURSOR LVM_FIRST 63 + ; inline
-: LVM_APPROXIMATEVIEWRECT LVM_FIRST 64 + ; inline
-: LVM_SETWORKAREAS LVM_FIRST 65 + ; inline
-: LVM_GETWORKAREAS LVM_FIRST 70 + ; inline
-: LVM_GETNUMBEROFWORKAREAS LVM_FIRST 73 + ; inline
-: LVM_GETSELECTIONMARK LVM_FIRST 66 + ; inline
-: LVM_SETSELECTIONMARK LVM_FIRST 67 + ; inline
-: LVM_SETHOVERTIME LVM_FIRST 71 + ; inline
-: LVM_GETHOVERTIME LVM_FIRST 72 + ; inline
-: LVM_SETTOOLTIPS LVM_FIRST 74 + ; inline
-: LVM_GETTOOLTIPS LVM_FIRST 78 + ; inline
-: LVM_SORTITEMSEX LVM_FIRST 81 + ; inline
-: LVM_SETBKIMAGEA LVM_FIRST 68 + ; inline
-: LVM_SETBKIMAGEW LVM_FIRST 138 + ; inline
-: LVM_GETBKIMAGEA LVM_FIRST 69 + ; inline
-: LVM_GETBKIMAGEW LVM_FIRST 139 + ; inline
-: LVM_SETSELECTEDCOLUMN LVM_FIRST 140 + ; inline
-: LVM_SETTILEWIDTH LVM_FIRST 141 + ; inline
-: LVM_SETVIEW LVM_FIRST 142 + ; inline
-: LVM_GETVIEW LVM_FIRST 143 + ; inline
-: LVM_INSERTGROUP LVM_FIRST 145 + ; inline
-: LVM_SETGROUPINFO LVM_FIRST 147 + ; inline
-: LVM_GETGROUPINFO LVM_FIRST 149 + ; inline
-: LVM_REMOVEGROUP LVM_FIRST 150 + ; inline
-: LVM_MOVEGROUP LVM_FIRST 151 + ; inline
-: LVM_MOVEITEMTOGROUP LVM_FIRST 154 + ; inline
-: LVM_SETGROUPMETRICS LVM_FIRST 155 + ; inline
-: LVM_GETGROUPMETRICS LVM_FIRST 156 + ; inline
-: LVM_ENABLEGROUPVIEW LVM_FIRST 157 + ; inline
-: LVM_SORTGROUPS LVM_FIRST 158 + ; inline
-: LVM_INSERTGROUPSORTED LVM_FIRST 159 + ; inline
-: LVM_REMOVEALLGROUPS LVM_FIRST 160 + ; inline
-: LVM_HASGROUP LVM_FIRST 161 + ; inline
-: LVM_SETTILEVIEWINFO LVM_FIRST 162 + ; inline
-: LVM_GETTILEVIEWINFO LVM_FIRST 163 + ; inline
-: LVM_SETTILEINFO LVM_FIRST 164 + ; inline
-: LVM_GETTILEINFO LVM_FIRST 165 + ; inline
-: LVM_SETINSERTMARK LVM_FIRST 166 + ; inline
-: LVM_GETINSERTMARK LVM_FIRST 167 + ; inline
-: LVM_INSERTMARKHITTEST LVM_FIRST 168 + ; inline
-: LVM_GETINSERTMARKRECT LVM_FIRST 169 + ; inline
-: LVM_SETINSERTMARKCOLOR LVM_FIRST 170 + ; inline
-: LVM_GETINSERTMARKCOLOR LVM_FIRST 171 + ; inline
-: LVM_SETINFOTIP LVM_FIRST 173 + ; inline
-: LVM_GETSELECTEDCOLUMN LVM_FIRST 174 + ; inline
-: LVM_ISGROUPVIEWENABLED LVM_FIRST 175 + ; inline
-: LVM_GETOUTLINECOLOR LVM_FIRST 176 + ; inline
-: LVM_SETOUTLINECOLOR LVM_FIRST 177 + ; inline
-: LVM_CANCELEDITLABEL LVM_FIRST 179 + ; inline
-: LVM_MAPINDEXTOID LVM_FIRST 180 + ; inline
-: LVM_MAPIDTOINDEX LVM_FIRST 181 + ; inline
-: TVM_INSERTITEMA TV_FIRST 0 + ; inline
-: TVM_INSERTITEMW TV_FIRST 50 + ; inline
-: TVM_DELETEITEM TV_FIRST 1 + ; inline
-: TVM_EXPAND TV_FIRST 2 + ; inline
-: TVM_GETITEMRECT TV_FIRST 4 + ; inline
-: TVM_GETCOUNT TV_FIRST 5 + ; inline
-: TVM_GETINDENT TV_FIRST 6 + ; inline
-: TVM_SETINDENT TV_FIRST 7 + ; inline
-: TVM_GETIMAGELIST TV_FIRST 8 + ; inline
-: TVM_SETIMAGELIST TV_FIRST 9 + ; inline
-: TVM_GETNEXTITEM TV_FIRST 10 + ; inline
-: TVM_SELECTITEM TV_FIRST 11 + ; inline
-: TVM_GETITEMA TV_FIRST 12 + ; inline
-: TVM_GETITEMW TV_FIRST 62 + ; inline
-: TVM_SETITEMA TV_FIRST 13 + ; inline
-: TVM_SETITEMW TV_FIRST 63 + ; inline
-: TVM_EDITLABELA TV_FIRST 14 + ; inline
-: TVM_EDITLABELW TV_FIRST 65 + ; inline
-: TVM_GETEDITCONTROL TV_FIRST 15 + ; inline
-: TVM_GETVISIBLECOUNT TV_FIRST 16 + ; inline
-: TVM_HITTEST TV_FIRST 17 + ; inline
-: TVM_CREATEDRAGIMAGE TV_FIRST 18 + ; inline
-: TVM_SORTCHILDREN TV_FIRST 19 + ; inline
-: TVM_ENSUREVISIBLE TV_FIRST 20 + ; inline
-: TVM_SORTCHILDRENCB TV_FIRST 21 + ; inline
-: TVM_ENDEDITLABELNOW TV_FIRST 22 + ; inline
-: TVM_GETISEARCHSTRINGA TV_FIRST 23 + ; inline
-: TVM_GETISEARCHSTRINGW TV_FIRST 64 + ; inline
-: TVM_SETTOOLTIPS TV_FIRST 24 + ; inline
-: TVM_GETTOOLTIPS TV_FIRST 25 + ; inline
-: TVM_SETINSERTMARK TV_FIRST 26 + ; inline
-: TVM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: TVM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: TVM_SETITEMHEIGHT TV_FIRST 27 + ; inline
-: TVM_GETITEMHEIGHT TV_FIRST 28 + ; inline
-: TVM_SETBKCOLOR TV_FIRST 29 + ; inline
-: TVM_SETTEXTCOLOR TV_FIRST 30 + ; inline
-: TVM_GETBKCOLOR TV_FIRST 31 + ; inline
-: TVM_GETTEXTCOLOR TV_FIRST 32 + ; inline
-: TVM_SETSCROLLTIME TV_FIRST 33 + ; inline
-: TVM_GETSCROLLTIME TV_FIRST 34 + ; inline
-: TVM_SETINSERTMARKCOLOR TV_FIRST 37 + ; inline
-: TVM_GETINSERTMARKCOLOR TV_FIRST 38 + ; inline
-: TVM_GETITEMSTATE TV_FIRST 39 + ; inline
-: TVM_SETLINECOLOR TV_FIRST 40 + ; inline
-: TVM_GETLINECOLOR TV_FIRST 41 + ; inline
-: TVM_MAPACCIDTOHTREEITEM TV_FIRST 42 + ; inline
-: TVM_MAPHTREEITEMTOACCID TV_FIRST 43 + ; inline
-: CBEM_INSERTITEMA WM_USER 1 + ; inline
-: CBEM_SETIMAGELIST WM_USER 2 + ; inline
-: CBEM_GETIMAGELIST WM_USER 3 + ; inline
-: CBEM_GETITEMA WM_USER 4 + ; inline
-: CBEM_SETITEMA WM_USER 5 + ; inline
-: CBEM_DELETEITEM CB_DELETESTRING ; inline
-: CBEM_GETCOMBOCONTROL WM_USER 6 + ; inline
-: CBEM_GETEDITCONTROL WM_USER 7 + ; inline
-: CBEM_SETEXTENDEDSTYLE WM_USER 14 + ; inline
-: CBEM_GETEXTENDEDSTYLE WM_USER 9 + ; inline
-: CBEM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: CBEM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: CBEM_SETEXSTYLE WM_USER 8 + ; inline
-: CBEM_GETEXSTYLE WM_USER 9 + ; inline
-: CBEM_HASEDITCHANGED WM_USER 10 + ; inline
-: CBEM_INSERTITEMW WM_USER 11 + ; inline
-: CBEM_SETITEMW WM_USER 12 + ; inline
-: CBEM_GETITEMW WM_USER 13 + ; inline
-: TCM_GETIMAGELIST TCM_FIRST 2 + ; inline
-: TCM_SETIMAGELIST TCM_FIRST 3 + ; inline
-: TCM_GETITEMCOUNT TCM_FIRST 4 + ; inline
-: TCM_GETITEMA TCM_FIRST 5 + ; inline
-: TCM_GETITEMW TCM_FIRST 60 + ; inline
-: TCM_SETITEMA TCM_FIRST 6 + ; inline
-: TCM_SETITEMW TCM_FIRST 61 + ; inline
-: TCM_INSERTITEMA TCM_FIRST 7 + ; inline
-: TCM_INSERTITEMW TCM_FIRST 62 + ; inline
-: TCM_DELETEITEM TCM_FIRST 8 + ; inline
-: TCM_DELETEALLITEMS TCM_FIRST 9 + ; inline
-: TCM_GETITEMRECT TCM_FIRST 10 + ; inline
-: TCM_GETCURSEL TCM_FIRST 11 + ; inline
-: TCM_SETCURSEL TCM_FIRST 12 + ; inline
-: TCM_HITTEST TCM_FIRST 13 + ; inline
-: TCM_SETITEMEXTRA TCM_FIRST 14 + ; inline
-: TCM_ADJUSTRECT TCM_FIRST 40 + ; inline
-: TCM_SETITEMSIZE TCM_FIRST 41 + ; inline
-: TCM_REMOVEIMAGE TCM_FIRST 42 + ; inline
-: TCM_SETPADDING TCM_FIRST 43 + ; inline
-: TCM_GETROWCOUNT TCM_FIRST 44 + ; inline
-: TCM_GETTOOLTIPS TCM_FIRST 45 + ; inline
-: TCM_SETTOOLTIPS TCM_FIRST 46 + ; inline
-: TCM_GETCURFOCUS TCM_FIRST 47 + ; inline
-: TCM_SETCURFOCUS TCM_FIRST 48 + ; inline
-: TCM_SETMINTABWIDTH TCM_FIRST 49 + ; inline
-: TCM_DESELECTALL TCM_FIRST 50 + ; inline
-: TCM_HIGHLIGHTITEM TCM_FIRST 51 + ; inline
-: TCM_SETEXTENDEDSTYLE TCM_FIRST 52 + ; inline
-: TCM_GETEXTENDEDSTYLE TCM_FIRST 53 + ; inline
-: TCM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: TCM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: ACM_OPENA WM_USER 100 + ; inline
-: ACM_OPENW WM_USER 103 + ; inline
-: ACM_PLAY WM_USER 101 + ; inline
-: ACM_STOP WM_USER 102 + ; inline
-: MCM_FIRST HEX: 1000 ; inline
-: MCM_GETCURSEL MCM_FIRST 1 + ; inline
-: MCM_SETCURSEL MCM_FIRST 2 + ; inline
-: MCM_GETMAXSELCOUNT MCM_FIRST 3 + ; inline
-: MCM_SETMAXSELCOUNT MCM_FIRST 4 + ; inline
-: MCM_GETSELRANGE MCM_FIRST 5 + ; inline
-: MCM_SETSELRANGE MCM_FIRST 6 + ; inline
-: MCM_GETMONTHRANGE MCM_FIRST 7 + ; inline
-: MCM_SETDAYSTATE MCM_FIRST 8 + ; inline
-: MCM_GETMINREQRECT MCM_FIRST 9 + ; inline
-: MCM_SETCOLOR MCM_FIRST 10 + ; inline
-: MCM_GETCOLOR MCM_FIRST 11 + ; inline
-: MCM_SETTODAY MCM_FIRST 12 + ; inline
-: MCM_GETTODAY MCM_FIRST 13 + ; inline
-: MCM_HITTEST MCM_FIRST 14 + ; inline
-: MCM_SETFIRSTDAYOFWEEK MCM_FIRST 15 + ; inline
-: MCM_GETFIRSTDAYOFWEEK MCM_FIRST 16 + ; inline
-: MCM_GETRANGE MCM_FIRST 17 + ; inline
-: MCM_SETRANGE MCM_FIRST 18 + ; inline
-: MCM_GETMONTHDELTA MCM_FIRST 19 + ; inline
-: MCM_SETMONTHDELTA MCM_FIRST 20 + ; inline
-: MCM_GETMAXTODAYWIDTH MCM_FIRST 21 + ; inline
-: MCM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT ; inline
-: MCM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT ; inline
-: DTM_FIRST HEX: 1000 ; inline
-: DTM_GETSYSTEMTIME DTM_FIRST 1 + ; inline
-: DTM_SETSYSTEMTIME DTM_FIRST 2 + ; inline
-: DTM_GETRANGE DTM_FIRST 3 + ; inline
-: DTM_SETRANGE DTM_FIRST 4 + ; inline
-: DTM_SETFORMATA DTM_FIRST 5 + ; inline
-: DTM_SETFORMATW DTM_FIRST 50 + ; inline
-: DTM_SETMCCOLOR DTM_FIRST 6 + ; inline
-: DTM_GETMCCOLOR DTM_FIRST 7 + ; inline
-: DTM_GETMONTHCAL DTM_FIRST 8 + ; inline
-: DTM_SETMCFONT DTM_FIRST 9 + ; inline
-: DTM_GETMCFONT DTM_FIRST 10 + ; inline
-: PGM_SETCHILD PGM_FIRST 1 + ; inline
-: PGM_RECALCSIZE PGM_FIRST 2 + ; inline
-: PGM_FORWARDMOUSE PGM_FIRST 3 + ; inline
-: PGM_SETBKCOLOR PGM_FIRST 4 + ; inline
-: PGM_GETBKCOLOR PGM_FIRST 5 + ; inline
-: PGM_SETBORDER PGM_FIRST 6 + ; inline
-: PGM_GETBORDER PGM_FIRST 7 + ; inline
-: PGM_SETPOS PGM_FIRST 8 + ; inline
-: PGM_GETPOS PGM_FIRST 9 + ; inline
-: PGM_SETBUTTONSIZE PGM_FIRST 10 + ; inline
-: PGM_GETBUTTONSIZE PGM_FIRST 11 + ; inline
-: PGM_GETBUTTONSTATE PGM_FIRST 12 + ; inline
-: PGM_GETDROPTARGET CCM_GETDROPTARGET ; inline
-: BCM_GETIDEALSIZE BCM_FIRST 1 + ; inline
-: BCM_SETIMAGELIST BCM_FIRST 2 + ; inline
-: BCM_GETIMAGELIST BCM_FIRST 3 + ; inline
-: BCM_SETTEXTMARGIN BCM_FIRST 4 + ; inline
-: BCM_GETTEXTMARGIN BCM_FIRST 5 + ; inline
-: EM_SETCUEBANNER ECM_FIRST 1 + ; inline
-: EM_GETCUEBANNER ECM_FIRST 2 + ; inline
-: EM_SHOWBALLOONTIP ECM_FIRST 3 + ; inline
-: EM_HIDEBALLOONTIP ECM_FIRST 4 + ; inline
-: CB_SETMINVISIBLE CBM_FIRST 1 + ; inline
-: CB_GETMINVISIBLE CBM_FIRST 2 + ; inline
-: LM_HITTEST WM_USER HEX: 0300 + ; inline
-: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline
-: LM_SETITEM WM_USER HEX: 0302 + ; inline
-: LM_GETITEM WM_USER HEX: 0303 + ; inline
+CONSTANT: WM_NULL HEX: 0000
+CONSTANT: WM_CREATE HEX: 0001
+CONSTANT: WM_DESTROY HEX: 0002
+CONSTANT: WM_MOVE HEX: 0003
+CONSTANT: WM_SIZE HEX: 0005
+CONSTANT: WM_ACTIVATE HEX: 0006
+CONSTANT: WM_SETFOCUS HEX: 0007
+CONSTANT: WM_KILLFOCUS HEX: 0008
+CONSTANT: WM_ENABLE HEX: 000A
+CONSTANT: WM_SETREDRAW HEX: 000B
+CONSTANT: WM_SETTEXT HEX: 000C
+CONSTANT: WM_GETTEXT HEX: 000D
+CONSTANT: WM_GETTEXTLENGTH HEX: 000E
+CONSTANT: WM_PAINT HEX: 000F
+CONSTANT: WM_CLOSE HEX: 0010
+CONSTANT: WM_QUERYENDSESSION HEX: 0011
+CONSTANT: WM_QUERYOPEN HEX: 0013
+CONSTANT: WM_ENDSESSION HEX: 0016
+CONSTANT: WM_QUIT HEX: 0012
+CONSTANT: WM_ERASEBKGND HEX: 0014
+CONSTANT: WM_SYSCOLORCHANGE HEX: 0015
+CONSTANT: WM_SHOWWINDOW HEX: 0018
+CONSTANT: WM_WININICHANGE HEX: 001A
+CONSTANT: WM_SETTINGCHANGE HEX: 001A
+CONSTANT: WM_DEVMODECHANGE HEX: 001B
+CONSTANT: WM_ACTIVATEAPP HEX: 001C
+CONSTANT: WM_FONTCHANGE HEX: 001D
+CONSTANT: WM_TIMECHANGE HEX: 001E
+CONSTANT: WM_CANCELMODE HEX: 001F
+CONSTANT: WM_SETCURSOR HEX: 0020
+CONSTANT: WM_MOUSEACTIVATE HEX: 0021
+CONSTANT: WM_CHILDACTIVATE HEX: 0022
+CONSTANT: WM_QUEUESYNC HEX: 0023
+CONSTANT: WM_GETMINMAXINFO HEX: 0024
+CONSTANT: WM_PAINTICON HEX: 0026
+CONSTANT: WM_ICONERASEBKGND HEX: 0027
+CONSTANT: WM_NEXTDLGCTL HEX: 0028
+CONSTANT: WM_SPOOLERSTATUS HEX: 002A
+CONSTANT: WM_DRAWITEM HEX: 002B
+CONSTANT: WM_MEASUREITEM HEX: 002C
+CONSTANT: WM_DELETEITEM HEX: 002D
+CONSTANT: WM_VKEYTOITEM HEX: 002E
+CONSTANT: WM_CHARTOITEM HEX: 002F
+CONSTANT: WM_SETFONT HEX: 0030
+CONSTANT: WM_GETFONT HEX: 0031
+CONSTANT: WM_SETHOTKEY HEX: 0032
+CONSTANT: WM_GETHOTKEY HEX: 0033
+CONSTANT: WM_QUERYDRAGICON HEX: 0037
+CONSTANT: WM_COMPAREITEM HEX: 0039
+CONSTANT: WM_GETOBJECT HEX: 003D
+CONSTANT: WM_COMPACTING HEX: 0041
+CONSTANT: WM_COMMNOTIFY HEX: 0044
+CONSTANT: WM_WINDOWPOSCHANGING HEX: 0046
+CONSTANT: WM_WINDOWPOSCHANGED HEX: 0047
+CONSTANT: WM_POWER HEX: 0048
+CONSTANT: WM_COPYDATA HEX: 004A
+CONSTANT: WM_CANCELJOURNAL HEX: 004B
+CONSTANT: WM_NOTIFY HEX: 004E
+CONSTANT: WM_INPUTLANGCHANGEREQUEST HEX: 0050
+CONSTANT: WM_INPUTLANGCHANGE HEX: 0051
+CONSTANT: WM_TCARD HEX: 0052
+CONSTANT: WM_HELP HEX: 0053
+CONSTANT: WM_USERCHANGED HEX: 0054
+CONSTANT: WM_NOTIFYFORMAT HEX: 0055
+CONSTANT: WM_CONTEXTMENU HEX: 007B
+CONSTANT: WM_STYLECHANGING HEX: 007C
+CONSTANT: WM_STYLECHANGED HEX: 007D
+CONSTANT: WM_DISPLAYCHANGE HEX: 007E
+CONSTANT: WM_GETICON HEX: 007F
+CONSTANT: WM_SETICON HEX: 0080
+CONSTANT: WM_NCCREATE HEX: 0081
+CONSTANT: WM_NCDESTROY HEX: 0082
+CONSTANT: WM_NCCALCSIZE HEX: 0083
+CONSTANT: WM_NCHITTEST HEX: 0084
+CONSTANT: WM_NCPAINT HEX: 0085
+CONSTANT: WM_NCACTIVATE HEX: 0086
+CONSTANT: WM_GETDLGCODE HEX: 0087
+CONSTANT: WM_SYNCPAINT HEX: 0088
+CONSTANT: WM_NCMOUSEMOVE HEX: 00A0
+CONSTANT: WM_NCLBUTTONDOWN HEX: 00A1
+CONSTANT: WM_NCLBUTTONUP HEX: 00A2
+CONSTANT: WM_NCLBUTTONDBLCLK HEX: 00A3
+CONSTANT: WM_NCRBUTTONDOWN HEX: 00A4
+CONSTANT: WM_NCRBUTTONUP HEX: 00A5
+CONSTANT: WM_NCRBUTTONDBLCLK HEX: 00A6
+CONSTANT: WM_NCMBUTTONDOWN HEX: 00A7
+CONSTANT: WM_NCMBUTTONUP HEX: 00A8
+CONSTANT: WM_NCMBUTTONDBLCLK HEX: 00A9
+CONSTANT: WM_NCXBUTTONDOWN HEX: 00AB
+CONSTANT: WM_NCXBUTTONUP HEX: 00AC
+CONSTANT: WM_NCXBUTTONDBLCLK HEX: 00AD
+CONSTANT: WM_NCUAHDRAWCAPTION HEX: 00AE ! undocumented
+CONSTANT: WM_NCUAHDRAWFRAME HEX: 00AF ! undocumented
+CONSTANT: WM_INPUT HEX: 00FF
+CONSTANT: WM_KEYFIRST HEX: 0100
+CONSTANT: WM_KEYDOWN HEX: 0100
+CONSTANT: WM_KEYUP HEX: 0101
+CONSTANT: WM_CHAR HEX: 0102
+CONSTANT: WM_DEADCHAR HEX: 0103
+CONSTANT: WM_SYSKEYDOWN HEX: 0104
+CONSTANT: WM_SYSKEYUP HEX: 0105
+CONSTANT: WM_SYSCHAR HEX: 0106
+CONSTANT: WM_SYSDEADCHAR HEX: 0107
+CONSTANT: WM_UNICHAR HEX: 0109
+CONSTANT: WM_KEYLAST_NT501 HEX: 0109
+CONSTANT: UNICODE_NOCHAR HEX: FFFF
+CONSTANT: WM_KEYLAST_PRE501 HEX: 0108
+CONSTANT: WM_IME_STARTCOMPOSITION HEX: 010D
+CONSTANT: WM_IME_ENDCOMPOSITION HEX: 010E
+CONSTANT: WM_IME_COMPOSITION HEX: 010F
+CONSTANT: WM_IME_KEYLAST HEX: 010F
+CONSTANT: WM_INITDIALOG HEX: 0110
+CONSTANT: WM_COMMAND HEX: 0111
+CONSTANT: WM_SYSCOMMAND HEX: 0112
+CONSTANT: WM_TIMER HEX: 0113
+CONSTANT: WM_HSCROLL HEX: 0114
+CONSTANT: WM_VSCROLL HEX: 0115
+CONSTANT: WM_INITMENU HEX: 0116
+CONSTANT: WM_INITMENUPOPUP HEX: 0117
+CONSTANT: WM_MENUSELECT HEX: 011F
+CONSTANT: WM_MENUCHAR HEX: 0120
+CONSTANT: WM_ENTERIDLE HEX: 0121
+CONSTANT: WM_MENURBUTTONUP HEX: 0122
+CONSTANT: WM_MENUDRAG HEX: 0123
+CONSTANT: WM_MENUGETOBJECT HEX: 0124
+CONSTANT: WM_UNINITMENUPOPUP HEX: 0125
+CONSTANT: WM_MENUCOMMAND HEX: 0126
+CONSTANT: WM_CHANGEUISTATE HEX: 0127
+CONSTANT: WM_UPDATEUISTATE HEX: 0128
+CONSTANT: WM_QUERYUISTATE HEX: 0129
+CONSTANT: WM_CTLCOLORMSGBOX HEX: 0132
+CONSTANT: WM_CTLCOLOREDIT HEX: 0133
+CONSTANT: WM_CTLCOLORLISTBOX HEX: 0134
+CONSTANT: WM_CTLCOLORBTN HEX: 0135
+CONSTANT: WM_CTLCOLORDLG HEX: 0136
+CONSTANT: WM_CTLCOLORSCROLLBAR HEX: 0137
+CONSTANT: WM_CTLCOLORSTATIC HEX: 0138
+CONSTANT: WM_MOUSEFIRST HEX: 0200
+CONSTANT: WM_MOUSEMOVE HEX: 0200
+CONSTANT: WM_LBUTTONDOWN HEX: 0201
+CONSTANT: WM_LBUTTONUP HEX: 0202
+CONSTANT: WM_LBUTTONDBLCLK HEX: 0203
+CONSTANT: WM_RBUTTONDOWN HEX: 0204
+CONSTANT: WM_RBUTTONUP HEX: 0205
+CONSTANT: WM_RBUTTONDBLCLK HEX: 0206
+CONSTANT: WM_MBUTTONDOWN HEX: 0207
+CONSTANT: WM_MBUTTONUP HEX: 0208
+CONSTANT: WM_MBUTTONDBLCLK HEX: 0209
+CONSTANT: WM_MOUSEWHEEL HEX: 020A
+CONSTANT: WM_XBUTTONDOWN HEX: 020B
+CONSTANT: WM_XBUTTONUP HEX: 020C
+CONSTANT: WM_XBUTTONDBLCLK HEX: 020D
+CONSTANT: WM_MOUSELAST_5 HEX: 020D
+CONSTANT: WM_MOUSELAST_4 HEX: 020A
+CONSTANT: WM_MOUSELAST_PRE_4 HEX: 0209
+CONSTANT: WM_PARENTNOTIFY HEX: 0210
+CONSTANT: WM_ENTERMENULOOP HEX: 0211
+CONSTANT: WM_EXITMENULOOP HEX: 0212
+CONSTANT: WM_NEXTMENU HEX: 0213
+CONSTANT: WM_SIZING HEX: 0214
+CONSTANT: WM_CAPTURECHANGED HEX: 0215
+CONSTANT: WM_MOVING HEX: 0216
+CONSTANT: WM_POWERBROADCAST HEX: 0218
+CONSTANT: WM_DEVICECHANGE HEX: 0219
+CONSTANT: WM_MDICREATE HEX: 0220
+CONSTANT: WM_MDIDESTROY HEX: 0221
+CONSTANT: WM_MDIACTIVATE HEX: 0222
+CONSTANT: WM_MDIRESTORE HEX: 0223
+CONSTANT: WM_MDINEXT HEX: 0224
+CONSTANT: WM_MDIMAXIMIZE HEX: 0225
+CONSTANT: WM_MDITILE HEX: 0226
+CONSTANT: WM_MDICASCADE HEX: 0227
+CONSTANT: WM_MDIICONARRANGE HEX: 0228
+CONSTANT: WM_MDIGETACTIVE HEX: 0229
+CONSTANT: WM_MDISETMENU HEX: 0230
+CONSTANT: WM_ENTERSIZEMOVE HEX: 0231
+CONSTANT: WM_EXITSIZEMOVE HEX: 0232
+CONSTANT: WM_DROPFILES HEX: 0233
+CONSTANT: WM_MDIREFRESHMENU HEX: 0234
+CONSTANT: WM_IME_SETCONTEXT HEX: 0281
+CONSTANT: WM_IME_NOTIFY HEX: 0282
+CONSTANT: WM_IME_CONTROL HEX: 0283
+CONSTANT: WM_IME_COMPOSITIONFULL HEX: 0284
+CONSTANT: WM_IME_SELECT HEX: 0285
+CONSTANT: WM_IME_CHAR HEX: 0286
+CONSTANT: WM_IME_REQUEST HEX: 0288
+CONSTANT: WM_IME_KEYDOWN HEX: 0290
+CONSTANT: WM_IME_KEYUP HEX: 0291
+CONSTANT: WM_MOUSEHOVER HEX: 02A1
+CONSTANT: WM_MOUSELEAVE HEX: 02A3
+CONSTANT: WM_NCMOUSEHOVER HEX: 02A0
+CONSTANT: WM_NCMOUSELEAVE HEX: 02A2
+CONSTANT: WM_WTSSESSION_CHANGE HEX: 02B1
+CONSTANT: WM_TABLET_FIRST HEX: 02c0
+CONSTANT: WM_TABLET_LAST HEX: 02df
+CONSTANT: WM_CUT HEX: 0300
+CONSTANT: WM_COPY HEX: 0301
+CONSTANT: WM_PASTE HEX: 0302
+CONSTANT: WM_CLEAR HEX: 0303
+CONSTANT: WM_UNDO HEX: 0304
+CONSTANT: WM_RENDERFORMAT HEX: 0305
+CONSTANT: WM_RENDERALLFORMATS HEX: 0306
+CONSTANT: WM_DESTROYCLIPBOARD HEX: 0307
+CONSTANT: WM_DRAWCLIPBOARD HEX: 0308
+CONSTANT: WM_PAINTCLIPBOARD HEX: 0309
+CONSTANT: WM_VSCROLLCLIPBOARD HEX: 030A
+CONSTANT: WM_SIZECLIPBOARD HEX: 030B
+CONSTANT: WM_ASKCBFORMATNAME HEX: 030C
+CONSTANT: WM_CHANGECBCHAIN HEX: 030D
+CONSTANT: WM_HSCROLLCLIPBOARD HEX: 030E
+CONSTANT: WM_QUERYNEWPALETTE HEX: 030F
+CONSTANT: WM_PALETTEISCHANGING HEX: 0310
+CONSTANT: WM_PALETTECHANGED HEX: 0311
+CONSTANT: WM_HOTKEY HEX: 0312
+CONSTANT: WM_PRINT HEX: 0317
+CONSTANT: WM_PRINTCLIENT HEX: 0318
+CONSTANT: WM_APPCOMMAND HEX: 0319
+CONSTANT: WM_THEMECHANGED HEX: 031A
+CONSTANT: WM_HANDHELDFIRST HEX: 0358
+CONSTANT: WM_HANDHELDLAST HEX: 035F
+CONSTANT: WM_AFXFIRST HEX: 0360
+CONSTANT: WM_AFXLAST HEX: 037F
+CONSTANT: WM_PENWINFIRST HEX: 0380
+CONSTANT: WM_PENWINLAST HEX: 038F
+CONSTANT: WM_APP HEX: 8000
+CONSTANT: WM_USER HEX: 0400
+CONSTANT: EM_GETSEL HEX: 00B0
+CONSTANT: EM_SETSEL HEX: 00B1
+CONSTANT: EM_GETRECT HEX: 00B2
+CONSTANT: EM_SETRECT HEX: 00B3
+CONSTANT: EM_SETRECTNP HEX: 00B4
+CONSTANT: EM_SCROLL HEX: 00B5
+CONSTANT: EM_LINESCROLL HEX: 00B6
+CONSTANT: EM_SCROLLCARET HEX: 00B7
+CONSTANT: EM_GETMODIFY HEX: 00B8
+CONSTANT: EM_SETMODIFY HEX: 00B9
+CONSTANT: EM_GETLINECOUNT HEX: 00BA
+CONSTANT: EM_LINEINDEX HEX: 00BB
+CONSTANT: EM_SETHANDLE HEX: 00BC
+CONSTANT: EM_GETHANDLE HEX: 00BD
+CONSTANT: EM_GETTHUMB HEX: 00BE
+CONSTANT: EM_LINELENGTH HEX: 00C1
+CONSTANT: EM_REPLACESEL HEX: 00C2
+CONSTANT: EM_GETLINE HEX: 00C4
+CONSTANT: EM_LIMITTEXT HEX: 00C5
+CONSTANT: EM_CANUNDO HEX: 00C6
+CONSTANT: EM_UNDO HEX: 00C7
+CONSTANT: EM_FMTLINES HEX: 00C8
+CONSTANT: EM_LINEFROMCHAR HEX: 00C9
+CONSTANT: EM_SETTABSTOPS HEX: 00CB
+CONSTANT: EM_SETPASSWORDCHAR HEX: 00CC
+CONSTANT: EM_EMPTYUNDOBUFFER HEX: 00CD
+CONSTANT: EM_GETFIRSTVISIBLELINE HEX: 00CE
+CONSTANT: EM_SETREADONLY HEX: 00CF
+CONSTANT: EM_SETWORDBREAKPROC HEX: 00D0
+CONSTANT: EM_GETWORDBREAKPROC HEX: 00D1
+CONSTANT: EM_GETPASSWORDCHAR HEX: 00D2
+CONSTANT: EM_SETMARGINS HEX: 00D3
+CONSTANT: EM_GETMARGINS HEX: 00D4
+ALIAS: EM_SETLIMITTEXT EM_LIMITTEXT
+CONSTANT: EM_GETLIMITTEXT HEX: 00D5
+CONSTANT: EM_POSFROMCHAR HEX: 00D6
+CONSTANT: EM_CHARFROMPOS HEX: 00D7
+CONSTANT: EM_SETIMESTATUS HEX: 00D8
+CONSTANT: EM_GETIMESTATUS HEX: 00D9
+CONSTANT: BM_GETCHECK HEX: 00F0
+CONSTANT: BM_SETCHECK HEX: 00F1
+CONSTANT: BM_GETSTATE HEX: 00F2
+CONSTANT: BM_SETSTATE HEX: 00F3
+CONSTANT: BM_SETSTYLE HEX: 00F4
+CONSTANT: BM_CLICK HEX: 00F5
+CONSTANT: BM_GETIMAGE HEX: 00F6
+CONSTANT: BM_SETIMAGE HEX: 00F7
+CONSTANT: STM_SETICON HEX: 0170
+CONSTANT: STM_GETICON HEX: 0171
+CONSTANT: STM_SETIMAGE HEX: 0172
+CONSTANT: STM_GETIMAGE HEX: 0173
+CONSTANT: STM_MSGMAX HEX: 0174
+CONSTANT: DM_GETDEFID WM_USER
+: DM_SETDEFID ( -- n ) ( -- n ) WM_USER 1 + ; inline
+: DM_REPOSITION ( -- n ) ( -- n ) WM_USER 2 + ; inline
+CONSTANT: LB_ADDSTRING HEX: 0180
+CONSTANT: LB_INSERTSTRING HEX: 0181
+CONSTANT: LB_DELETESTRING HEX: 0182
+CONSTANT: LB_SELITEMRANGEEX HEX: 0183
+CONSTANT: LB_RESETCONTENT HEX: 0184
+CONSTANT: LB_SETSEL HEX: 0185
+CONSTANT: LB_SETCURSEL HEX: 0186
+CONSTANT: LB_GETSEL HEX: 0187
+CONSTANT: LB_GETCURSEL HEX: 0188
+CONSTANT: LB_GETTEXT HEX: 0189
+CONSTANT: LB_GETTEXTLEN HEX: 018A
+CONSTANT: LB_GETCOUNT HEX: 018B
+CONSTANT: LB_SELECTSTRING HEX: 018C
+CONSTANT: LB_DIR HEX: 018D
+CONSTANT: LB_GETTOPINDEX HEX: 018E
+CONSTANT: LB_FINDSTRING HEX: 018F
+CONSTANT: LB_GETSELCOUNT HEX: 0190
+CONSTANT: LB_GETSELITEMS HEX: 0191
+CONSTANT: LB_SETTABSTOPS HEX: 0192
+CONSTANT: LB_GETHORIZONTALEXTENT HEX: 0193
+CONSTANT: LB_SETHORIZONTALEXTENT HEX: 0194
+CONSTANT: LB_SETCOLUMNWIDTH HEX: 0195
+CONSTANT: LB_ADDFILE HEX: 0196
+CONSTANT: LB_SETTOPINDEX HEX: 0197
+CONSTANT: LB_GETITEMRECT HEX: 0198
+CONSTANT: LB_GETITEMDATA HEX: 0199
+CONSTANT: LB_SETITEMDATA HEX: 019A
+CONSTANT: LB_SELITEMRANGE HEX: 019B
+CONSTANT: LB_SETANCHORINDEX HEX: 019C
+CONSTANT: LB_GETANCHORINDEX HEX: 019D
+CONSTANT: LB_SETCARETINDEX HEX: 019E
+CONSTANT: LB_GETCARETINDEX HEX: 019F
+CONSTANT: LB_SETITEMHEIGHT HEX: 01A0
+CONSTANT: LB_GETITEMHEIGHT HEX: 01A1
+CONSTANT: LB_FINDSTRINGEXACT HEX: 01A2
+CONSTANT: LB_SETLOCALE HEX: 01A5
+CONSTANT: LB_GETLOCALE HEX: 01A6
+CONSTANT: LB_SETCOUNT HEX: 01A7
+CONSTANT: LB_INITSTORAGE HEX: 01A8
+CONSTANT: LB_ITEMFROMPOINT HEX: 01A9
+CONSTANT: LB_MULTIPLEADDSTRING HEX: 01B1
+CONSTANT: LB_GETLISTBOXINFO HEX: 01B2
+CONSTANT: LB_MSGMAX_501 HEX: 01B3
+CONSTANT: LB_MSGMAX_WCE4 HEX: 01B1
+CONSTANT: LB_MSGMAX_4 HEX: 01B0
+CONSTANT: LB_MSGMAX_PRE4 HEX: 01A8
+CONSTANT: CB_GETEDITSEL HEX: 0140
+CONSTANT: CB_LIMITTEXT HEX: 0141
+CONSTANT: CB_SETEDITSEL HEX: 0142
+CONSTANT: CB_ADDSTRING HEX: 0143
+CONSTANT: CB_DELETESTRING HEX: 0144
+CONSTANT: CB_DIR HEX: 0145
+CONSTANT: CB_GETCOUNT HEX: 0146
+CONSTANT: CB_GETCURSEL HEX: 0147
+CONSTANT: CB_GETLBTEXT HEX: 0148
+CONSTANT: CB_GETLBTEXTLEN HEX: 0149
+CONSTANT: CB_INSERTSTRING HEX: 014A
+CONSTANT: CB_RESETCONTENT HEX: 014B
+CONSTANT: CB_FINDSTRING HEX: 014C
+CONSTANT: CB_SELECTSTRING HEX: 014D
+CONSTANT: CB_SETCURSEL HEX: 014E
+CONSTANT: CB_SHOWDROPDOWN HEX: 014F
+CONSTANT: CB_GETITEMDATA HEX: 0150
+CONSTANT: CB_SETITEMDATA HEX: 0151
+CONSTANT: CB_GETDROPPEDCONTROLRECT HEX: 0152
+CONSTANT: CB_SETITEMHEIGHT HEX: 0153
+CONSTANT: CB_GETITEMHEIGHT HEX: 0154
+CONSTANT: CB_SETEXTENDEDUI HEX: 0155
+CONSTANT: CB_GETEXTENDEDUI HEX: 0156
+CONSTANT: CB_GETDROPPEDSTATE HEX: 0157
+CONSTANT: CB_FINDSTRINGEXACT HEX: 0158
+CONSTANT: CB_SETLOCALE HEX: 0159
+CONSTANT: CB_GETLOCALE HEX: 015A
+CONSTANT: CB_GETTOPINDEX HEX: 015B
+CONSTANT: CB_SETTOPINDEX HEX: 015C
+CONSTANT: CB_GETHORIZONTALEXTENT HEX: 015d
+CONSTANT: CB_SETHORIZONTALEXTENT HEX: 015e
+CONSTANT: CB_GETDROPPEDWIDTH HEX: 015f
+CONSTANT: CB_SETDROPPEDWIDTH HEX: 0160
+CONSTANT: CB_INITSTORAGE HEX: 0161
+CONSTANT: CB_MULTIPLEADDSTRING HEX: 0163
+CONSTANT: CB_GETCOMBOBOXINFO HEX: 0164
+CONSTANT: CB_MSGMAX_501 HEX: 0165
+CONSTANT: CB_MSGMAX_WCE400 HEX: 0163
+CONSTANT: CB_MSGMAX_400 HEX: 0162
+CONSTANT: CB_MSGMAX_PRE400 HEX: 015B
+CONSTANT: SBM_SETPOS HEX: 00E0
+CONSTANT: SBM_GETPOS HEX: 00E1
+CONSTANT: SBM_SETRANGE HEX: 00E2
+CONSTANT: SBM_SETRANGEREDRAW HEX: 00E6
+CONSTANT: SBM_GETRANGE HEX: 00E3
+CONSTANT: SBM_ENABLE_ARROWS HEX: 00E4
+CONSTANT: SBM_SETSCROLLINFO HEX: 00E9
+CONSTANT: SBM_GETSCROLLINFO HEX: 00EA
+CONSTANT: SBM_GETSCROLLBARINFO HEX: 00EB
+CONSTANT: LVM_FIRST HEX: 1000 ! ListView messages
+CONSTANT: TV_FIRST HEX: 1100 ! TreeView messages
+CONSTANT: HDM_FIRST HEX: 1200 ! Header messages
+CONSTANT: TCM_FIRST HEX: 1300 ! Tab control messages
+CONSTANT: PGM_FIRST HEX: 1400 ! Pager control messages
+CONSTANT: ECM_FIRST HEX: 1500 ! Edit control messages
+CONSTANT: BCM_FIRST HEX: 1600 ! Button control messages
+CONSTANT: CBM_FIRST HEX: 1700 ! Combobox control messages
+CONSTANT: CCM_FIRST HEX: 2000 ! Common control shared messages
+: CCM_LAST ( -- n ) CCM_FIRST HEX: 0200 + ; inline
+: CCM_SETBKCOLOR ( -- n ) CCM_FIRST 1 + ; inline
+: CCM_SETCOLORSCHEME ( -- n ) CCM_FIRST 2 + ; inline
+: CCM_GETCOLORSCHEME ( -- n ) CCM_FIRST 3 + ; inline
+: CCM_GETDROPTARGET ( -- n ) CCM_FIRST 4 + ; inline
+: CCM_SETUNICODEFORMAT ( -- n ) CCM_FIRST 5 + ; inline
+: CCM_GETUNICODEFORMAT ( -- n ) CCM_FIRST 6 + ; inline
+: CCM_SETVERSION ( -- n ) CCM_FIRST 7 + ; inline
+: CCM_GETVERSION ( -- n ) CCM_FIRST 8 + ; inline
+: CCM_SETNOTIFYWINDOW ( -- n ) CCM_FIRST 9 + ; inline
+: CCM_SETWINDOWTHEME ( -- n ) CCM_FIRST HEX: b + ; inline
+: CCM_DPISCALE ( -- n ) CCM_FIRST HEX: c + ; inline
+: HDM_GETITEMCOUNT ( -- n ) HDM_FIRST 0 + ; inline
+: HDM_INSERTITEMA ( -- n ) HDM_FIRST 1 + ; inline
+: HDM_INSERTITEMW ( -- n ) HDM_FIRST 10 + ; inline
+: HDM_DELETEITEM ( -- n ) HDM_FIRST 2 + ; inline
+: HDM_GETITEMA ( -- n ) HDM_FIRST 3 + ; inline
+: HDM_GETITEMW ( -- n ) HDM_FIRST 11 + ; inline
+: HDM_SETITEMA ( -- n ) HDM_FIRST 4 + ; inline
+: HDM_SETITEMW ( -- n ) HDM_FIRST 12 + ; inline
+: HDM_LAYOUT ( -- n ) HDM_FIRST 5 + ; inline
+: HDM_HITTEST ( -- n ) HDM_FIRST 6 + ; inline
+: HDM_GETITEMRECT ( -- n ) HDM_FIRST 7 + ; inline
+: HDM_SETIMAGELIST ( -- n ) HDM_FIRST 8 + ; inline
+: HDM_GETIMAGELIST ( -- n ) HDM_FIRST 9 + ; inline
+: HDM_ORDERTOINDEX ( -- n ) HDM_FIRST 15 + ; inline
+: HDM_CREATEDRAGIMAGE ( -- n ) HDM_FIRST 16 + ; inline
+: HDM_GETORDERARRAY ( -- n ) HDM_FIRST 17 + ; inline
+: HDM_SETORDERARRAY ( -- n ) HDM_FIRST 18 + ; inline
+: HDM_SETHOTDIVIDER ( -- n ) HDM_FIRST 19 + ; inline
+: HDM_SETBITMAPMARGIN ( -- n ) HDM_FIRST 20 + ; inline
+: HDM_GETBITMAPMARGIN ( -- n ) HDM_FIRST 21 + ; inline
+CONSTANT: HDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+CONSTANT: HDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+: HDM_SETFILTERCHANGETIMEOUT ( -- n ) HDM_FIRST 22 + ; inline
+: HDM_EDITFILTER ( -- n ) HDM_FIRST 23 + ; inline
+: HDM_CLEARFILTER ( -- n ) HDM_FIRST 24 + ; inline
+: TB_ENABLEBUTTON ( -- n ) WM_USER 1 + ; inline
+: TB_CHECKBUTTON ( -- n ) WM_USER 2 + ; inline
+: TB_PRESSBUTTON ( -- n ) WM_USER 3 + ; inline
+: TB_HIDEBUTTON ( -- n ) WM_USER 4 + ; inline
+: TB_INDETERMINATE ( -- n ) WM_USER 5 + ; inline
+: TB_MARKBUTTON ( -- n ) WM_USER 6 + ; inline
+: TB_ISBUTTONENABLED ( -- n ) WM_USER 9 + ; inline
+: TB_ISBUTTONCHECKED ( -- n ) WM_USER 10 + ; inline
+: TB_ISBUTTONPRESSED ( -- n ) WM_USER 11 + ; inline
+: TB_ISBUTTONHIDDEN ( -- n ) WM_USER 12 + ; inline
+: TB_ISBUTTONINDETERMINATE ( -- n ) WM_USER 13 + ; inline
+: TB_ISBUTTONHIGHLIGHTED ( -- n ) WM_USER 14 + ; inline
+: TB_SETSTATE ( -- n ) WM_USER 17 + ; inline
+: TB_GETSTATE ( -- n ) WM_USER 18 + ; inline
+: TB_ADDBITMAP ( -- n ) WM_USER 19 + ; inline
+: TB_ADDBUTTONSA ( -- n ) WM_USER 20 + ; inline
+: TB_INSERTBUTTONA ( -- n ) WM_USER 21 + ; inline
+: TB_ADDBUTTONS ( -- n ) WM_USER 20 + ; inline
+: TB_INSERTBUTTON ( -- n ) WM_USER 21 + ; inline
+: TB_DELETEBUTTON ( -- n ) WM_USER 22 + ; inline
+: TB_GETBUTTON ( -- n ) WM_USER 23 + ; inline
+: TB_BUTTONCOUNT ( -- n ) WM_USER 24 + ; inline
+: TB_COMMANDTOINDEX ( -- n ) WM_USER 25 + ; inline
+: TB_SAVERESTOREA ( -- n ) WM_USER 26 + ; inline
+: TB_SAVERESTOREW ( -- n ) WM_USER 76 + ; inline
+: TB_CUSTOMIZE ( -- n ) WM_USER 27 + ; inline
+: TB_ADDSTRINGA ( -- n ) WM_USER 28 + ; inline
+: TB_ADDSTRINGW ( -- n ) WM_USER 77 + ; inline
+: TB_GETITEMRECT ( -- n ) WM_USER 29 + ; inline
+: TB_BUTTONSTRUCTSIZE ( -- n ) WM_USER 30 + ; inline
+: TB_SETBUTTONSIZE ( -- n ) WM_USER 31 + ; inline
+: TB_SETBITMAPSIZE ( -- n ) WM_USER 32 + ; inline
+: TB_AUTOSIZE ( -- n ) WM_USER 33 + ; inline
+: TB_GETTOOLTIPS ( -- n ) WM_USER 35 + ; inline
+: TB_SETTOOLTIPS ( -- n ) WM_USER 36 + ; inline
+: TB_SETPARENT ( -- n ) WM_USER 37 + ; inline
+: TB_SETROWS ( -- n ) WM_USER 39 + ; inline
+: TB_GETROWS ( -- n ) WM_USER 40 + ; inline
+: TB_SETCMDID ( -- n ) WM_USER 42 + ; inline
+: TB_CHANGEBITMAP ( -- n ) WM_USER 43 + ; inline
+: TB_GETBITMAP ( -- n ) WM_USER 44 + ; inline
+: TB_GETBUTTONTEXTA ( -- n ) WM_USER 45 + ; inline
+: TB_GETBUTTONTEXTW ( -- n ) WM_USER 75 + ; inline
+: TB_REPLACEBITMAP ( -- n ) WM_USER 46 + ; inline
+: TB_SETINDENT ( -- n ) WM_USER 47 + ; inline
+: TB_SETIMAGELIST ( -- n ) WM_USER 48 + ; inline
+: TB_GETIMAGELIST ( -- n ) WM_USER 49 + ; inline
+: TB_LOADIMAGES ( -- n ) WM_USER 50 + ; inline
+: TB_GETRECT ( -- n ) WM_USER 51 + ; inline
+: TB_SETHOTIMAGELIST ( -- n ) WM_USER 52 + ; inline
+: TB_GETHOTIMAGELIST ( -- n ) WM_USER 53 + ; inline
+: TB_SETDISABLEDIMAGELIST ( -- n ) WM_USER 54 + ; inline
+: TB_GETDISABLEDIMAGELIST ( -- n ) WM_USER 55 + ; inline
+: TB_SETSTYLE ( -- n ) WM_USER 56 + ; inline
+: TB_GETSTYLE ( -- n ) WM_USER 57 + ; inline
+: TB_GETBUTTONSIZE ( -- n ) WM_USER 58 + ; inline
+: TB_SETBUTTONWIDTH ( -- n ) WM_USER 59 + ; inline
+: TB_SETMAXTEXTROWS ( -- n ) WM_USER 60 + ; inline
+: TB_GETTEXTROWS ( -- n ) WM_USER 61 + ; inline
+: TB_GETOBJECT ( -- n ) WM_USER 62 + ; inline
+: TB_GETHOTITEM ( -- n ) WM_USER 71 + ; inline
+: TB_SETHOTITEM ( -- n ) WM_USER 72 + ; inline
+: TB_SETANCHORHIGHLIGHT ( -- n ) WM_USER 73 + ; inline
+: TB_GETANCHORHIGHLIGHT ( -- n ) WM_USER 74 + ; inline
+: TB_MAPACCELERATORA ( -- n ) WM_USER 78 + ; inline
+: TB_GETINSERTMARK ( -- n ) WM_USER 79 + ; inline
+: TB_SETINSERTMARK ( -- n ) WM_USER 80 + ; inline
+: TB_INSERTMARKHITTEST ( -- n ) WM_USER 81 + ; inline
+: TB_MOVEBUTTON ( -- n ) WM_USER 82 + ; inline
+: TB_GETMAXSIZE ( -- n ) WM_USER 83 + ; inline
+: TB_SETEXTENDEDSTYLE ( -- n ) WM_USER 84 + ; inline
+: TB_GETEXTENDEDSTYLE ( -- n ) WM_USER 85 + ; inline
+: TB_GETPADDING ( -- n ) WM_USER 86 + ; inline
+: TB_SETPADDING ( -- n ) WM_USER 87 + ; inline
+: TB_SETINSERTMARKCOLOR ( -- n ) WM_USER 88 + ; inline
+: TB_GETINSERTMARKCOLOR ( -- n ) WM_USER 89 + ; inline
+ALIAS: TB_SETCOLORSCHEME CCM_SETCOLORSCHEME
+ALIAS: TB_GETCOLORSCHEME CCM_GETCOLORSCHEME
+ALIAS: TB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+ALIAS: TB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+: TB_MAPACCELERATORW ( -- n ) WM_USER 90 + ; inline
+: TB_GETBITMAPFLAGS ( -- n ) WM_USER 41 + ; inline
+: TB_GETBUTTONINFOW ( -- n ) WM_USER 63 + ; inline
+: TB_SETBUTTONINFOW ( -- n ) WM_USER 64 + ; inline
+: TB_GETBUTTONINFOA ( -- n ) WM_USER 65 + ; inline
+: TB_SETBUTTONINFOA ( -- n ) WM_USER 66 + ; inline
+: TB_INSERTBUTTONW ( -- n ) WM_USER 67 + ; inline
+: TB_ADDBUTTONSW ( -- n ) WM_USER 68 + ; inline
+: TB_HITTEST ( -- n ) WM_USER 69 + ; inline
+: TB_SETDRAWTEXTFLAGS ( -- n ) WM_USER 70 + ; inline
+: TB_GETSTRINGW ( -- n ) WM_USER 91 + ; inline
+: TB_GETSTRINGA ( -- n ) WM_USER 92 + ; inline
+: TB_GETMETRICS ( -- n ) WM_USER 101 + ; inline
+: TB_SETMETRICS ( -- n ) WM_USER 102 + ; inline
+ALIAS: TB_SETWINDOWTHEME CCM_SETWINDOWTHEME
+: RB_INSERTBANDA ( -- n ) WM_USER 1 + ; inline
+: RB_DELETEBAND ( -- n ) WM_USER 2 + ; inline
+: RB_GETBARINFO ( -- n ) WM_USER 3 + ; inline
+: RB_SETBARINFO ( -- n ) WM_USER 4 + ; inline
+: RB_GETBANDINFO ( -- n ) WM_USER 5 + ; inline
+: RB_SETBANDINFOA ( -- n ) WM_USER 6 + ; inline
+: RB_SETPARENT ( -- n ) WM_USER 7 + ; inline
+: RB_HITTEST ( -- n ) WM_USER 8 + ; inline
+: RB_GETRECT ( -- n ) WM_USER 9 + ; inline
+: RB_INSERTBANDW ( -- n ) WM_USER 10 + ; inline
+: RB_SETBANDINFOW ( -- n ) WM_USER 11 + ; inline
+: RB_GETBANDCOUNT ( -- n ) WM_USER 12 + ; inline
+: RB_GETROWCOUNT ( -- n ) WM_USER 13 + ; inline
+: RB_GETROWHEIGHT ( -- n ) WM_USER 14 + ; inline
+: RB_IDTOINDEX ( -- n ) WM_USER 16 + ; inline
+: RB_GETTOOLTIPS ( -- n ) WM_USER 17 + ; inline
+: RB_SETTOOLTIPS ( -- n ) WM_USER 18 + ; inline
+: RB_SETBKCOLOR ( -- n ) WM_USER 19 + ; inline
+: RB_GETBKCOLOR ( -- n ) WM_USER 20 + ; inline
+: RB_SETTEXTCOLOR ( -- n ) WM_USER 21 + ; inline
+: RB_GETTEXTCOLOR ( -- n ) WM_USER 22 + ; inline
+: RB_SIZETORECT ( -- n ) WM_USER 23 + ; inline
+CONSTANT: RB_SETCOLORSCHEME CCM_SETCOLORSCHEME
+CONSTANT: RB_GETCOLORSCHEME CCM_GETCOLORSCHEME
+: RB_BEGINDRAG ( -- n ) WM_USER 24 + ; inline
+: RB_ENDDRAG ( -- n ) WM_USER 25 + ; inline
+: RB_DRAGMOVE ( -- n ) WM_USER 26 + ; inline
+: RB_GETBARHEIGHT ( -- n ) WM_USER 27 + ; inline
+: RB_GETBANDINFOW ( -- n ) WM_USER 28 + ; inline
+: RB_GETBANDINFOA ( -- n ) WM_USER 29 + ; inline
+: RB_MINIMIZEBAND ( -- n ) WM_USER 30 + ; inline
+: RB_MAXIMIZEBAND ( -- n ) WM_USER 31 + ; inline
+ALIAS: RB_GETDROPTARGET CCM_GETDROPTARGET
+: RB_GETBANDBORDERS ( -- n ) WM_USER 34 + ; inline
+: RB_SHOWBAND ( -- n ) WM_USER 35 + ; inline
+: RB_SETPALETTE ( -- n ) WM_USER 37 + ; inline
+: RB_GETPALETTE ( -- n ) WM_USER 38 + ; inline
+: RB_MOVEBAND ( -- n ) WM_USER 39 + ; inline
+CONSTANT: RB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+CONSTANT: RB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+: RB_GETBANDMARGINS ( -- n ) WM_USER 40 + ; inline
+ALIAS: RB_SETWINDOWTHEME CCM_SETWINDOWTHEME
+: RB_PUSHCHEVRON ( -- n ) WM_USER 43 + ; inline
+: TTM_ACTIVATE ( -- n ) WM_USER 1 + ; inline
+: TTM_SETDELAYTIME ( -- n ) WM_USER 3 + ; inline
+: TTM_ADDTOOLA ( -- n ) WM_USER 4 + ; inline
+: TTM_ADDTOOLW ( -- n ) WM_USER 50 + ; inline
+: TTM_DELTOOLA ( -- n ) WM_USER 5 + ; inline
+: TTM_DELTOOLW ( -- n ) WM_USER 51 + ; inline
+: TTM_NEWTOOLRECTA ( -- n ) WM_USER 6 + ; inline
+: TTM_NEWTOOLRECTW ( -- n ) WM_USER 52 + ; inline
+: TTM_RELAYEVENT ( -- n ) WM_USER 7 + ; inline
+: TTM_GETTOOLINFOA ( -- n ) WM_USER 8 + ; inline
+: TTM_GETTOOLINFOW ( -- n ) WM_USER 53 + ; inline
+: TTM_SETTOOLINFOA ( -- n ) WM_USER 9 + ; inline
+: TTM_SETTOOLINFOW ( -- n ) WM_USER 54 + ; inline
+: TTM_HITTESTA ( -- n ) WM_USER 10 + ; inline
+: TTM_HITTESTW ( -- n ) WM_USER 55 + ; inline
+: TTM_GETTEXTA ( -- n ) WM_USER 11 + ; inline
+: TTM_GETTEXTW ( -- n ) WM_USER 56 + ; inline
+: TTM_UPDATETIPTEXTA ( -- n ) WM_USER 12 + ; inline
+: TTM_UPDATETIPTEXTW ( -- n ) WM_USER 57 + ; inline
+: TTM_GETTOOLCOUNT ( -- n ) WM_USER 13 + ; inline
+: TTM_ENUMTOOLSA ( -- n ) WM_USER 14 + ; inline
+: TTM_ENUMTOOLSW ( -- n ) WM_USER 58 + ; inline
+: TTM_GETCURRENTTOOLA ( -- n ) WM_USER 15 + ; inline
+: TTM_GETCURRENTTOOLW ( -- n ) WM_USER 59 + ; inline
+: TTM_WINDOWFROMPOINT ( -- n ) WM_USER 16 + ; inline
+: TTM_TRACKACTIVATE ( -- n ) WM_USER 17 + ; inline
+: TTM_TRACKPOSITION ( -- n ) WM_USER 18 + ; inline
+: TTM_SETTIPBKCOLOR ( -- n ) WM_USER 19 + ; inline
+: TTM_SETTIPTEXTCOLOR ( -- n ) WM_USER 20 + ; inline
+: TTM_GETDELAYTIME ( -- n ) WM_USER 21 + ; inline
+: TTM_GETTIPBKCOLOR ( -- n ) WM_USER 22 + ; inline
+: TTM_GETTIPTEXTCOLOR ( -- n ) WM_USER 23 + ; inline
+: TTM_SETMAXTIPWIDTH ( -- n ) WM_USER 24 + ; inline
+: TTM_GETMAXTIPWIDTH ( -- n ) WM_USER 25 + ; inline
+: TTM_SETMARGIN ( -- n ) WM_USER 26 + ; inline
+: TTM_GETMARGIN ( -- n ) WM_USER 27 + ; inline
+: TTM_POP ( -- n ) WM_USER 28 + ; inline
+: TTM_UPDATE ( -- n ) WM_USER 29 + ; inline
+: TTM_GETBUBBLESIZE ( -- n ) WM_USER 30 + ; inline
+: TTM_ADJUSTRECT ( -- n ) WM_USER 31 + ; inline
+: TTM_SETTITLEA ( -- n ) WM_USER 32 + ; inline
+: TTM_SETTITLEW ( -- n ) WM_USER 33 + ; inline
+: TTM_POPUP ( -- n ) WM_USER 34 + ; inline
+: TTM_GETTITLE ( -- n ) WM_USER 35 + ; inline
+ALIAS: TTM_SETWINDOWTHEME CCM_SETWINDOWTHEME
+: SB_SETTEXTA ( -- n ) WM_USER 1 + ; inline
+: SB_SETTEXTW ( -- n ) WM_USER 11 + ; inline
+: SB_GETTEXTA ( -- n ) WM_USER 2 + ; inline
+: SB_GETTEXTW ( -- n ) WM_USER 13 + ; inline
+: SB_GETTEXTLENGTHA ( -- n ) WM_USER 3 + ; inline
+: SB_GETTEXTLENGTHW ( -- n ) WM_USER 12 + ; inline
+: SB_SETPARTS ( -- n ) WM_USER 4 + ; inline
+: SB_GETPARTS ( -- n ) WM_USER 6 + ; inline
+: SB_GETBORDERS ( -- n ) WM_USER 7 + ; inline
+: SB_SETMINHEIGHT ( -- n ) WM_USER 8 + ; inline
+: SB_SIMPLE ( -- n ) WM_USER 9 + ; inline
+: SB_GETRECT ( -- n ) WM_USER 10 + ; inline
+: SB_ISSIMPLE ( -- n ) WM_USER 14 + ; inline
+: SB_SETICON ( -- n ) WM_USER 15 + ; inline
+: SB_SETTIPTEXTA ( -- n ) WM_USER 16 + ; inline
+: SB_SETTIPTEXTW ( -- n ) WM_USER 17 + ; inline
+: SB_GETTIPTEXTA ( -- n ) WM_USER 18 + ; inline
+: SB_GETTIPTEXTW ( -- n ) WM_USER 19 + ; inline
+: SB_GETICON ( -- n ) WM_USER 20 + ; inline
+CONSTANT: SB_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+CONSTANT: SB_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+ALIAS: SB_SETBKCOLOR CCM_SETBKCOLOR
+CONSTANT: SB_SIMPLEID HEX: 00ff
+ALIAS: TBM_GETPOS WM_USER
+: TBM_GETRANGEMIN ( -- n ) WM_USER 1 + ; inline
+: TBM_GETRANGEMAX ( -- n ) WM_USER 2 + ; inline
+: TBM_GETTIC ( -- n ) WM_USER 3 + ; inline
+: TBM_SETTIC ( -- n ) WM_USER 4 + ; inline
+: TBM_SETPOS ( -- n ) WM_USER 5 + ; inline
+: TBM_SETRANGE ( -- n ) WM_USER 6 + ; inline
+: TBM_SETRANGEMIN ( -- n ) WM_USER 7 + ; inline
+: TBM_SETRANGEMAX ( -- n ) WM_USER 8 + ; inline
+: TBM_CLEARTICS ( -- n ) WM_USER 9 + ; inline
+: TBM_SETSEL ( -- n ) WM_USER 10 + ; inline
+: TBM_SETSELSTART ( -- n ) WM_USER 11 + ; inline
+: TBM_SETSELEND ( -- n ) WM_USER 12 + ; inline
+: TBM_GETPTICS ( -- n ) WM_USER 14 + ; inline
+: TBM_GETTICPOS ( -- n ) WM_USER 15 + ; inline
+: TBM_GETNUMTICS ( -- n ) WM_USER 16 + ; inline
+: TBM_GETSELSTART ( -- n ) WM_USER 17 + ; inline
+: TBM_GETSELEND ( -- n ) WM_USER 18 + ; inline
+: TBM_CLEARSEL ( -- n ) WM_USER 19 + ; inline
+: TBM_SETTICFREQ ( -- n ) WM_USER 20 + ; inline
+: TBM_SETPAGESIZE ( -- n ) WM_USER 21 + ; inline
+: TBM_GETPAGESIZE ( -- n ) WM_USER 22 + ; inline
+: TBM_SETLINESIZE ( -- n ) WM_USER 23 + ; inline
+: TBM_GETLINESIZE ( -- n ) WM_USER 24 + ; inline
+: TBM_GETTHUMBRECT ( -- n ) WM_USER 25 + ; inline
+: TBM_GETCHANNELRECT ( -- n ) WM_USER 26 + ; inline
+: TBM_SETTHUMBLENGTH ( -- n ) WM_USER 27 + ; inline
+: TBM_GETTHUMBLENGTH ( -- n ) WM_USER 28 + ; inline
+: TBM_SETTOOLTIPS ( -- n ) WM_USER 29 + ; inline
+: TBM_GETTOOLTIPS ( -- n ) WM_USER 30 + ; inline
+: TBM_SETTIPSIDE ( -- n ) WM_USER 31 + ; inline
+: TBM_SETBUDDY ( -- n ) WM_USER 32 + ; inline
+: TBM_GETBUDDY ( -- n ) WM_USER 33 + ; inline
+ALIAS: TBM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+ALIAS: TBM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+: DL_BEGINDRAG ( -- n ) WM_USER 133 + ; inline
+: DL_DRAGGING ( -- n ) WM_USER 134 + ; inline
+: DL_DROPPED ( -- n ) WM_USER 135 + ; inline
+: DL_CANCELDRAG ( -- n ) WM_USER 136 + ; inline
+: UDM_SETRANGE ( -- n ) WM_USER 101 + ; inline
+: UDM_GETRANGE ( -- n ) WM_USER 102 + ; inline
+: UDM_SETPOS ( -- n ) WM_USER 103 + ; inline
+: UDM_GETPOS ( -- n ) WM_USER 104 + ; inline
+: UDM_SETBUDDY ( -- n ) WM_USER 105 + ; inline
+: UDM_GETBUDDY ( -- n ) WM_USER 106 + ; inline
+: UDM_SETACCEL ( -- n ) WM_USER 107 + ; inline
+: UDM_GETACCEL ( -- n ) WM_USER 108 + ; inline
+: UDM_SETBASE ( -- n ) WM_USER 109 + ; inline
+: UDM_GETBASE ( -- n ) WM_USER 110 + ; inline
+: UDM_SETRANGE32 ( -- n ) WM_USER 111 + ; inline
+: UDM_GETRANGE32 ( -- n ) WM_USER 112 + ; inline
+ALIAS: UDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+ALIAS: UDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+: UDM_SETPOS32 ( -- n ) WM_USER 113 + ; inline
+: UDM_GETPOS32 ( -- n ) WM_USER 114 + ; inline
+: PBM_SETRANGE ( -- n ) WM_USER 1 + ; inline
+: PBM_SETPOS ( -- n ) WM_USER 2 + ; inline
+: PBM_DELTAPOS ( -- n ) WM_USER 3 + ; inline
+: PBM_SETSTEP ( -- n ) WM_USER 4 + ; inline
+: PBM_STEPIT ( -- n ) WM_USER 5 + ; inline
+: PBM_SETRANGE32 ( -- n ) WM_USER 6 + ; inline
+: PBM_GETRANGE ( -- n ) WM_USER 7 + ; inline
+: PBM_GETPOS ( -- n ) WM_USER 8 + ; inline
+: PBM_SETBARCOLOR ( -- n ) WM_USER 9 + ; inline
+ALIAS: PBM_SETBKCOLOR CCM_SETBKCOLOR
+: HKM_SETHOTKEY ( -- n ) WM_USER 1 + ; inline
+: HKM_GETHOTKEY ( -- n ) WM_USER 2 + ; inline
+: HKM_SETRULES ( -- n ) WM_USER 3 + ; inline
+ALIAS: LVM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+ALIAS: LVM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+: LVM_GETBKCOLOR ( -- n ) LVM_FIRST 0 + ; inline
+: LVM_SETBKCOLOR ( -- n ) LVM_FIRST 1 + ; inline
+: LVM_GETIMAGELIST ( -- n ) LVM_FIRST 2 + ; inline
+: LVM_SETIMAGELIST ( -- n ) LVM_FIRST 3 + ; inline
+: LVM_GETITEMCOUNT ( -- n ) LVM_FIRST 4 + ; inline
+: LVM_GETITEMA ( -- n ) LVM_FIRST 5 + ; inline
+: LVM_GETITEMW ( -- n ) LVM_FIRST 75 + ; inline
+: LVM_SETITEMA ( -- n ) LVM_FIRST 6 + ; inline
+: LVM_SETITEMW ( -- n ) LVM_FIRST 76 + ; inline
+: LVM_INSERTITEMA ( -- n ) LVM_FIRST 7 + ; inline
+: LVM_INSERTITEMW ( -- n ) LVM_FIRST 77 + ; inline
+: LVM_DELETEITEM ( -- n ) LVM_FIRST 8 + ; inline
+: LVM_DELETEALLITEMS ( -- n ) LVM_FIRST 9 + ; inline
+: LVM_GETCALLBACKMASK ( -- n ) LVM_FIRST 10 + ; inline
+: LVM_SETCALLBACKMASK ( -- n ) LVM_FIRST 11 + ; inline
+: LVM_FINDITEMA ( -- n ) LVM_FIRST 13 + ; inline
+: LVM_FINDITEMW ( -- n ) LVM_FIRST 83 + ; inline
+: LVM_GETITEMRECT ( -- n ) LVM_FIRST 14 + ; inline
+: LVM_SETITEMPOSITION ( -- n ) LVM_FIRST 15 + ; inline
+: LVM_GETITEMPOSITION ( -- n ) LVM_FIRST 16 + ; inline
+: LVM_GETSTRINGWIDTHA ( -- n ) LVM_FIRST 17 + ; inline
+: LVM_GETSTRINGWIDTHW ( -- n ) LVM_FIRST 87 + ; inline
+: LVM_HITTEST ( -- n ) LVM_FIRST 18 + ; inline
+: LVM_ENSUREVISIBLE ( -- n ) LVM_FIRST 19 + ; inline
+: LVM_SCROLL ( -- n ) LVM_FIRST 20 + ; inline
+: LVM_REDRAWITEMS ( -- n ) LVM_FIRST 21 + ; inline
+: LVM_ARRANGE ( -- n ) LVM_FIRST 22 + ; inline
+: LVM_EDITLABELA ( -- n ) LVM_FIRST 23 + ; inline
+: LVM_EDITLABELW ( -- n ) LVM_FIRST 118 + ; inline
+: LVM_GETEDITCONTROL ( -- n ) LVM_FIRST 24 + ; inline
+: LVM_GETCOLUMNA ( -- n ) LVM_FIRST 25 + ; inline
+: LVM_GETCOLUMNW ( -- n ) LVM_FIRST 95 + ; inline
+: LVM_SETCOLUMNA ( -- n ) LVM_FIRST 26 + ; inline
+: LVM_SETCOLUMNW ( -- n ) LVM_FIRST 96 + ; inline
+: LVM_INSERTCOLUMNA ( -- n ) LVM_FIRST 27 + ; inline
+: LVM_INSERTCOLUMNW ( -- n ) LVM_FIRST 97 + ; inline
+: LVM_DELETECOLUMN ( -- n ) LVM_FIRST 28 + ; inline
+: LVM_GETCOLUMNWIDTH ( -- n ) LVM_FIRST 29 + ; inline
+: LVM_SETCOLUMNWIDTH ( -- n ) LVM_FIRST 30 + ; inline
+: LVM_CREATEDRAGIMAGE ( -- n ) LVM_FIRST 33 + ; inline
+: LVM_GETVIEWRECT ( -- n ) LVM_FIRST 34 + ; inline
+: LVM_GETTEXTCOLOR ( -- n ) LVM_FIRST 35 + ; inline
+: LVM_SETTEXTCOLOR ( -- n ) LVM_FIRST 36 + ; inline
+: LVM_GETTEXTBKCOLOR ( -- n ) LVM_FIRST 37 + ; inline
+: LVM_SETTEXTBKCOLOR ( -- n ) LVM_FIRST 38 + ; inline
+: LVM_GETTOPINDEX ( -- n ) LVM_FIRST 39 + ; inline
+: LVM_GETCOUNTPERPAGE ( -- n ) LVM_FIRST 40 + ; inline
+: LVM_GETORIGIN ( -- n ) LVM_FIRST 41 + ; inline
+: LVM_UPDATE ( -- n ) LVM_FIRST 42 + ; inline
+: LVM_SETITEMSTATE ( -- n ) LVM_FIRST 43 + ; inline
+: LVM_GETITEMSTATE ( -- n ) LVM_FIRST 44 + ; inline
+: LVM_GETITEMTEXTA ( -- n ) LVM_FIRST 45 + ; inline
+: LVM_GETITEMTEXTW ( -- n ) LVM_FIRST 115 + ; inline
+: LVM_SETITEMTEXTA ( -- n ) LVM_FIRST 46 + ; inline
+: LVM_SETITEMTEXTW ( -- n ) LVM_FIRST 116 + ; inline
+: LVM_SETITEMCOUNT ( -- n ) LVM_FIRST 47 + ; inline
+: LVM_SORTITEMS ( -- n ) LVM_FIRST 48 + ; inline
+: LVM_SETITEMPOSITION32 ( -- n ) LVM_FIRST 49 + ; inline
+: LVM_GETSELECTEDCOUNT ( -- n ) LVM_FIRST 50 + ; inline
+: LVM_GETITEMSPACING ( -- n ) LVM_FIRST 51 + ; inline
+: LVM_GETISEARCHSTRINGA ( -- n ) LVM_FIRST 52 + ; inline
+: LVM_GETISEARCHSTRINGW ( -- n ) LVM_FIRST 117 + ; inline
+: LVM_SETICONSPACING ( -- n ) LVM_FIRST 53 + ; inline
+: LVM_SETEXTENDEDLISTVIEWSTYLE ( -- n ) LVM_FIRST 54 + ; inline
+: LVM_GETEXTENDEDLISTVIEWSTYLE ( -- n ) LVM_FIRST 55 + ; inline
+: LVM_GETSUBITEMRECT ( -- n ) LVM_FIRST 56 + ; inline
+: LVM_SUBITEMHITTEST ( -- n ) LVM_FIRST 57 + ; inline
+: LVM_SETCOLUMNORDERARRAY ( -- n ) LVM_FIRST 58 + ; inline
+: LVM_GETCOLUMNORDERARRAY ( -- n ) LVM_FIRST 59 + ; inline
+: LVM_SETHOTITEM ( -- n ) LVM_FIRST 60 + ; inline
+: LVM_GETHOTITEM ( -- n ) LVM_FIRST 61 + ; inline
+: LVM_SETHOTCURSOR ( -- n ) LVM_FIRST 62 + ; inline
+: LVM_GETHOTCURSOR ( -- n ) LVM_FIRST 63 + ; inline
+: LVM_APPROXIMATEVIEWRECT ( -- n ) LVM_FIRST 64 + ; inline
+: LVM_SETWORKAREAS ( -- n ) LVM_FIRST 65 + ; inline
+: LVM_GETWORKAREAS ( -- n ) LVM_FIRST 70 + ; inline
+: LVM_GETNUMBEROFWORKAREAS ( -- n ) LVM_FIRST 73 + ; inline
+: LVM_GETSELECTIONMARK ( -- n ) LVM_FIRST 66 + ; inline
+: LVM_SETSELECTIONMARK ( -- n ) LVM_FIRST 67 + ; inline
+: LVM_SETHOVERTIME ( -- n ) LVM_FIRST 71 + ; inline
+: LVM_GETHOVERTIME ( -- n ) LVM_FIRST 72 + ; inline
+: LVM_SETTOOLTIPS ( -- n ) LVM_FIRST 74 + ; inline
+: LVM_GETTOOLTIPS ( -- n ) LVM_FIRST 78 + ; inline
+: LVM_SORTITEMSEX ( -- n ) LVM_FIRST 81 + ; inline
+: LVM_SETBKIMAGEA ( -- n ) LVM_FIRST 68 + ; inline
+: LVM_SETBKIMAGEW ( -- n ) LVM_FIRST 138 + ; inline
+: LVM_GETBKIMAGEA ( -- n ) LVM_FIRST 69 + ; inline
+: LVM_GETBKIMAGEW ( -- n ) LVM_FIRST 139 + ; inline
+: LVM_SETSELECTEDCOLUMN ( -- n ) LVM_FIRST 140 + ; inline
+: LVM_SETTILEWIDTH ( -- n ) LVM_FIRST 141 + ; inline
+: LVM_SETVIEW ( -- n ) LVM_FIRST 142 + ; inline
+: LVM_GETVIEW ( -- n ) LVM_FIRST 143 + ; inline
+: LVM_INSERTGROUP ( -- n ) LVM_FIRST 145 + ; inline
+: LVM_SETGROUPINFO ( -- n ) LVM_FIRST 147 + ; inline
+: LVM_GETGROUPINFO ( -- n ) LVM_FIRST 149 + ; inline
+: LVM_REMOVEGROUP ( -- n ) LVM_FIRST 150 + ; inline
+: LVM_MOVEGROUP ( -- n ) LVM_FIRST 151 + ; inline
+: LVM_MOVEITEMTOGROUP ( -- n ) LVM_FIRST 154 + ; inline
+: LVM_SETGROUPMETRICS ( -- n ) LVM_FIRST 155 + ; inline
+: LVM_GETGROUPMETRICS ( -- n ) LVM_FIRST 156 + ; inline
+: LVM_ENABLEGROUPVIEW ( -- n ) LVM_FIRST 157 + ; inline
+: LVM_SORTGROUPS ( -- n ) LVM_FIRST 158 + ; inline
+: LVM_INSERTGROUPSORTED ( -- n ) LVM_FIRST 159 + ; inline
+: LVM_REMOVEALLGROUPS ( -- n ) LVM_FIRST 160 + ; inline
+: LVM_HASGROUP ( -- n ) LVM_FIRST 161 + ; inline
+: LVM_SETTILEVIEWINFO ( -- n ) LVM_FIRST 162 + ; inline
+: LVM_GETTILEVIEWINFO ( -- n ) LVM_FIRST 163 + ; inline
+: LVM_SETTILEINFO ( -- n ) LVM_FIRST 164 + ; inline
+: LVM_GETTILEINFO ( -- n ) LVM_FIRST 165 + ; inline
+: LVM_SETINSERTMARK ( -- n ) LVM_FIRST 166 + ; inline
+: LVM_GETINSERTMARK ( -- n ) LVM_FIRST 167 + ; inline
+: LVM_INSERTMARKHITTEST ( -- n ) LVM_FIRST 168 + ; inline
+: LVM_GETINSERTMARKRECT ( -- n ) LVM_FIRST 169 + ; inline
+: LVM_SETINSERTMARKCOLOR ( -- n ) LVM_FIRST 170 + ; inline
+: LVM_GETINSERTMARKCOLOR ( -- n ) LVM_FIRST 171 + ; inline
+: LVM_SETINFOTIP ( -- n ) LVM_FIRST 173 + ; inline
+: LVM_GETSELECTEDCOLUMN ( -- n ) LVM_FIRST 174 + ; inline
+: LVM_ISGROUPVIEWENABLED ( -- n ) LVM_FIRST 175 + ; inline
+: LVM_GETOUTLINECOLOR ( -- n ) LVM_FIRST 176 + ; inline
+: LVM_SETOUTLINECOLOR ( -- n ) LVM_FIRST 177 + ; inline
+: LVM_CANCELEDITLABEL ( -- n ) LVM_FIRST 179 + ; inline
+: LVM_MAPINDEXTOID ( -- n ) LVM_FIRST 180 + ; inline
+: LVM_MAPIDTOINDEX ( -- n ) LVM_FIRST 181 + ; inline
+: TVM_INSERTITEMA ( -- n ) TV_FIRST 0 + ; inline
+: TVM_INSERTITEMW ( -- n ) TV_FIRST 50 + ; inline
+: TVM_DELETEITEM ( -- n ) TV_FIRST 1 + ; inline
+: TVM_EXPAND ( -- n ) TV_FIRST 2 + ; inline
+: TVM_GETITEMRECT ( -- n ) TV_FIRST 4 + ; inline
+: TVM_GETCOUNT ( -- n ) TV_FIRST 5 + ; inline
+: TVM_GETINDENT ( -- n ) TV_FIRST 6 + ; inline
+: TVM_SETINDENT ( -- n ) TV_FIRST 7 + ; inline
+: TVM_GETIMAGELIST ( -- n ) TV_FIRST 8 + ; inline
+: TVM_SETIMAGELIST ( -- n ) TV_FIRST 9 + ; inline
+: TVM_GETNEXTITEM ( -- n ) TV_FIRST 10 + ; inline
+: TVM_SELECTITEM ( -- n ) TV_FIRST 11 + ; inline
+: TVM_GETITEMA ( -- n ) TV_FIRST 12 + ; inline
+: TVM_GETITEMW ( -- n ) TV_FIRST 62 + ; inline
+: TVM_SETITEMA ( -- n ) TV_FIRST 13 + ; inline
+: TVM_SETITEMW ( -- n ) TV_FIRST 63 + ; inline
+: TVM_EDITLABELA ( -- n ) TV_FIRST 14 + ; inline
+: TVM_EDITLABELW ( -- n ) TV_FIRST 65 + ; inline
+: TVM_GETEDITCONTROL ( -- n ) TV_FIRST 15 + ; inline
+: TVM_GETVISIBLECOUNT ( -- n ) TV_FIRST 16 + ; inline
+: TVM_HITTEST ( -- n ) TV_FIRST 17 + ; inline
+: TVM_CREATEDRAGIMAGE ( -- n ) TV_FIRST 18 + ; inline
+: TVM_SORTCHILDREN ( -- n ) TV_FIRST 19 + ; inline
+: TVM_ENSUREVISIBLE ( -- n ) TV_FIRST 20 + ; inline
+: TVM_SORTCHILDRENCB ( -- n ) TV_FIRST 21 + ; inline
+: TVM_ENDEDITLABELNOW ( -- n ) TV_FIRST 22 + ; inline
+: TVM_GETISEARCHSTRINGA ( -- n ) TV_FIRST 23 + ; inline
+: TVM_GETISEARCHSTRINGW ( -- n ) TV_FIRST 64 + ; inline
+: TVM_SETTOOLTIPS ( -- n ) TV_FIRST 24 + ; inline
+: TVM_GETTOOLTIPS ( -- n ) TV_FIRST 25 + ; inline
+: TVM_SETINSERTMARK ( -- n ) TV_FIRST 26 + ; inline
+ALIAS: TVM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+ALIAS: TVM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+: TVM_SETITEMHEIGHT ( -- n ) TV_FIRST 27 + ; inline
+: TVM_GETITEMHEIGHT ( -- n ) TV_FIRST 28 + ; inline
+: TVM_SETBKCOLOR ( -- n ) TV_FIRST 29 + ; inline
+: TVM_SETTEXTCOLOR ( -- n ) TV_FIRST 30 + ; inline
+: TVM_GETBKCOLOR ( -- n ) TV_FIRST 31 + ; inline
+: TVM_GETTEXTCOLOR ( -- n ) TV_FIRST 32 + ; inline
+: TVM_SETSCROLLTIME ( -- n ) TV_FIRST 33 + ; inline
+: TVM_GETSCROLLTIME ( -- n ) TV_FIRST 34 + ; inline
+: TVM_SETINSERTMARKCOLOR ( -- n ) TV_FIRST 37 + ; inline
+: TVM_GETINSERTMARKCOLOR ( -- n ) TV_FIRST 38 + ; inline
+: TVM_GETITEMSTATE ( -- n ) TV_FIRST 39 + ; inline
+: TVM_SETLINECOLOR ( -- n ) TV_FIRST 40 + ; inline
+: TVM_GETLINECOLOR ( -- n ) TV_FIRST 41 + ; inline
+: TVM_MAPACCIDTOHTREEITEM ( -- n ) TV_FIRST 42 + ; inline
+: TVM_MAPHTREEITEMTOACCID ( -- n ) TV_FIRST 43 + ; inline
+: CBEM_INSERTITEMA ( -- n ) WM_USER 1 + ; inline
+: CBEM_SETIMAGELIST ( -- n ) WM_USER 2 + ; inline
+: CBEM_GETIMAGELIST ( -- n ) WM_USER 3 + ; inline
+: CBEM_GETITEMA ( -- n ) WM_USER 4 + ; inline
+: CBEM_SETITEMA ( -- n ) WM_USER 5 + ; inline
+ALIAS: CBEM_DELETEITEM CB_DELETESTRING
+: CBEM_GETCOMBOCONTROL ( -- n ) WM_USER 6 + ; inline
+: CBEM_GETEDITCONTROL ( -- n ) WM_USER 7 + ; inline
+: CBEM_SETEXTENDEDSTYLE ( -- n ) WM_USER 14 + ; inline
+: CBEM_GETEXTENDEDSTYLE ( -- n ) WM_USER 9 + ; inline
+ALIAS: CBEM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+ALIAS: CBEM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+: CBEM_SETEXSTYLE ( -- n ) WM_USER 8 + ; inline
+: CBEM_GETEXSTYLE ( -- n ) WM_USER 9 + ; inline
+: CBEM_HASEDITCHANGED ( -- n ) WM_USER 10 + ; inline
+: CBEM_INSERTITEMW ( -- n ) WM_USER 11 + ; inline
+: CBEM_SETITEMW ( -- n ) WM_USER 12 + ; inline
+: CBEM_GETITEMW ( -- n ) WM_USER 13 + ; inline
+: TCM_GETIMAGELIST ( -- n ) TCM_FIRST 2 + ; inline
+: TCM_SETIMAGELIST ( -- n ) TCM_FIRST 3 + ; inline
+: TCM_GETITEMCOUNT ( -- n ) TCM_FIRST 4 + ; inline
+: TCM_GETITEMA ( -- n ) TCM_FIRST 5 + ; inline
+: TCM_GETITEMW ( -- n ) TCM_FIRST 60 + ; inline
+: TCM_SETITEMA ( -- n ) TCM_FIRST 6 + ; inline
+: TCM_SETITEMW ( -- n ) TCM_FIRST 61 + ; inline
+: TCM_INSERTITEMA ( -- n ) TCM_FIRST 7 + ; inline
+: TCM_INSERTITEMW ( -- n ) TCM_FIRST 62 + ; inline
+: TCM_DELETEITEM ( -- n ) TCM_FIRST 8 + ; inline
+: TCM_DELETEALLITEMS ( -- n ) TCM_FIRST 9 + ; inline
+: TCM_GETITEMRECT ( -- n ) TCM_FIRST 10 + ; inline
+: TCM_GETCURSEL ( -- n ) TCM_FIRST 11 + ; inline
+: TCM_SETCURSEL ( -- n ) TCM_FIRST 12 + ; inline
+: TCM_HITTEST ( -- n ) TCM_FIRST 13 + ; inline
+: TCM_SETITEMEXTRA ( -- n ) TCM_FIRST 14 + ; inline
+: TCM_ADJUSTRECT ( -- n ) TCM_FIRST 40 + ; inline
+: TCM_SETITEMSIZE ( -- n ) TCM_FIRST 41 + ; inline
+: TCM_REMOVEIMAGE ( -- n ) TCM_FIRST 42 + ; inline
+: TCM_SETPADDING ( -- n ) TCM_FIRST 43 + ; inline
+: TCM_GETROWCOUNT ( -- n ) TCM_FIRST 44 + ; inline
+: TCM_GETTOOLTIPS ( -- n ) TCM_FIRST 45 + ; inline
+: TCM_SETTOOLTIPS ( -- n ) TCM_FIRST 46 + ; inline
+: TCM_GETCURFOCUS ( -- n ) TCM_FIRST 47 + ; inline
+: TCM_SETCURFOCUS ( -- n ) TCM_FIRST 48 + ; inline
+: TCM_SETMINTABWIDTH ( -- n ) TCM_FIRST 49 + ; inline
+: TCM_DESELECTALL ( -- n ) TCM_FIRST 50 + ; inline
+: TCM_HIGHLIGHTITEM ( -- n ) TCM_FIRST 51 + ; inline
+: TCM_SETEXTENDEDSTYLE ( -- n ) TCM_FIRST 52 + ; inline
+: TCM_GETEXTENDEDSTYLE ( -- n ) TCM_FIRST 53 + ; inline
+ALIAS: TCM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+ALIAS: TCM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+: ACM_OPENA ( -- n ) WM_USER 100 + ; inline
+: ACM_OPENW ( -- n ) WM_USER 103 + ; inline
+: ACM_PLAY ( -- n ) WM_USER 101 + ; inline
+: ACM_STOP ( -- n ) WM_USER 102 + ; inline
+CONSTANT: MCM_FIRST HEX: 1000
+: MCM_GETCURSEL ( -- n ) MCM_FIRST 1 + ; inline
+: MCM_SETCURSEL ( -- n ) MCM_FIRST 2 + ; inline
+: MCM_GETMAXSELCOUNT ( -- n ) MCM_FIRST 3 + ; inline
+: MCM_SETMAXSELCOUNT ( -- n ) MCM_FIRST 4 + ; inline
+: MCM_GETSELRANGE ( -- n ) MCM_FIRST 5 + ; inline
+: MCM_SETSELRANGE ( -- n ) MCM_FIRST 6 + ; inline
+: MCM_GETMONTHRANGE ( -- n ) MCM_FIRST 7 + ; inline
+: MCM_SETDAYSTATE ( -- n ) MCM_FIRST 8 + ; inline
+: MCM_GETMINREQRECT ( -- n ) MCM_FIRST 9 + ; inline
+: MCM_SETCOLOR ( -- n ) MCM_FIRST 10 + ; inline
+: MCM_GETCOLOR ( -- n ) MCM_FIRST 11 + ; inline
+: MCM_SETTODAY ( -- n ) MCM_FIRST 12 + ; inline
+: MCM_GETTODAY ( -- n ) MCM_FIRST 13 + ; inline
+: MCM_HITTEST ( -- n ) MCM_FIRST 14 + ; inline
+: MCM_SETFIRSTDAYOFWEEK ( -- n ) MCM_FIRST 15 + ; inline
+: MCM_GETFIRSTDAYOFWEEK ( -- n ) MCM_FIRST 16 + ; inline
+: MCM_GETRANGE ( -- n ) MCM_FIRST 17 + ; inline
+: MCM_SETRANGE ( -- n ) MCM_FIRST 18 + ; inline
+: MCM_GETMONTHDELTA ( -- n ) MCM_FIRST 19 + ; inline
+: MCM_SETMONTHDELTA ( -- n ) MCM_FIRST 20 + ; inline
+: MCM_GETMAXTODAYWIDTH ( -- n ) MCM_FIRST 21 + ; inline
+ALIAS: MCM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
+ALIAS: MCM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+CONSTANT: DTM_FIRST HEX: 1000
+: DTM_GETSYSTEMTIME ( -- n ) DTM_FIRST 1 + ; inline
+: DTM_SETSYSTEMTIME ( -- n ) DTM_FIRST 2 + ; inline
+: DTM_GETRANGE ( -- n ) DTM_FIRST 3 + ; inline
+: DTM_SETRANGE ( -- n ) DTM_FIRST 4 + ; inline
+: DTM_SETFORMATA ( -- n ) DTM_FIRST 5 + ; inline
+: DTM_SETFORMATW ( -- n ) DTM_FIRST 50 + ; inline
+: DTM_SETMCCOLOR ( -- n ) DTM_FIRST 6 + ; inline
+: DTM_GETMCCOLOR ( -- n ) DTM_FIRST 7 + ; inline
+: DTM_GETMONTHCAL ( -- n ) DTM_FIRST 8 + ; inline
+: DTM_SETMCFONT ( -- n ) DTM_FIRST 9 + ; inline
+: DTM_GETMCFONT ( -- n ) DTM_FIRST 10 + ; inline
+: PGM_SETCHILD ( -- n ) PGM_FIRST 1 + ; inline
+: PGM_RECALCSIZE ( -- n ) PGM_FIRST 2 + ; inline
+: PGM_FORWARDMOUSE ( -- n ) PGM_FIRST 3 + ; inline
+: PGM_SETBKCOLOR ( -- n ) PGM_FIRST 4 + ; inline
+: PGM_GETBKCOLOR ( -- n ) PGM_FIRST 5 + ; inline
+: PGM_SETBORDER ( -- n ) PGM_FIRST 6 + ; inline
+: PGM_GETBORDER ( -- n ) PGM_FIRST 7 + ; inline
+: PGM_SETPOS ( -- n ) PGM_FIRST 8 + ; inline
+: PGM_GETPOS ( -- n ) PGM_FIRST 9 + ; inline
+: PGM_SETBUTTONSIZE ( -- n ) PGM_FIRST 10 + ; inline
+: PGM_GETBUTTONSIZE ( -- n ) PGM_FIRST 11 + ; inline
+: PGM_GETBUTTONSTATE ( -- n ) PGM_FIRST 12 + ; inline
+CONSTANT: PGM_GETDROPTARGET CCM_GETDROPTARGET
+: BCM_GETIDEALSIZE ( -- n ) BCM_FIRST 1 + ; inline
+: BCM_SETIMAGELIST ( -- n ) BCM_FIRST 2 + ; inline
+: BCM_GETIMAGELIST ( -- n ) BCM_FIRST 3 + ; inline
+: BCM_SETTEXTMARGIN ( -- n ) BCM_FIRST 4 + ; inline
+: BCM_GETTEXTMARGIN ( -- n ) BCM_FIRST 5 + ; inline
+: EM_SETCUEBANNER ( -- n ) ECM_FIRST 1 + ; inline
+: EM_GETCUEBANNER ( -- n ) ECM_FIRST 2 + ; inline
+: EM_SHOWBALLOONTIP ( -- n ) ECM_FIRST 3 + ; inline
+: EM_HIDEBALLOONTIP ( -- n ) ECM_FIRST 4 + ; inline
+: CB_SETMINVISIBLE ( -- n ) CBM_FIRST 1 + ; inline
+: CB_GETMINVISIBLE ( -- n ) CBM_FIRST 2 + ; inline
+: LM_HITTEST ( -- n ) WM_USER HEX: 0300 + ; inline
+: LM_GETIDEALHEIGHT ( -- n ) WM_USER HEX: 0301 + ; inline
+: LM_SETITEM ( -- n ) WM_USER HEX: 0302 + ; inline
+: LM_GETITEM ( -- n ) WM_USER HEX: 0303 + ; inline
-: WA_INACTIVE 0 ; inline
-: WA_ACTIVE 1 ; inline
-: WA_CLICKACTIVE 2 ; inline
-: SC_SIZE HEX: f000 ; inline
-: SC_MOVE HEX: f010 ; inline
-: SC_MINIMIZE HEX: f020 ; inline
-: SC_MAXIMIZE HEX: f030 ; inline
-: SC_NEXTWINDOW HEX: f040 ; inline
-: SC_PREVWINDOW HEX: f050 ; inline
-: SC_CLOSE HEX: f060 ; inline
-: SC_VSCROLL HEX: f070 ; inline
-: SC_HSCROLL HEX: f080 ; inline
-: SC_MOUSEMENU HEX: f090 ; inline
-: SC_KEYMENU HEX: f100 ; inline
-: SC_ARRANGE HEX: f110 ; inline
-: SC_RESTORE HEX: f120 ; inline
-: SC_TASKLIST HEX: f130 ; inline
-: SC_SCREENSAVE HEX: f140 ; inline
-: SC_HOTKEY HEX: f150 ; inline
+CONSTANT: WA_INACTIVE 0
+CONSTANT: WA_ACTIVE 1
+CONSTANT: WA_CLICKACTIVE 2
+
+CONSTANT: SC_SIZE HEX: f000
+CONSTANT: SC_MOVE HEX: f010
+CONSTANT: SC_MINIMIZE HEX: f020
+CONSTANT: SC_MAXIMIZE HEX: f030
+CONSTANT: SC_NEXTWINDOW HEX: f040
+CONSTANT: SC_PREVWINDOW HEX: f050
+CONSTANT: SC_CLOSE HEX: f060
+CONSTANT: SC_VSCROLL HEX: f070
+CONSTANT: SC_HSCROLL HEX: f080
+CONSTANT: SC_MOUSEMENU HEX: f090
+CONSTANT: SC_KEYMENU HEX: f100
+CONSTANT: SC_ARRANGE HEX: f110
+CONSTANT: SC_RESTORE HEX: f120
+CONSTANT: SC_TASKLIST HEX: f130
+CONSTANT: SC_SCREENSAVE HEX: f140
+CONSTANT: SC_HOTKEY HEX: f150
: guid= ( a b -- ? )
[ 16 memory>byte-array ] bi@ = ;
-: GUID-STRING-LENGTH
+: GUID-STRING-LENGTH ( -- n )
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
:: (guid-section>guid) ( string guid start end quot -- )
-USING: alien alien.c-types alien.strings alien.syntax combinators
-kernel windows windows.user32 windows.ole32
-windows.com windows.com.syntax io.files io.encodings.utf16n ;
+! Copyright (C) 2006, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings alien.syntax
+combinators io.encodings.utf16n io.files io.pathnames kernel
+windows windows.com windows.com.syntax windows.ole32
+windows.user32 ;
IN: windows.shell32
-: CSIDL_DESKTOP HEX: 00 ; inline
-: CSIDL_INTERNET HEX: 01 ; inline
-: CSIDL_PROGRAMS HEX: 02 ; inline
-: CSIDL_CONTROLS HEX: 03 ; inline
-: CSIDL_PRINTERS HEX: 04 ; inline
-: CSIDL_PERSONAL HEX: 05 ; inline
-: CSIDL_FAVORITES HEX: 06 ; inline
-: CSIDL_STARTUP HEX: 07 ; inline
-: CSIDL_RECENT HEX: 08 ; inline
-: CSIDL_SENDTO HEX: 09 ; inline
-: CSIDL_BITBUCKET HEX: 0a ; inline
-: CSIDL_STARTMENU HEX: 0b ; inline
-: CSIDL_MYDOCUMENTS HEX: 0c ; inline
-: CSIDL_MYMUSIC HEX: 0d ; inline
-: CSIDL_MYVIDEO HEX: 0e ; inline
-: CSIDL_DESKTOPDIRECTORY HEX: 10 ; inline
-: CSIDL_DRIVES HEX: 11 ; inline
-: CSIDL_NETWORK HEX: 12 ; inline
-: CSIDL_NETHOOD HEX: 13 ; inline
-: CSIDL_FONTS HEX: 14 ; inline
-: CSIDL_TEMPLATES HEX: 15 ; inline
-: CSIDL_COMMON_STARTMENU HEX: 16 ; inline
-: CSIDL_COMMON_PROGRAMS HEX: 17 ; inline
-: CSIDL_COMMON_STARTUP HEX: 18 ; inline
-: CSIDL_COMMON_DESKTOPDIRECTORY HEX: 19 ; inline
-: CSIDL_APPDATA HEX: 1a ; inline
-: CSIDL_PRINTHOOD HEX: 1b ; inline
-: CSIDL_LOCAL_APPDATA HEX: 1c ; inline
-: CSIDL_ALTSTARTUP HEX: 1d ; inline
-: CSIDL_COMMON_ALTSTARTUP HEX: 1e ; inline
-: CSIDL_COMMON_FAVORITES HEX: 1f ; inline
-: CSIDL_INTERNET_CACHE HEX: 20 ; inline
-: CSIDL_COOKIES HEX: 21 ; inline
-: CSIDL_HISTORY HEX: 22 ; inline
-: CSIDL_COMMON_APPDATA HEX: 23 ; inline
-: CSIDL_WINDOWS HEX: 24 ; inline
-: CSIDL_SYSTEM HEX: 25 ; inline
-: CSIDL_PROGRAM_FILES HEX: 26 ; inline
-: CSIDL_MYPICTURES HEX: 27 ; inline
-: CSIDL_PROFILE HEX: 28 ; inline
-: CSIDL_SYSTEMX86 HEX: 29 ; inline
-: CSIDL_PROGRAM_FILESX86 HEX: 2a ; inline
-: CSIDL_PROGRAM_FILES_COMMON HEX: 2b ; inline
-: CSIDL_PROGRAM_FILES_COMMONX86 HEX: 2c ; inline
-: CSIDL_COMMON_TEMPLATES HEX: 2d ; inline
-: CSIDL_COMMON_DOCUMENTS HEX: 2e ; inline
-: CSIDL_COMMON_ADMINTOOLS HEX: 2f ; inline
-: CSIDL_ADMINTOOLS HEX: 30 ; inline
-: CSIDL_CONNECTIONS HEX: 31 ; inline
-: CSIDL_COMMON_MUSIC HEX: 35 ; inline
-: CSIDL_COMMON_PICTURES HEX: 36 ; inline
-: CSIDL_COMMON_VIDEO HEX: 37 ; inline
-: CSIDL_RESOURCES HEX: 38 ; inline
-: CSIDL_RESOURCES_LOCALIZED HEX: 39 ; inline
-: CSIDL_COMMON_OEM_LINKS HEX: 3a ; inline
-: CSIDL_CDBURN_AREA HEX: 3b ; inline
-: CSIDL_COMPUTERSNEARME HEX: 3d ; inline
-: CSIDL_PROFILES HEX: 3e ; inline
-: CSIDL_FOLDER_MASK HEX: ff ; inline
-: CSIDL_FLAG_PER_USER_INIT HEX: 800 ; inline
-: CSIDL_FLAG_NO_ALIAS HEX: 1000 ; inline
-: CSIDL_FLAG_DONT_VERIFY HEX: 4000 ; inline
-: CSIDL_FLAG_CREATE HEX: 8000 ; inline
-: CSIDL_FLAG_MASK HEX: ff00 ; inline
-
-
-: ERROR_FILE_NOT_FOUND 2 ; inline
-
-: SHGFP_TYPE_CURRENT 0 ; inline
-: SHGFP_TYPE_DEFAULT 1 ; inline
+CONSTANT: CSIDL_DESKTOP HEX: 00
+CONSTANT: CSIDL_INTERNET HEX: 01
+CONSTANT: CSIDL_PROGRAMS HEX: 02
+CONSTANT: CSIDL_CONTROLS HEX: 03
+CONSTANT: CSIDL_PRINTERS HEX: 04
+CONSTANT: CSIDL_PERSONAL HEX: 05
+CONSTANT: CSIDL_FAVORITES HEX: 06
+CONSTANT: CSIDL_STARTUP HEX: 07
+CONSTANT: CSIDL_RECENT HEX: 08
+CONSTANT: CSIDL_SENDTO HEX: 09
+CONSTANT: CSIDL_BITBUCKET HEX: 0a
+CONSTANT: CSIDL_STARTMENU HEX: 0b
+CONSTANT: CSIDL_MYDOCUMENTS HEX: 0c
+CONSTANT: CSIDL_MYMUSIC HEX: 0d
+CONSTANT: CSIDL_MYVIDEO HEX: 0e
+CONSTANT: CSIDL_DESKTOPDIRECTORY HEX: 10
+CONSTANT: CSIDL_DRIVES HEX: 11
+CONSTANT: CSIDL_NETWORK HEX: 12
+CONSTANT: CSIDL_NETHOOD HEX: 13
+CONSTANT: CSIDL_FONTS HEX: 14
+CONSTANT: CSIDL_TEMPLATES HEX: 15
+CONSTANT: CSIDL_COMMON_STARTMENU HEX: 16
+CONSTANT: CSIDL_COMMON_PROGRAMS HEX: 17
+CONSTANT: CSIDL_COMMON_STARTUP HEX: 18
+CONSTANT: CSIDL_COMMON_DESKTOPDIRECTORY HEX: 19
+CONSTANT: CSIDL_APPDATA HEX: 1a
+CONSTANT: CSIDL_PRINTHOOD HEX: 1b
+CONSTANT: CSIDL_LOCAL_APPDATA HEX: 1c
+CONSTANT: CSIDL_ALTSTARTUP HEX: 1d
+CONSTANT: CSIDL_COMMON_ALTSTARTUP HEX: 1e
+CONSTANT: CSIDL_COMMON_FAVORITES HEX: 1f
+CONSTANT: CSIDL_INTERNET_CACHE HEX: 20
+CONSTANT: CSIDL_COOKIES HEX: 21
+CONSTANT: CSIDL_HISTORY HEX: 22
+CONSTANT: CSIDL_COMMON_APPDATA HEX: 23
+CONSTANT: CSIDL_WINDOWS HEX: 24
+CONSTANT: CSIDL_SYSTEM HEX: 25
+CONSTANT: CSIDL_PROGRAM_FILES HEX: 26
+CONSTANT: CSIDL_MYPICTURES HEX: 27
+CONSTANT: CSIDL_PROFILE HEX: 28
+CONSTANT: CSIDL_SYSTEMX86 HEX: 29
+CONSTANT: CSIDL_PROGRAM_FILESX86 HEX: 2a
+CONSTANT: CSIDL_PROGRAM_FILES_COMMON HEX: 2b
+CONSTANT: CSIDL_PROGRAM_FILES_COMMONX86 HEX: 2c
+CONSTANT: CSIDL_COMMON_TEMPLATES HEX: 2d
+CONSTANT: CSIDL_COMMON_DOCUMENTS HEX: 2e
+CONSTANT: CSIDL_COMMON_ADMINTOOLS HEX: 2f
+CONSTANT: CSIDL_ADMINTOOLS HEX: 30
+CONSTANT: CSIDL_CONNECTIONS HEX: 31
+CONSTANT: CSIDL_COMMON_MUSIC HEX: 35
+CONSTANT: CSIDL_COMMON_PICTURES HEX: 36
+CONSTANT: CSIDL_COMMON_VIDEO HEX: 37
+CONSTANT: CSIDL_RESOURCES HEX: 38
+CONSTANT: CSIDL_RESOURCES_LOCALIZED HEX: 39
+CONSTANT: CSIDL_COMMON_OEM_LINKS HEX: 3a
+CONSTANT: CSIDL_CDBURN_AREA HEX: 3b
+CONSTANT: CSIDL_COMPUTERSNEARME HEX: 3d
+CONSTANT: CSIDL_PROFILES HEX: 3e
+CONSTANT: CSIDL_FOLDER_MASK HEX: ff
+CONSTANT: CSIDL_FLAG_PER_USER_INIT HEX: 800
+CONSTANT: CSIDL_FLAG_NO_ALIAS HEX: 1000
+CONSTANT: CSIDL_FLAG_DONT_VERIFY HEX: 4000
+CONSTANT: CSIDL_FLAG_CREATE HEX: 8000
+CONSTANT: CSIDL_FLAG_MASK HEX: ff00
+
+
+CONSTANT: ERROR_FILE_NOT_FOUND 2
+
+CONSTANT: SHGFP_TYPE_CURRENT 0
+CONSTANT: SHGFP_TYPE_DEFAULT 1
LIBRARY: shell32
FUNCTION: HRESULT SHGetFolderPathW ( HWND hwndOwner, int nFolder, HANDLE hToken, DWORD dwReserved, LPTSTR pszPath ) ;
-: SHGetFolderPath SHGetFolderPathW ; inline
+ALIAS: SHGetFolderPath SHGetFolderPathW
FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFile, LPCTSTR lpParameters, LPCTSTR lpDirectory, INT nShowCmd ) ;
-: ShellExecute ShellExecuteW ; inline
+ALIAS: ShellExecute ShellExecuteW
: open-in-explorer ( dir -- )
f "open" rot (normalize-path) f f SW_SHOWNORMAL ShellExecute drop ;
: application-data ( -- str )
CSIDL_APPDATA shell32-directory ;
-: windows ( -- str )
+: windows-directory ( -- str )
CSIDL_WINDOWS shell32-directory ;
: programs ( -- str )
: program-files-common-x86 ( -- str )
CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ;
-: SHCONTF_FOLDERS 32 ; inline
-: SHCONTF_NONFOLDERS 64 ; inline
-: SHCONTF_INCLUDEHIDDEN 128 ; inline
-: SHCONTF_INIT_ON_FIRST_NEXT 256 ; inline
-: SHCONTF_NETPRINTERSRCH 512 ; inline
-: SHCONTF_SHAREABLE 1024 ; inline
-: SHCONTF_STORAGE 2048 ; inline
+CONSTANT: SHCONTF_FOLDERS 32
+CONSTANT: SHCONTF_NONFOLDERS 64
+CONSTANT: SHCONTF_INCLUDEHIDDEN 128
+CONSTANT: SHCONTF_INIT_ON_FIRST_NEXT 256
+CONSTANT: SHCONTF_NETPRINTERSRCH 512
+CONSTANT: SHCONTF_SHAREABLE 1024
+CONSTANT: SHCONTF_STORAGE 2048
TYPEDEF: DWORD SHCONTF
-: SHGDN_NORMAL 0 ; inline
-: SHGDN_INFOLDER 1 ; inline
-: SHGDN_FOREDITING HEX: 1000 ; inline
-: SHGDN_INCLUDE_NONFILESYS HEX: 2000 ; inline
-: SHGDN_FORADDRESSBAR HEX: 4000 ; inline
-: SHGDN_FORPARSING HEX: 8000 ; inline
+CONSTANT: SHGDN_NORMAL 0
+CONSTANT: SHGDN_INFOLDER 1
+CONSTANT: SHGDN_FOREDITING HEX: 1000
+CONSTANT: SHGDN_INCLUDE_NONFILESYS HEX: 2000
+CONSTANT: SHGDN_FORADDRESSBAR HEX: 4000
+CONSTANT: SHGDN_FORPARSING HEX: 8000
TYPEDEF: DWORD SHGDNF
-: SFGAO_CANCOPY DROPEFFECT_COPY ; inline
-: SFGAO_CANMOVE DROPEFFECT_MOVE ; inline
-: SFGAO_CANLINK DROPEFFECT_LINK ; inline
-: SFGAO_CANRENAME HEX: 00000010 ; inline
-: SFGAO_CANDELETE HEX: 00000020 ; inline
-: SFGAO_HASPROPSHEET HEX: 00000040 ; inline
-: SFGAO_DROPTARGET HEX: 00000100 ; inline
-: SFGAO_CAPABILITYMASK HEX: 00000177 ; inline
-: SFGAO_LINK HEX: 00010000 ; inline
-: SFGAO_SHARE HEX: 00020000 ; inline
-: SFGAO_READONLY HEX: 00040000 ; inline
-: SFGAO_GHOSTED HEX: 00080000 ; inline
-: SFGAO_HIDDEN HEX: 00080000 ; inline
-: SFGAO_DISPLAYATTRMASK HEX: 000F0000 ; inline
-: SFGAO_FILESYSANCESTOR HEX: 10000000 ; inline
-: SFGAO_FOLDER HEX: 20000000 ; inline
-: SFGAO_FILESYSTEM HEX: 40000000 ; inline
-: SFGAO_HASSUBFOLDER HEX: 80000000 ; inline
-: SFGAO_CONTENTSMASK HEX: 80000000 ; inline
-: SFGAO_VALIDATE HEX: 01000000 ; inline
-: SFGAO_REMOVABLE HEX: 02000000 ; inline
-: SFGAO_COMPRESSED HEX: 04000000 ; inline
-: SFGAO_BROWSABLE HEX: 08000000 ; inline
-: SFGAO_NONENUMERATED HEX: 00100000 ; inline
-: SFGAO_NEWCONTENT HEX: 00200000 ; inline
+ALIAS: SFGAO_CANCOPY DROPEFFECT_COPY
+ALIAS: SFGAO_CANMOVE DROPEFFECT_MOVE
+ALIAS: SFGAO_CANLINK DROPEFFECT_LINK
+CONSTANT: SFGAO_CANRENAME HEX: 00000010
+CONSTANT: SFGAO_CANDELETE HEX: 00000020
+CONSTANT: SFGAO_HASPROPSHEET HEX: 00000040
+CONSTANT: SFGAO_DROPTARGET HEX: 00000100
+CONSTANT: SFGAO_CAPABILITYMASK HEX: 00000177
+CONSTANT: SFGAO_LINK HEX: 00010000
+CONSTANT: SFGAO_SHARE HEX: 00020000
+CONSTANT: SFGAO_READONLY HEX: 00040000
+CONSTANT: SFGAO_GHOSTED HEX: 00080000
+CONSTANT: SFGAO_HIDDEN HEX: 00080000
+CONSTANT: SFGAO_DISPLAYATTRMASK HEX: 000F0000
+CONSTANT: SFGAO_FILESYSANCESTOR HEX: 10000000
+CONSTANT: SFGAO_FOLDER HEX: 20000000
+CONSTANT: SFGAO_FILESYSTEM HEX: 40000000
+CONSTANT: SFGAO_HASSUBFOLDER HEX: 80000000
+CONSTANT: SFGAO_CONTENTSMASK HEX: 80000000
+CONSTANT: SFGAO_VALIDATE HEX: 01000000
+CONSTANT: SFGAO_REMOVABLE HEX: 02000000
+CONSTANT: SFGAO_COMPRESSED HEX: 04000000
+CONSTANT: SFGAO_BROWSABLE HEX: 08000000
+CONSTANT: SFGAO_NONENUMERATED HEX: 00100000
+CONSTANT: SFGAO_NEWCONTENT HEX: 00200000
TYPEDEF: ULONG SFGAOF
FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ;
FUNCTION: UINT DragQueryFileW ( HDROP hDrop, UINT iFile, LPWSTR lpszFile, UINT cch ) ;
-: DragQueryFile DragQueryFileW ; inline
-
+ALIAS: DragQueryFile DragQueryFileW
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types kernel math windows windows.kernel32
-namespaces calendar ;
+namespaces calendar math.bitwise ;
IN: windows.time
: >64bit ( lo hi -- n )
1601 1 1 0 0 0 instant <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n )
- [ FILETIME-dwLowDateTime ] keep
- FILETIME-dwHighDateTime >64bit ;
+ [ FILETIME-dwLowDateTime ]
+ [ FILETIME-dwHighDateTime ]
+ bi >64bit ;
: windows-time>timestamp ( n -- timestamp )
10000000 /i seconds windows-1601 swap time+ ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
[
- [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep
- >r -32 shift r> set-FILETIME-dwHighDateTime
+ [ [ 32 bits ] dip set-FILETIME-dwLowDateTime ]
+ [ [ -32 shift ] dip set-FILETIME-dwHighDateTime ] 2bi
] keep ;
: timestamp>FILETIME ( timestamp -- FILETIME/f )
- [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ;
+ dup [ >gmt timestamp>windows-time windows-time>FILETIME ] when ;
: FILETIME>timestamp ( FILETIME -- timestamp/f )
FILETIME>windows-time windows-time>timestamp ;
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax parser namespaces kernel math
-windows.types generalizations math.bitwise alias ;
+windows.types generalizations math.bitwise ;
IN: windows.user32
! HKL for ActivateKeyboardLayout
-: HKL_PREV 0 ; inline
-: HKL_NEXT 1 ; inline
-
-: CW_USEDEFAULT HEX: 80000000 ; inline
-
-: WS_OVERLAPPED HEX: 00000000 ; inline
-: WS_POPUP HEX: 80000000 ; inline
-: WS_CHILD HEX: 40000000 ; inline
-: WS_MINIMIZE HEX: 20000000 ; inline
-: WS_VISIBLE HEX: 10000000 ; inline
-: WS_DISABLED HEX: 08000000 ; inline
-: WS_CLIPSIBLINGS HEX: 04000000 ; inline
-: WS_CLIPCHILDREN HEX: 02000000 ; inline
-: WS_MAXIMIZE HEX: 01000000 ; inline
-: WS_CAPTION HEX: 00C00000 ; inline
-: WS_BORDER HEX: 00800000 ; inline
-: WS_DLGFRAME HEX: 00400000 ; inline
-: WS_VSCROLL HEX: 00200000 ; inline
-: WS_HSCROLL HEX: 00100000 ; inline
-: WS_SYSMENU HEX: 00080000 ; inline
-: WS_THICKFRAME HEX: 00040000 ; inline
-: WS_GROUP HEX: 00020000 ; inline
-: WS_TABSTOP HEX: 00010000 ; inline
-: WS_MINIMIZEBOX HEX: 00020000 ; inline
-: WS_MAXIMIZEBOX HEX: 00010000 ; inline
+CONSTANT: HKL_PREV 0
+CONSTANT: HKL_NEXT 1
+
+CONSTANT: CW_USEDEFAULT HEX: 80000000
+
+CONSTANT: WS_OVERLAPPED HEX: 00000000
+CONSTANT: WS_POPUP HEX: 80000000
+CONSTANT: WS_CHILD HEX: 40000000
+CONSTANT: WS_MINIMIZE HEX: 20000000
+CONSTANT: WS_VISIBLE HEX: 10000000
+CONSTANT: WS_DISABLED HEX: 08000000
+CONSTANT: WS_CLIPSIBLINGS HEX: 04000000
+CONSTANT: WS_CLIPCHILDREN HEX: 02000000
+CONSTANT: WS_MAXIMIZE HEX: 01000000
+CONSTANT: WS_CAPTION HEX: 00C00000
+CONSTANT: WS_BORDER HEX: 00800000
+CONSTANT: WS_DLGFRAME HEX: 00400000
+CONSTANT: WS_VSCROLL HEX: 00200000
+CONSTANT: WS_HSCROLL HEX: 00100000
+CONSTANT: WS_SYSMENU HEX: 00080000
+CONSTANT: WS_THICKFRAME HEX: 00040000
+CONSTANT: WS_GROUP HEX: 00020000
+CONSTANT: WS_TABSTOP HEX: 00010000
+CONSTANT: WS_MINIMIZEBOX HEX: 00020000
+CONSTANT: WS_MAXIMIZEBOX HEX: 00010000
! Common window styles
: WS_OVERLAPPEDWINDOW ( -- n )
: WS_POPUPWINDOW ( -- n )
{ WS_POPUP WS_BORDER WS_SYSMENU } flags ; foldable
-: WS_CHILDWINDOW WS_CHILD ; inline
+ALIAS: WS_CHILDWINDOW WS_CHILD
-: WS_TILED WS_OVERLAPPED ; inline
-: WS_ICONIC WS_MINIMIZE ; inline
-: WS_SIZEBOX WS_THICKFRAME ; inline
-: WS_TILEDWINDOW WS_OVERLAPPEDWINDOW ; inline
+ALIAS: WS_TILED WS_OVERLAPPED
+ALIAS: WS_ICONIC WS_MINIMIZE
+ALIAS: WS_SIZEBOX WS_THICKFRAME
+ALIAS: WS_TILEDWINDOW WS_OVERLAPPEDWINDOW
! Extended window styles
-: WS_EX_DLGMODALFRAME HEX: 00000001 ; inline
-: WS_EX_NOPARENTNOTIFY HEX: 00000004 ; inline
-: WS_EX_TOPMOST HEX: 00000008 ; inline
-: WS_EX_ACCEPTFILES HEX: 00000010 ; inline
-: WS_EX_TRANSPARENT HEX: 00000020 ; inline
-: WS_EX_MDICHILD HEX: 00000040 ; inline
-: WS_EX_TOOLWINDOW HEX: 00000080 ; inline
-: WS_EX_WINDOWEDGE HEX: 00000100 ; inline
-: WS_EX_CLIENTEDGE HEX: 00000200 ; inline
-: WS_EX_CONTEXTHELP HEX: 00000400 ; inline
-
-: WS_EX_RIGHT HEX: 00001000 ; inline
-: WS_EX_LEFT HEX: 00000000 ; inline
-: WS_EX_RTLREADING HEX: 00002000 ; inline
-: WS_EX_LTRREADING HEX: 00000000 ; inline
-: WS_EX_LEFTSCROLLBAR HEX: 00004000 ; inline
-: WS_EX_RIGHTSCROLLBAR HEX: 00000000 ; inline
-: WS_EX_CONTROLPARENT HEX: 00010000 ; inline
-: WS_EX_STATICEDGE HEX: 00020000 ; inline
-: WS_EX_APPWINDOW HEX: 00040000 ; inline
+CONSTANT: WS_EX_DLGMODALFRAME HEX: 00000001
+CONSTANT: WS_EX_NOPARENTNOTIFY HEX: 00000004
+CONSTANT: WS_EX_TOPMOST HEX: 00000008
+CONSTANT: WS_EX_ACCEPTFILES HEX: 00000010
+CONSTANT: WS_EX_TRANSPARENT HEX: 00000020
+CONSTANT: WS_EX_MDICHILD HEX: 00000040
+CONSTANT: WS_EX_TOOLWINDOW HEX: 00000080
+CONSTANT: WS_EX_WINDOWEDGE HEX: 00000100
+CONSTANT: WS_EX_CLIENTEDGE HEX: 00000200
+CONSTANT: WS_EX_CONTEXTHELP HEX: 00000400
+
+CONSTANT: WS_EX_RIGHT HEX: 00001000
+CONSTANT: WS_EX_LEFT HEX: 00000000
+CONSTANT: WS_EX_RTLREADING HEX: 00002000
+CONSTANT: WS_EX_LTRREADING HEX: 00000000
+CONSTANT: WS_EX_LEFTSCROLLBAR HEX: 00004000
+CONSTANT: WS_EX_RIGHTSCROLLBAR HEX: 00000000
+CONSTANT: WS_EX_CONTROLPARENT HEX: 00010000
+CONSTANT: WS_EX_STATICEDGE HEX: 00020000
+CONSTANT: WS_EX_APPWINDOW HEX: 00040000
: WS_EX_OVERLAPPEDWINDOW ( -- n )
WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
: WS_EX_PALETTEWINDOW ( -- n )
{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable
-: CS_VREDRAW HEX: 0001 ; inline
-: CS_HREDRAW HEX: 0002 ; inline
-: CS_DBLCLKS HEX: 0008 ; inline
-: CS_OWNDC HEX: 0020 ; inline
-: CS_CLASSDC HEX: 0040 ; inline
-: CS_PARENTDC HEX: 0080 ; inline
-: CS_NOCLOSE HEX: 0200 ; inline
-: CS_SAVEBITS HEX: 0800 ; inline
-: CS_BYTEALIGNCLIENT HEX: 1000 ; inline
-: CS_BYTEALIGNWINDOW HEX: 2000 ; inline
-: CS_GLOBALCLASS HEX: 4000 ; inline
-
-: COLOR_SCROLLBAR 0 ; inline
-: COLOR_BACKGROUND 1 ; inline
-: COLOR_ACTIVECAPTION 2 ; inline
-: COLOR_INACTIVECAPTION 3 ; inline
-: COLOR_MENU 4 ; inline
-: COLOR_WINDOW 5 ; inline
-: COLOR_WINDOWFRAME 6 ; inline
-: COLOR_MENUTEXT 7 ; inline
-: COLOR_WINDOWTEXT 8 ; inline
-: COLOR_CAPTIONTEXT 9 ; inline
-: COLOR_ACTIVEBORDER 10 ; inline
-: COLOR_INACTIVEBORDER 11 ; inline
-: COLOR_APPWORKSPACE 12 ; inline
-: COLOR_HIGHLIGHT 13 ; inline
-: COLOR_HIGHLIGHTTEXT 14 ; inline
-: COLOR_BTNFACE 15 ; inline
-: COLOR_BTNSHADOW 16 ; inline
-: COLOR_GRAYTEXT 17 ; inline
-: COLOR_BTNTEXT 18 ; inline
-: COLOR_INACTIVECAPTIONTEXT 19 ; inline
-: COLOR_BTNHIGHLIGHT 20 ; inline
-
-: IDI_APPLICATION 32512 ; inline
-: IDI_HAND 32513 ; inline
-: IDI_QUESTION 32514 ; inline
-: IDI_EXCLAMATION 32515 ; inline
-: IDI_ASTERISK 32516 ; inline
-: IDI_WINLOGO 32517 ; inline
+CONSTANT: CS_VREDRAW HEX: 0001
+CONSTANT: CS_HREDRAW HEX: 0002
+CONSTANT: CS_DBLCLKS HEX: 0008
+CONSTANT: CS_OWNDC HEX: 0020
+CONSTANT: CS_CLASSDC HEX: 0040
+CONSTANT: CS_PARENTDC HEX: 0080
+CONSTANT: CS_NOCLOSE HEX: 0200
+CONSTANT: CS_SAVEBITS HEX: 0800
+CONSTANT: CS_BYTEALIGNCLIENT HEX: 1000
+CONSTANT: CS_BYTEALIGNWINDOW HEX: 2000
+CONSTANT: CS_GLOBALCLASS HEX: 4000
+
+CONSTANT: COLOR_SCROLLBAR 0
+CONSTANT: COLOR_BACKGROUND 1
+CONSTANT: COLOR_ACTIVECAPTION 2
+CONSTANT: COLOR_INACTIVECAPTION 3
+CONSTANT: COLOR_MENU 4
+CONSTANT: COLOR_WINDOW 5
+CONSTANT: COLOR_WINDOWFRAME 6
+CONSTANT: COLOR_MENUTEXT 7
+CONSTANT: COLOR_WINDOWTEXT 8
+CONSTANT: COLOR_CAPTIONTEXT 9
+CONSTANT: COLOR_ACTIVEBORDER 10
+CONSTANT: COLOR_INACTIVEBORDER 11
+CONSTANT: COLOR_APPWORKSPACE 12
+CONSTANT: COLOR_HIGHLIGHT 13
+CONSTANT: COLOR_HIGHLIGHTTEXT 14
+CONSTANT: COLOR_BTNFACE 15
+CONSTANT: COLOR_BTNSHADOW 16
+CONSTANT: COLOR_GRAYTEXT 17
+CONSTANT: COLOR_BTNTEXT 18
+CONSTANT: COLOR_INACTIVECAPTIONTEXT 19
+CONSTANT: COLOR_BTNHIGHLIGHT 20
+
+CONSTANT: IDI_APPLICATION 32512
+CONSTANT: IDI_HAND 32513
+CONSTANT: IDI_QUESTION 32514
+CONSTANT: IDI_EXCLAMATION 32515
+CONSTANT: IDI_ASTERISK 32516
+CONSTANT: IDI_WINLOGO 32517
! ShowWindow() Commands
-: SW_HIDE 0 ; inline
-: SW_SHOWNORMAL 1 ; inline
-: SW_NORMAL 1 ; inline
-: SW_SHOWMINIMIZED 2 ; inline
-: SW_SHOWMAXIMIZED 3 ; inline
-: SW_MAXIMIZE 3 ; inline
-: SW_SHOWNOACTIVATE 4 ; inline
-: SW_SHOW 5 ; inline
-: SW_MINIMIZE 6 ; inline
-: SW_SHOWMINNOACTIVE 7 ; inline
-: SW_SHOWNA 8 ; inline
-: SW_RESTORE 9 ; inline
-: SW_SHOWDEFAULT 10 ; inline
-: SW_FORCEMINIMIZE 11 ; inline
-: SW_MAX 11 ; inline
+CONSTANT: SW_HIDE 0
+CONSTANT: SW_SHOWNORMAL 1
+CONSTANT: SW_NORMAL 1
+CONSTANT: SW_SHOWMINIMIZED 2
+CONSTANT: SW_SHOWMAXIMIZED 3
+CONSTANT: SW_MAXIMIZE 3
+CONSTANT: SW_SHOWNOACTIVATE 4
+CONSTANT: SW_SHOW 5
+CONSTANT: SW_MINIMIZE 6
+CONSTANT: SW_SHOWMINNOACTIVE 7
+CONSTANT: SW_SHOWNA 8
+CONSTANT: SW_RESTORE 9
+CONSTANT: SW_SHOWDEFAULT 10
+CONSTANT: SW_FORCEMINIMIZE 11
+CONSTANT: SW_MAX 11
! PeekMessage
-: PM_NOREMOVE 0 ; inline
-: PM_REMOVE 1 ; inline
-: PM_NOYIELD 2 ; inline
+CONSTANT: PM_NOREMOVE 0
+CONSTANT: PM_REMOVE 1
+CONSTANT: PM_NOYIELD 2
! : PM_QS_INPUT (QS_INPUT << 16) ;
! : PM_QS_POSTMESSAGE ((QS_POSTMESSAGE | QS_HOTKEY | QS_TIMER) << 16) ;
! : PM_QS_PAINT (QS_PAINT << 16) ;
: MB_ICONQUESTION HEX: 00000020 ; inline
: MB_OK HEX: 00000000 ; inline
-: FVIRTKEY TRUE ; inline
+ALIAS: FVIRTKEY TRUE
: FNOINVERT 2 ; inline
: FSHIFT 4 ; inline
: FCONTROL 8 ; inline
ALIAS: CreateWindowEx CreateWindowExW
-: CreateWindow 0 12 -nrot CreateWindowEx ; inline
+: CreateWindow ( a b c d e f g h i j k -- hwnd ) 0 12 -nrot CreateWindowEx ; inline
! FUNCTION: CreateWindowStationA
! FUNCTION: SetKeyboardState
! type is ignored
FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
-: SetLastError 0 SetLastErrorEx ; inline
+: SetLastError ( errcode -- ) 0 SetLastErrorEx ; inline
! FUNCTION: SetLayeredWindowAttributes
! FUNCTION: SetLogonNotifyWindow
! FUNCTION: SetMenu
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors windows math.bitwise alias io.encodings.utf16n ;
+windows.errors windows math.bitwise io.encodings.utf16n ;
IN: windows.winsock
USE: libc
: <wsadata> ( -- byte-array )
HEX: 190 <byte-array> ;
-: SOCK_STREAM 1 ; inline
-: SOCK_DGRAM 2 ; inline
-: SOCK_RAW 3 ; inline
-: SOCK_RDM 4 ; inline
-: SOCK_SEQPACKET 5 ; inline
-
-: SO_DEBUG HEX: 1 ; inline
-: SO_ACCEPTCONN HEX: 2 ; inline
-: SO_REUSEADDR HEX: 4 ; inline
-: SO_KEEPALIVE HEX: 8 ; inline
-: SO_DONTROUTE HEX: 10 ; inline
-: SO_BROADCAST HEX: 20 ; inline
-: SO_USELOOPBACK HEX: 40 ; inline
-: SO_LINGER HEX: 80 ; inline
-: SO_OOBINLINE HEX: 100 ; inline
-: SO_DONTLINGER SO_LINGER bitnot ; inline
-
-: SO_SNDBUF HEX: 1001 ; inline
-: SO_RCVBUF HEX: 1002 ; inline
-: SO_SNDLOWAT HEX: 1003 ; inline
-: SO_RCVLOWAT HEX: 1004 ; inline
-: SO_SNDTIMEO HEX: 1005 ; inline
-: SO_RCVTIMEO HEX: 1006 ; inline
-: SO_ERROR HEX: 1007 ; inline
-: SO_TYPE HEX: 1008 ; inline
-
-: TCP_NODELAY HEX: 1 ; inline
-
-: AF_UNSPEC 0 ; inline
-: AF_UNIX 1 ; inline
-: AF_INET 2 ; inline
-: AF_IMPLINK 3 ; inline
-: AF_PUP 4 ; inline
-: AF_CHAOS 5 ; inline
-: AF_NS 6 ; inline
-: AF_ISO 7 ; inline
-: AF_OSI AF_ISO ; inline
-: AF_ECMA 8 ; inline
-: AF_DATAKIT 9 ; inline
-: AF_CCITT 10 ; inline
-: AF_SNA 11 ; inline
-: AF_DECnet 12 ; inline
-: AF_DLI 13 ; inline
-: AF_LAT 14 ; inline
-: AF_HYLINK 15 ; inline
-: AF_APPLETALK 16 ; inline
-: AF_NETBIOS 17 ; inline
-: AF_MAX 18 ; inline
-: AF_INET6 23 ; inline
-: AF_IRDA 26 ; inline
-: AF_BTM 32 ; inline
-
-: PF_UNSPEC 0 ; inline
-: PF_LOCAL 1 ; inline
-: PF_INET 2 ; inline
-: PF_INET6 23 ; inline
-
-: AI_PASSIVE 1 ; inline
-: AI_CANONNAME 2 ; inline
-: AI_NUMERICHOST 4 ; inline
+CONSTANT: SOCK_STREAM 1
+CONSTANT: SOCK_DGRAM 2
+CONSTANT: SOCK_RAW 3
+CONSTANT: SOCK_RDM 4
+CONSTANT: SOCK_SEQPACKET 5
+
+CONSTANT: SO_DEBUG HEX: 1
+CONSTANT: SO_ACCEPTCONN HEX: 2
+CONSTANT: SO_REUSEADDR HEX: 4
+CONSTANT: SO_KEEPALIVE HEX: 8
+CONSTANT: SO_DONTROUTE HEX: 10
+CONSTANT: SO_BROADCAST HEX: 20
+CONSTANT: SO_USELOOPBACK HEX: 40
+CONSTANT: SO_LINGER HEX: 80
+CONSTANT: SO_OOBINLINE HEX: 100
+: SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
+
+CONSTANT: SO_SNDBUF HEX: 1001
+CONSTANT: SO_RCVBUF HEX: 1002
+CONSTANT: SO_SNDLOWAT HEX: 1003
+CONSTANT: SO_RCVLOWAT HEX: 1004
+CONSTANT: SO_SNDTIMEO HEX: 1005
+CONSTANT: SO_RCVTIMEO HEX: 1006
+CONSTANT: SO_ERROR HEX: 1007
+CONSTANT: SO_TYPE HEX: 1008
+
+CONSTANT: TCP_NODELAY HEX: 1
+
+CONSTANT: AF_UNSPEC 0
+CONSTANT: AF_UNIX 1
+CONSTANT: AF_INET 2
+CONSTANT: AF_IMPLINK 3
+CONSTANT: AF_PUP 4
+CONSTANT: AF_CHAOS 5
+CONSTANT: AF_NS 6
+CONSTANT: AF_ISO 7
+ALIAS: AF_OSI AF_ISO
+CONSTANT: AF_ECMA 8
+CONSTANT: AF_DATAKIT 9
+CONSTANT: AF_CCITT 10
+CONSTANT: AF_SNA 11
+CONSTANT: AF_DECnet 12
+CONSTANT: AF_DLI 13
+CONSTANT: AF_LAT 14
+CONSTANT: AF_HYLINK 15
+CONSTANT: AF_APPLETALK 16
+CONSTANT: AF_NETBIOS 17
+CONSTANT: AF_MAX 18
+CONSTANT: AF_INET6 23
+CONSTANT: AF_IRDA 26
+CONSTANT: AF_BTM 32
+
+CONSTANT: PF_UNSPEC 0
+CONSTANT: PF_LOCAL 1
+CONSTANT: PF_INET 2
+CONSTANT: PF_INET6 23
+
+CONSTANT: AI_PASSIVE 1
+CONSTANT: AI_CANONNAME 2
+CONSTANT: AI_NUMERICHOST 4
: AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
-: NI_NUMERICHOST 1 ;
-: NI_NUMERICSERV 2 ;
+CONSTANT: NI_NUMERICHOST 1
+CONSTANT: NI_NUMERICSERV 2
-: IPPROTO_TCP 6 ; inline
-: IPPROTO_UDP 17 ; inline
-: IPPROTO_RM 113 ; inline
+CONSTANT: IPPROTO_TCP 6
+CONSTANT: IPPROTO_UDP 17
+CONSTANT: IPPROTO_RM 113
-: WSA_FLAG_OVERLAPPED 1 ; inline
-: WSA_WAIT_EVENT_0 WAIT_OBJECT_0 ; inline
-: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS ; inline
-: WSA_INVALID_EVENT f ; inline
-: WSA_WAIT_FAILED -1 ; inline
-: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION ; inline
-: WSA_WAIT_TIMEOUT WAIT_TIMEOUT ; inline
-: WSA_INFINITE INFINITE ; inline
-: WSA_IO_PENDING ERROR_IO_PENDING ; inline
+CONSTANT: WSA_FLAG_OVERLAPPED 1
+ALIAS: WSA_WAIT_EVENT_0 WAIT_OBJECT_0
+ALIAS: WSA_MAXIMUM_WAIT_EVENTS MAXIMUM_WAIT_OBJECTS
+CONSTANT: WSA_INVALID_EVENT f
+CONSTANT: WSA_WAIT_FAILED -1
+ALIAS: WSA_WAIT_IO_COMPLETION WAIT_IO_COMPLETION
+ALIAS: WSA_WAIT_TIMEOUT WAIT_TIMEOUT
+ALIAS: WSA_INFINITE INFINITE
+ALIAS: WSA_IO_PENDING ERROR_IO_PENDING
-: INADDR_ANY 0 ; inline
+CONSTANT: INADDR_ANY 0
-: INVALID_SOCKET -1 <alien> ; inline
-: SOCKET_ERROR -1 ; inline
+: INVALID_SOCKET
( -- alien ) -1 <alien> ; inline
+CONSTANT: SOCKET_ERROR -1
-: SD_RECV 0 ; inline
-: SD_SEND 1 ; inline
-: SD_BOTH 2 ; inline
+CONSTANT: SD_RECV 0
+CONSTANT: SD_SEND 1
+CONSTANT: SD_BOTH 2
-: SOL_SOCKET HEX: ffff ; inline
+CONSTANT: SOL_SOCKET HEX: ffff
! TYPEDEF: uint in_addr_t
! C-STRUCT: in_addr
{ "WSABUF" "ProviderSpecific" } ;
TYPEDEF: QOS* LPQOS
-: MAX_PROTOCOL_CHAIN 7 ; inline
+CONSTANT: MAX_PROTOCOL_CHAIN 7
C-STRUCT: WSAPROTOCOLCHAIN
{ "int" "ChainLen" }
{ { "DWORD" 7 } "ChainEntries" } ;
TYPEDEF: WSAPROTOCOLCHAIN* LPWSAPROTOCOLCHAIN
-: WSAPROTOCOL_LEN 255 ; inline
+CONSTANT: WSAPROTOCOL_LEN 255
C-STRUCT: WSAPROTOCOL_INFOW
{ "DWORD" "dwServiceFlags1" }
FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
-: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090 ; inline
+CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
: WSAID_CONNECTEX ( -- GUID )
"GUID" <c-object>
"org.factorcode.Factor.SELECTION" x-atom ;
: convert-selection ( win selection -- )
- swap >r >r dpy get r> XA_UTF8_STRING selection-property r>
+ swap [ [ dpy get ] dip XA_UTF8_STRING selection-property ] dip
CurrentTime XConvertSelection drop ;
: snarf-property ( prop-return -- string )
dup *void* [ *void* ascii alien>string ] [ drop f ] if ;
: window-property ( win prop delete? -- string )
- >r dpy get -rot 0 -1 r> AnyPropertyType
+ [ [ dpy get ] 2dip 0 -1 ] dip AnyPropertyType
0 <Atom> 0 <int> 0 <ulong> 0 <ulong> f <void*>
[ XGetWindowProperty drop ] keep snarf-property ;
dpy get swap
[ XSelectionRequestEvent-requestor ] keep
[ XSelectionRequestEvent-property ] keep
- >r "TIMESTAMP" x-atom 32 PropModeReplace r>
+ [ "TIMESTAMP" x-atom 32 PropModeReplace ] dip
XSelectionRequestEvent-time <int>
1 XChangeProperty drop ;
over XSelectionRequestEvent-selection over set-XSelectionEvent-selection
over XSelectionRequestEvent-target over set-XSelectionEvent-target
over XSelectionRequestEvent-time over set-XSelectionEvent-time
- >r dpy get swap XSelectionRequestEvent-requestor 0 0 r>
+ [ dpy get swap XSelectionRequestEvent-requestor 0 0 ] dip
XSendEvent drop
flush-dpy ;
GENERIC: client-event ( event window -- )
: next-event ( -- event )
- dpy get "XEvent" <c-object> dup >r XNextEvent drop r> ;
+ dpy get "XEvent" <c-object> [ XNextEvent drop ] keep ;
: mask-event ( mask -- event )
- >r dpy get r> "XEvent" <c-object> dup >r XMaskEvent drop r> ;
+ [ dpy get ] dip "XEvent" <c-object> [ XMaskEvent drop ] keep ;
-: events-queued ( mode -- n ) >r dpy get r> XEventsQueued ;
+: events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ;
: wheel? ( event -- ? ) XButtonEvent-button 4 7 between? ;
} case ;
: configured-loc ( event -- dim )
- dup XConfigureEvent-x swap XConfigureEvent-y 2array ;
+ [ XConfigureEvent-x ] [ XConfigureEvent-y ] bi 2array ;
: configured-dim ( event -- dim )
- dup XConfigureEvent-width swap XConfigureEvent-height 2array ;
+ [ XConfigureEvent-width ] [ XConfigureEvent-height ] bi 2array ;
: mouse-event-loc ( event -- loc )
- dup XButtonEvent-x swap XButtonEvent-y 2array ;
+ [ XButtonEvent-x ] [ XButtonEvent-y ] bi 2array ;
: close-box? ( event -- ? )
- dup XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom =
- swap XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom =
- and ;
+ [ XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom = ]
+ [ XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom = ]
+ bi and ;
"XSetWindowAttributes" <c-object>
0 over set-XSetWindowAttributes-background_pixel
0 over set-XSetWindowAttributes-border_pixel
- [ >r create-colormap r> set-XSetWindowAttributes-colormap ] keep
+ [ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
event-mask over set-XSetWindowAttributes-event_mask ;
: set-size-hints ( window -- )
{ 0 0 } = [ drop ] [ set-size-hints ] if ;
: create-window ( loc dim visinfo -- window )
- pick >r
- >r >r >r dpy get root get r> first2 r> { 1 1 } vmax first2 0 r>
- [ XVisualInfo-depth InputOutput ] keep
- [ XVisualInfo-visual create-window-mask ] keep
- window-attributes XCreateWindow
- dup r> auto-position ;
+ pick [
+ [ [ [ dpy get root get ] dip first2 ] dip { 1 1 } vmax first2 0 ] dip
+ [ XVisualInfo-depth InputOutput ] keep
+ [ XVisualInfo-visual create-window-mask ] keep
+ window-attributes XCreateWindow
+ dup
+ ] dip auto-position ;
: glx-window ( loc dim -- window glx )
GLX_DOUBLEBUFFER 1array choose-visual
TYPEDEF: void* Window**
TYPEDEF: void* Atom**
-: <XID> <ulong> ; inline
-: <Window> <XID> ; inline
-: <Drawable> <XID> ; inline
-: <KeySym> <XID> ; inline
-: <Atom> <ulong> ; inline
-
-: *XID *ulong ; inline
-: *Window *XID ; inline
-: *Drawable *XID ; inline
-: *KeySym *XID ; inline
-: *Atom *ulong ; inline
+ALIAS: <XID> <ulong>
+ALIAS: <Window> <XID>
+ALIAS: <Drawable> <XID>
+ALIAS: <KeySym> <XID>
+ALIAS: <Atom> <ulong>
+
+ALIAS: *XID *ulong
+ALIAS: *Window *XID
+ALIAS: *Drawable *XID
+ALIAS: *KeySym *XID
+ALIAS: *Atom *ulong
!
! 2 - Display Functions
!
! 3.2 - Window Attributes
-: CWBackPixmap 1 0 shift ; inline
-: CWBackPixel 1 1 shift ; inline
-: CWBorderPixmap 1 2 shift ; inline
-: CWBorderPixel 1 3 shift ; inline
-: CWBitGravity 1 4 shift ; inline
-: CWWinGravity 1 5 shift ; inline
-: CWBackingStore 1 6 shift ; inline
-: CWBackingPlanes 1 7 shift ; inline
-: CWBackingPixel 1 8 shift ; inline
-: CWOverrideRedirect 1 9 shift ; inline
-: CWSaveUnder 1 10 shift ; inline
-: CWEventMask 1 11 shift ; inline
-: CWDontPropagate 1 12 shift ; inline
-: CWColormap 1 13 shift ; inline
-: CWCursor 1 14 shift ; inline
+: CWBackPixmap ( -- n ) 0 2^ ; inline
+: CWBackPixel ( -- n ) 1 2^ ; inline
+: CWBorderPixmap ( -- n ) 2 2^ ; inline
+: CWBorderPixel ( -- n ) 3 2^ ; inline
+: CWBitGravity ( -- n ) 4 2^ ; inline
+: CWWinGravity ( -- n ) 5 2^ ; inline
+: CWBackingStore ( -- n ) 6 2^ ; inline
+: CWBackingPlanes ( -- n ) 7 2^ ; inline
+: CWBackingPixel ( -- n ) 8 2^ ; inline
+: CWOverrideRedirect ( -- n ) 9 2^ ; inline
+: CWSaveUnder ( -- n ) 10 2^ ; inline
+: CWEventMask ( -- n ) 11 2^ ; inline
+: CWDontPropagate ( -- n ) 12 2^ ; inline
+: CWColormap ( -- n ) 13 2^ ; inline
+: CWCursor ( -- n ) 14 2^ ; inline
C-STRUCT: XSetWindowAttributes
{ "Pixmap" "background_pixmap" }
! 3.7 - Configuring Windows
-: CWX 1 0 shift ; inline
-: CWY 1 1 shift ; inline
-: CWWidth 1 2 shift ; inline
-: CWHeight 1 3 shift ; inline
-: CWBorderWidth 1 4 shift ; inline
-: CWSibling 1 5 shift ; inline
-: CWStackMode 1 6 shift ; inline
+: CWX ( -- n ) 0 2^ ; inline
+: CWY ( -- n ) 1 2^ ; inline
+: CWWidth ( -- n ) 2 2^ ; inline
+: CWHeight ( -- n ) 3 2^ ; inline
+: CWBorderWidth ( -- n ) 4 2^ ; inline
+: CWSibling ( -- n ) 5 2^ ; inline
+: CWStackMode ( -- n ) 6 2^ ; inline
C-STRUCT: XWindowChanges
{ "int" "x" }
! 7 - Graphics Context Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: GCFunction 1 0 shift ; inline
-: GCPlaneMask 1 1 shift ; inline
-: GCForeground 1 2 shift ; inline
-: GCBackground 1 3 shift ; inline
-: GCLineWidth 1 4 shift ; inline
-: GCLineStyle 1 5 shift ; inline
-: GCCapStyle 1 6 shift ; inline
-: GCJoinStyle 1 7 shift ; inline
-: GCFillStyle 1 8 shift ; inline
-: GCFillRule 1 9 shift ; inline
-: GCTile 1 10 shift ; inline
-: GCStipple 1 11 shift ; inline
-: GCTileStipXOrigin 1 12 shift ; inline
-: GCTileStipYOrigin 1 13 shift ; inline
-: GCFont 1 14 shift ; inline
-: GCSubwindowMode 1 15 shift ; inline
-: GCGraphicsExposures 1 16 shift ; inline
-: GCClipXOrigin 1 17 shift ; inline
-: GCClipYOrigin 1 18 shift ; inline
-: GCClipMask 1 19 shift ; inline
-: GCDashOffset 1 20 shift ; inline
-: GCDashList 1 21 shift ; inline
-: GCArcMode 1 22 shift ; inline
+: GCFunction ( -- n ) 0 2^ ; inline
+: GCPlaneMask ( -- n ) 1 2^ ; inline
+: GCForeground ( -- n ) 2 2^ ; inline
+: GCBackground ( -- n ) 3 2^ ; inline
+: GCLineWidth ( -- n ) 4 2^ ; inline
+: GCLineStyle ( -- n ) 5 2^ ; inline
+: GCCapStyle ( -- n ) 6 2^ ; inline
+: GCJoinStyle ( -- n ) 7 2^ ; inline
+: GCFillStyle ( -- n ) 8 2^ ; inline
+: GCFillRule ( -- n ) 9 2^ ; inline
+: GCTile ( -- n ) 10 2^ ; inline
+: GCStipple ( -- n ) 11 2^ ; inline
+: GCTileStipXOrigin ( -- n ) 12 2^ ; inline
+: GCTileStipYOrigin ( -- n ) 13 2^ ; inline
+: GCFont ( -- n ) 14 2^ ; inline
+: GCSubwindowMode ( -- n ) 15 2^ ; inline
+: GCGraphicsExposures ( -- n ) 16 2^ ; inline
+: GCClipXOrigin ( -- n ) 17 2^ ; inline
+: GCClipYOrigin ( -- n ) 18 2^ ; inline
+: GCClipMask ( -- n ) 19 2^ ; inline
+: GCDashOffset ( -- n ) 20 2^ ; inline
+: GCDashList ( -- n ) 21 2^ ; inline
+: GCArcMode ( -- n ) 22 2^ ; inline
: GXclear HEX: 0 ; inline
: GXand HEX: 1 ; inline
! 10.3 - Event Masks
-: NoEventMask 0 ; inline
-: KeyPressMask 1 0 shift ; inline
-: KeyReleaseMask 1 1 shift ; inline
-: ButtonPressMask 1 2 shift ; inline
-: ButtonReleaseMask 1 3 shift ; inline
-: EnterWindowMask 1 4 shift ; inline
-: LeaveWindowMask 1 5 shift ; inline
-: PointerMotionMask 1 6 shift ; inline
-: PointerMotionHintMask 1 7 shift ; inline
-: Button1MotionMask 1 8 shift ; inline
-: Button2MotionMask 1 9 shift ; inline
-: Button3MotionMask 1 10 shift ; inline
-: Button4MotionMask 1 11 shift ; inline
-: Button5MotionMask 1 12 shift ; inline
-: ButtonMotionMask 1 13 shift ; inline
-: KeymapStateMask 1 14 shift ; inline
-: ExposureMask 1 15 shift ; inline
-: VisibilityChangeMask 1 16 shift ; inline
-: StructureNotifyMask 1 17 shift ; inline
-: ResizeRedirectMask 1 18 shift ; inline
-: SubstructureNotifyMask 1 19 shift ; inline
-: SubstructureRedirectMask 1 20 shift ; inline
-: FocusChangeMask 1 21 shift ; inline
-: PropertyChangeMask 1 22 shift ; inline
-: ColormapChangeMask 1 23 shift ; inline
-: OwnerGrabButtonMask 1 24 shift ; inline
+: NoEventMask ( -- n ) 0 ; inline
+: KeyPressMask ( -- n ) 0 2^ ; inline
+: KeyReleaseMask ( -- n ) 1 2^ ; inline
+: ButtonPressMask ( -- n ) 2 2^ ; inline
+: ButtonReleaseMask ( -- n ) 3 2^ ; inline
+: EnterWindowMask ( -- n ) 4 2^ ; inline
+: LeaveWindowMask ( -- n ) 5 2^ ; inline
+: PointerMotionMask ( -- n ) 6 2^ ; inline
+: PointerMotionHintMask ( -- n ) 7 2^ ; inline
+: Button1MotionMask ( -- n ) 8 2^ ; inline
+: Button2MotionMask ( -- n ) 9 2^ ; inline
+: Button3MotionMask ( -- n ) 10 2^ ; inline
+: Button4MotionMask ( -- n ) 11 2^ ; inline
+: Button5MotionMask ( -- n ) 12 2^ ; inline
+: ButtonMotionMask ( -- n ) 13 2^ ; inline
+: KeymapStateMask ( -- n ) 14 2^ ; inline
+: ExposureMask ( -- n ) 15 2^ ; inline
+: VisibilityChangeMask ( -- n ) 16 2^ ; inline
+: StructureNotifyMask ( -- n ) 17 2^ ; inline
+: ResizeRedirectMask ( -- n ) 18 2^ ; inline
+: SubstructureNotifyMask ( -- n ) 19 2^ ; inline
+: SubstructureRedirectMask ( -- n ) 20 2^ ; inline
+: FocusChangeMask ( -- n ) 21 2^ ; inline
+: PropertyChangeMask ( -- n ) 22 2^ ; inline
+: ColormapChangeMask ( -- n ) 23 2^ ; inline
+: OwnerGrabButtonMask ( -- n ) 24 2^ ; inline
: KeyPress 2 ; inline
: KeyRelease 3 ; inline
: Button4 4 ; inline
: Button5 5 ; inline
-: Button1Mask 1 8 shift ; inline
-: Button2Mask 1 9 shift ; inline
-: Button3Mask 1 10 shift ; inline
-: Button4Mask 1 11 shift ; inline
-: Button5Mask 1 12 shift ; inline
-
-: ShiftMask 1 0 shift ; inline
-: LockMask 1 1 shift ; inline
-: ControlMask 1 2 shift ; inline
-: Mod1Mask 1 3 shift ; inline
-: Mod2Mask 1 4 shift ; inline
-: Mod3Mask 1 5 shift ; inline
-: Mod4Mask 1 6 shift ; inline
-: Mod5Mask 1 7 shift ; inline
+: Button1Mask ( -- n ) 1 8 shift ; inline
+: Button2Mask ( -- n ) 1 9 shift ; inline
+: Button3Mask ( -- n ) 1 10 shift ; inline
+: Button4Mask ( -- n ) 1 11 shift ; inline
+: Button5Mask ( -- n ) 1 12 shift ; inline
+
+: ShiftMask ( -- n ) 1 0 shift ; inline
+: LockMask ( -- n ) 1 1 shift ; inline
+: ControlMask ( -- n ) 1 2 shift ; inline
+: Mod1Mask ( -- n ) 1 3 shift ; inline
+: Mod2Mask ( -- n ) 1 4 shift ; inline
+: Mod3Mask ( -- n ) 1 5 shift ; inline
+: Mod4Mask ( -- n ) 1 6 shift ; inline
+: Mod5Mask ( -- n ) 1 7 shift ; inline
C-STRUCT: XButtonEvent
{ "int" "type" }
! !!! INPUT METHODS
-: XIMPreeditArea HEX: 0001 ;
-: XIMPreeditCallbacks HEX: 0002 ;
-: XIMPreeditPosition HEX: 0004 ;
-: XIMPreeditNothing HEX: 0008 ;
-: XIMPreeditNone HEX: 0010 ;
-: XIMStatusArea HEX: 0100 ;
-: XIMStatusCallbacks HEX: 0200 ;
-: XIMStatusNothing HEX: 0400 ;
-: XIMStatusNone HEX: 0800 ;
+: XIMPreeditArea HEX: 0001 ; inline
+: XIMPreeditCallbacks HEX: 0002 ; inline
+: XIMPreeditPosition HEX: 0004 ; inline
+: XIMPreeditNothing HEX: 0008 ; inline
+: XIMPreeditNone HEX: 0010 ; inline
+: XIMStatusArea HEX: 0100 ; inline
+: XIMStatusCallbacks HEX: 0200 ; inline
+: XIMStatusNothing HEX: 0400 ; inline
+: XIMStatusNone HEX: 0800 ; inline
: XNVaNestedList "XNVaNestedList" ;
: XNQueryInputStyle "queryInputStyle" ;
{ $see-also <base64> } ;
HELP: <rpc-method>
-{ $values { "name" "a string" } { "params" "a sequence" } }
+{ $values { "name" "a string" } { "params" "a sequence" } { "rpc-method" rpc-method } }
{ $description "creates a tuple reprsenting a method call which can be translated using send-rpc into an XML-RPC document" }
{ $see-also rpc-method <rpc-response> <rpc-fault> } ;
{ $see-also <rpc-method> rpc-response rpc-fault } ;
HELP: <rpc-response>
-{ $values { "params" "a sequence" } }
+{ $values { "params" "a sequence" } { "rpc-response" rpc-response } }
{ $description "creates a tuple representing a data response in XML-RPC" }
{ $see-also rpc-response <rpc-method> <rpc-fault> } ;
{ $see-also <rpc-response> rpc-method rpc-fault } ;
HELP: <rpc-fault>
-{ $values { "code" "an integer" } { "string" "a string" } }
+{ $values { "code" "an integer" } { "string" "a string" } { "rpc-fault" rpc-fault } }
{ $description "creates a tuple representing an exception in RPC, to be returned to the caller. The code is a number representing what type of error it is, and the string is a description" }
{ $see-also rpc-fault <rpc-method> <rpc-response> } ;
{ $class-description "represents an XML name, with the fields space (a string representing the namespace, as written in the document, tag (a string of the actual name of the tag) and url (a string of the URL that the namespace points to)" }\r
{ $see-also <name> tag } ;\r
\r
-HELP: <name> ( space tag url -- name )\r
-{ $values { "space" "a string" } { "tag" "a string" } { "url" "a string" }\r
+HELP: <name>\r
+{ $values { "space" "a string" } { "main" "a string" } { "url" "a string" }\r
{ "name" "an XML tag name" } }\r
{ $description "creates a name tuple with the name-space space and the tag-name tag and the tag-url url." }\r
{ $see-also name <tag> } ;\r
\r
HELP: <xml>\r
{ $values { "prolog" "an XML prolog" } { "before" "a sequence of XML elements" }\r
-{ "main" tag } { "after" "a sequence of XML elements" } { "xml" "an XML document" } }\r
+{ "body" tag } { "after" "a sequence of XML elements" } { "xml" "an XML document" } }\r
{ $description "creates an XML document, delegating to the main tag, with the specified prolog, before, and after" }\r
{ $see-also xml <tag> } ;\r
\r
{ $class-description "represents an XML prolog, with the tuple fields version (containing \"1.0\" or \"1.1\"), encoding (a string representing the encoding type), and standalone (t or f, whether the document is standalone without external entities)" }\r
{ $see-also <prolog> xml } ;\r
\r
-HELP: <prolog> ( version encoding standalone -- prolog )\r
+HELP: <prolog>\r
{ $values { "version" "a string, 1.0 or 1.1" }\r
{ "encoding" "a string" } { "standalone" "a boolean" } { "prolog" "an XML prolog" } }\r
{ $description "creates an XML prolog tuple" }\r
{ $class-description "represents a comment in XML. Has one slot, text, which contains the string of the comment" }\r
{ $see-also <comment> } ;\r
\r
-HELP: <comment> ( text -- comment )\r
+HELP: <comment>\r
{ $values { "text" "a string" } { "comment" "a comment" } }\r
{ $description "creates an XML comment tuple" }\r
{ $see-also comment } ;\r
{ $class-description "represents an XML instruction, such as <?xsl stylesheet='foo.xml'?>. Contains one slot, text, which contains the string between the question marks." }\r
{ $see-also <instruction> } ;\r
\r
-HELP: <instruction> ( text -- instruction )\r
+HELP: <instruction>\r
{ $values { "text" "a string" } { "instruction" "an XML instruction" } }\r
{ $description "creates an XML parsing instruction, such as <?xsl stylesheet='foo.xml'?>." }\r
{ $see-also instruction } ;\r
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: io io.files io.encodings.utf8 namespaces http.server\r
-http.server.responses http.server.static http xmode.code2html\r
-kernel sequences accessors fry ;\r
+USING: io io.files io.pathnames io.encodings.utf8 namespaces\r
+http.server http.server.responses http.server.static http\r
+xmode.code2html kernel sequences accessors fry ;\r
IN: xmode.code2html.responder\r
\r
: <sources> ( root -- responder )\r
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: xmode.marker.context xmode.rules symbols accessors
+USING: xmode.marker.context xmode.rules accessors
xmode.tokens namespaces make kernel sequences assocs math ;
IN: xmode.marker.state
xml.data xml.utilities combinators macros parser lexer words fry ;
IN: xmode.utilities
-: implies [ not ] dip or ; inline
+: implies ( x y -- z ) [ not ] dip or ; inline
: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
] if ; inline recursive
: assoc-stack ( key seq -- value )
- dup length 1- swap (assoc-stack) ; flushable
+ [ length 1- ] keep (assoc-stack) ; flushable
: assoc-subset? ( assoc1 assoc2 -- ? )
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
: remove-all ( assoc seq -- subseq )
swap [ key? not ] curry filter ;
-: (substitute)
+: substituter ( assoc -- quot )
[ dupd at* [ nip ] [ drop ] if ] curry ; inline
: substitute-here ( seq assoc -- )
- (substitute) change-each ;
+ substituter change-each ;
: substitute ( seq assoc -- newseq )
- (substitute) map ;
+ substituter map ;
: cache ( key assoc quot -- value )
2over at* [
"((empty))" "hashtables.private" create
"tombstone" "hashtables.private" lookup f
-2array >tuple 1quotation define-inline
+2array >tuple 1quotation (( -- value )) define-inline
"((tombstone))" "hashtables.private" create
"tombstone" "hashtables.private" lookup t
-2array >tuple 1quotation define-inline
+2array >tuple 1quotation (( -- value )) define-inline
! Some tuple classes
"curry" "kernel" create
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: words sequences vocabs kernel ;
+USING: words words.symbol sequences vocabs kernel ;
IN: bootstrap.syntax
"syntax" create-vocab drop
"PRIVATE>"
"SBUF\""
"SINGLETON:"
+ "SINGLETONS:"
"SYMBOL:"
+ "SYMBOLS:"
+ "CONSTANT:"
"TUPLE:"
"SLOT:"
"T{"
"INTERSECTION:"
"USE:"
"USING:"
+ "QUALIFIED:"
+ "QUALIFIED-WITH:"
+ "FROM:"
+ "EXCLUDE:"
+ "RENAME:"
+ "ALIAS:"
"V{"
"W{"
"["
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math.parser io io.encodings.binary io.files
+USING: sequences math.parser io io.backend io.files
kernel ;
IN: checksums
[ B{ CHAR: \n } join ] dip checksum-bytes ;
: checksum-file ( path checksum -- value )
- [ binary <file-reader> ] dip checksum-stream ;
+ #! normalize-path (file-reader) is equivalen to
+ #! binary <file-reader>. We use the lower-level form
+ #! so that we can move io.encodings.binary to basis/.
+ [ normalize-path (file-reader) ] dip checksum-stream ;
: hex-string ( seq -- str )
[ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;
INSTANCE: crc32 checksum
-: init-crc32 drop [ HEX: ffffffff dup ] dip ; inline
+: init-crc32 ( input checksum -- x y input )
+ drop [ HEX: ffffffff dup ] dip ; inline
-: finish-crc32 bitxor 4 >be ; inline
+: finish-crc32 ( x y -- bytes )
+ bitxor 4 >be ; inline
M: crc32 checksum-bytes
init-crc32
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions assocs kernel kernel.private
-slots.private namespaces make sequences strings words vectors
-math quotations combinators sorting effects graphs vocabs sets ;
+slots.private namespaces make sequences strings words words.symbol
+vectors math quotations combinators sorting effects graphs
+vocabs sets ;
IN: classes
SYMBOL: class<=-cache
ARTICLE: "singletons" "Singleton classes"
"A singleton is a class with only one instance and with no state."
{ $subsection POSTPONE: SINGLETON: }
+{ $subsection POSTPONE: SINGLETONS: }
{ $subsection define-singleton-class }
"The set of all singleton classes is itself a class:"
{ $subsection singleton-class? }
tri* define-declared
] 3tri ;
+: boa-effect ( class -- effect )
+ [ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;
+
+: define-boa-word ( word class -- )
+ [ [ boa ] curry ] [ boa-effect ] bi define-inline ;
+
M: tuple-class reset-class
[
dup "slots" word-prop [
IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
-quotations ;
+quotations words.symbol ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"The compiler saves various notifications in a global variable:"
{ $values { "quot" "a quotation" } }
{ $description "Runs a quotation. Throws an error if the quotation attempts to take input values from the stack, or leave outputs on the stack." } ;
-HELP: <continuation>
-{ $description "Constructs a new continuation." }
-{ $notes "User code should call " { $link continuation } " instead." } ;
-
HELP: attempt-all
{ $values
{ "seq" sequence } { "quot" quotation }
GENERIC: stack-effect ( word -- effect/f )
-M: symbol stack-effect drop (( -- symbol )) ;
-
M: word stack-effect
{ "declared-effect" "inferred-effect" }
swap props>> [ at ] curry map [ ] find nip ;
] change-at ;
: flatten-method ( class method assoc -- )
- [ dup flatten-class keys swap ] 2dip [
+ [ [ flatten-class keys ] keep ] 2dip [
[ spin ] dip push-method
] 3curry each ;
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
: grow-hash ( hash -- )
- [ dup >alist swap assoc-size 1+ ] keep
+ [ [ >alist ] [ assoc-size 1+ ] bi ] keep
[ reset-hash ] keep
swap (rehash) ; inline
<PRIVATE
-: cr+ t >>cr drop ; inline
+: cr+ ( stream -- ) t >>cr drop ; inline
-: cr- f >>cr drop ; inline
+: cr- ( stream -- ) f >>cr drop ; inline
: >decoder< ( decoder -- stream encoding )
[ stream>> ] [ code>> ] bi ; inline
io.files.private quotations ;
IN: io.files
-ARTICLE: "file-streams" "Reading and writing files"
+ARTICLE: "io.files" "Reading and writing files"
"File streams:"
{ $subsection <file-reader> }
{ $subsection <file-writer> }
{ $subsection with-file-writer }
{ $subsection with-file-appender } ;
-ARTICLE: "pathnames" "Pathname manipulation"
-"Pathname manipulation:"
-{ $subsection parent-directory }
-{ $subsection file-name }
-{ $subsection last-path-separator }
-{ $subsection append-path }
-"Pathnames relative to Factor's temporary files directory:"
-{ $subsection temp-directory }
-{ $subsection temp-file }
-"Pathname presentations:"
-{ $subsection pathname }
-{ $subsection <pathname> } ;
-
-ARTICLE: "symbolic-links" "Symbolic links"
-"Reading and creating links:"
-{ $subsection read-link }
-{ $subsection make-link }
-"Copying links:"
-{ $subsection copy-link }
-"Not all operating systems support symbolic links."
-{ $see-also link-info } ;
-
-ARTICLE: "current-directory" "Current working directory"
-"File system I/O operations use the value of a variable to resolve relative pathnames:"
-{ $subsection current-directory }
-"This variable can be changed with a pair of words:"
-{ $subsection set-current-directory }
-{ $subsection with-directory }
-"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
-{ $subsection (normalize-path) }
-"The second is to change the working directory of the current process:"
-{ $subsection cd }
-{ $subsection cwd } ;
-
-ARTICLE: "directories" "Directories"
-"Home directory:"
-{ $subsection home }
-"Directory listing:"
-{ $subsection directory-entries }
-{ $subsection directory-files }
-{ $subsection with-directory-files }
-"Creating directories:"
-{ $subsection make-directory }
-{ $subsection make-directories }
-{ $subsection "current-directory" } ;
-
-ARTICLE: "file-types" "File Types"
-"Platform-independent types:"
-{ $subsection +regular-file+ }
-{ $subsection +directory+ }
-"Platform-specific types:"
-{ $subsection +character-device+ }
-{ $subsection +block-device+ }
-{ $subsection +fifo+ }
-{ $subsection +symbolic-link+ }
-{ $subsection +socket+ }
-{ $subsection +unknown+ } ;
-
-ARTICLE: "fs-meta" "File metadata"
-"Querying file-system metadata:"
-{ $subsection file-info }
-{ $subsection link-info }
-{ $subsection exists? }
-{ $subsection directory? }
-
-"File types:"
-{ $subsection "file-types" } ;
-
-ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
-"Operations for deleting and copying files come in two forms:"
-{ $list
- { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." }
- { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." }
-}
-"The operations for moving and copying files come in three flavors:"
-{ $list
- { "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." }
- { "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." }
- { "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." }
-}
-"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file."
-$nl
-"Deleting files:"
-{ $subsection delete-file }
-{ $subsection delete-directory }
-{ $subsection delete-tree }
-"Moving files:"
-{ $subsection move-file }
-{ $subsection move-file-into }
-{ $subsection move-files-into }
-"Copying files:"
-{ $subsection copy-file }
-{ $subsection copy-file-into }
-{ $subsection copy-files-into }
-"Copying directory trees recursively:"
-{ $subsection copy-tree }
-{ $subsection copy-tree-into }
-{ $subsection copy-trees-into }
-"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ;
-
-ARTICLE: "io.files" "Basic file operations"
-"The " { $vocab-link "io.files" } " vocabulary provides basic support for working with files."
-{ $subsection "pathnames" }
-{ $subsection "file-streams" }
-{ $subsection "fs-meta" }
-{ $subsection "directories" }
-{ $subsection "delete-move-copy" }
-{ $subsection "symbolic-links" } ;
-
ABOUT: "io.files"
-HELP: path-separator?
-{ $values { "ch" "a code point" } { "?" "a boolean" } }
-{ $description "Tests if the code point is a platform-specific path separator." }
-{ $examples
- "On Unix:"
- { $example "USING: io.files prettyprint ;" "CHAR: / path-separator? ." "t" }
-} ;
-
-HELP: parent-directory
-{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
-{ $description "Strips the last component off a pathname." }
-{ $examples { $example "USING: io io.files ;" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
-
-HELP: file-name
-{ $values { "path" "a pathname string" } { "string" string } }
-{ $description "Outputs the last component of a pathname string." }
-{ $examples
- { $example "USING: io.files prettyprint ;" "\"/usr/bin/gcc\" file-name ." "\"gcc\"" }
- { $example "USING: io.files prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
-} ;
-
-! need a $class-description file-info
-
-HELP: file-info
-{ $values { "path" "a pathname string" } { "info" file-info } }
-{ $description "Queries the file system for metadata. If " { $snippet "path" } " refers to a symbolic link, it is followed. See the article " { $link "file-types" } " for a list of metadata symbols." }
-{ $errors "Throws an error if the file does not exist." } ;
-
-HELP: link-info
-{ $values { "path" "a pathname string" } { "info" "a file-info tuple" } }
-{ $description "Queries the file system for metadata. If path refers to a symbolic link, information about the symbolic link itself is returned. If the file does not exist, an exception is thrown." } ;
-
-{ file-info link-info } related-words
-
-HELP: +regular-file+
-{ $description "A regular file. This type exists on all platforms. See " { $link "file-streams" } " for words operating on files." } ;
-
-HELP: +directory+
-{ $description "A directory. This type exists on all platforms. See " { $link "directories" } " for words operating on directories." } ;
-
-HELP: +symbolic-link+
-{ $description "A symbolic link file. This type is currently implemented on Unix platforms only. See " { $link "symbolic-links" } " for words operating on symbolic links." } ;
-
-HELP: +character-device+
-{ $description "A Unix character device file. This type exists on Unix platforms only." } ;
-
-HELP: +block-device+
-{ $description "A Unix block device file. This type exists on Unix platforms only." } ;
-
-HELP: +fifo+
-{ $description "A Unix fifo file. This type exists on Unix platforms only." } ;
-
-HELP: +socket+
-{ $description "A Unix socket file. This type exists on Unix platforms only." } ;
-
-HELP: +unknown+
-{ $description "A unknown file type." } ;
-
HELP: <file-reader>
-{
- $values
- { "path" "a pathname string" }
- { "encoding" "an encoding descriptor" }
- { "stream" "an input stream" }
-}
+{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an input stream" } }
{ $description "Outputs an input stream for reading from the specified pathname using the given encoding." }
{ $errors "Throws an error if the file is unreadable." } ;
{ set-file-lines file-lines set-file-contents file-contents } related-words
-HELP: cwd
-{ $values { "path" "a pathname string" } }
-{ $description "Outputs the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
-{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
-
-HELP: cd
-{ $values { "path" "a pathname string" } }
-{ $description "Changes the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
-{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
-
-{ cd cwd current-directory set-current-directory with-directory } related-words
-
-HELP: current-directory
-{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable."
-$nl
-"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ;
-
-HELP: set-current-directory
-{ $values { "path" "a pathname string" } }
-{ $description "Changes the " { $link current-directory } " variable."
-$nl
-"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
-
-HELP: with-directory
-{ $values { "path" "a pathname string" } { "quot" quotation } }
-{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound."
-$nl
-"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
-
-HELP: append-path
-{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
-{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
-
-HELP: prepend-path
-{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
-{ $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ;
-
-{ append-path prepend-path } related-words
-
-HELP: absolute-path?
-{ $values { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Tests if a pathname is absolute. Examples of absolute pathnames are " { $snippet "/foo/bar" } " on Unix and " { $snippet "c:\\foo\\bar" } " on Windows." } ;
-
-HELP: windows-absolute-path?
-{ $values { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Tests if a pathname is absolute on Windows. Examples of absolute pathnames on Windows are " { $snippet "c:\\foo\\bar" } " and " { $snippet "\\\\?\\c:\\foo\\bar" } " for absolute Unicode pathnames." } ;
-
-HELP: root-directory?
-{ $values { "path" "a pathname string" } { "?" "a boolean" } }
-{ $description "Tests if a pathname is a root directory. Examples of root directory pathnames are " { $snippet "/" } " on Unix and " { $snippet "c:\\" } " on Windows." } ;
-
-{ absolute-path? windows-absolute-path? root-directory? } related-words
-
HELP: exists?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
-
-HELP: directory?
-{ $values { "file-info" file-info } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "file-info" } " is a directory." } ;
-
-HELP: (directory-entries)
-{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }
-{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
-{ $notes "This is a low-level word, and user code should call one of the related words instead." } ;
-
-HELP: directory-entries
-{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $link directory-entry } " objects" } }
-{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
-
-HELP: directory-files
-{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } }
-{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ;
-
-HELP: with-directory-files
-{ $values { "path" "a pathname string" } { "quot" quotation } }
-{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
-
-HELP: file-systems
-{ $values { "array" array } }
-{ $description "Returns an array of " { $link file-system-info } " objects returned by iterating the mount points and calling " { $link file-system-info } " on each." } ;
-
-HELP: file-system-info
-{ $values
-{ "path" "a pathname string" }
-{ "file-system-info" file-system-info } }
-{ $description "Returns a platform-specific object describing the file-system that contains the path. The cross-platform slot is " { $slot "free-space" } "." } ;
-
-HELP: resource-path
-{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
-{ $description "Resolve a path relative to the Factor source code location." } ;
-
-HELP: pathname
-{ $class-description "Class of path name objects. Path name objects can be created by calling " { $link <pathname> } "." } ;
-
-HELP: normalize-path
-{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
-{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
-
-HELP: <pathname> ( str -- pathname )
-{ $values { "str" "a pathname string" } { "pathname" pathname } }
-{ $description "Creates a new " { $link pathname } "." } ;
-
-HELP: make-link
-{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
-{ $description "Creates a symbolic link." } ;
-
-HELP: read-link
-{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
-{ $description "Reads the symbolic link and returns its target path." } ;
-
-HELP: copy-link
-{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
-{ $description "Copies a symbolic link without following the link." } ;
-
-{ make-link read-link copy-link } related-words
-
-HELP: home
-{ $values { "dir" string } }
-{ $description "Outputs the user's home directory." } ;
-
-HELP: delete-file
-{ $values { "path" "a pathname string" } }
-{ $description "Deletes a file." }
-{ $errors "Throws an error if the file could not be deleted." } ;
-
-HELP: make-directory
-{ $values { "path" "a pathname string" } }
-{ $description "Creates a directory." }
-{ $errors "Throws an error if the directory could not be created." } ;
-
-HELP: make-directories
-{ $values { "path" "a pathname string" } }
-{ $description "Creates a directory and any parent directories which do not yet exist." }
-{ $errors "Throws an error if the directories could not be created." } ;
-
-HELP: delete-directory
-{ $values { "path" "a pathname string" } }
-{ $description "Deletes a directory. The directory must be empty." }
-{ $errors "Throws an error if the directory could not be deleted." } ;
-
-HELP: touch-file
-{ $values { "path" "a pathname string" } }
-{ $description "Updates the modification time of a file or directory. If the file does not exist, creates a new, empty file." }
-{ $errors "Throws an error if the file could not be touched." } ;
-
-HELP: delete-tree
-{ $values { "path" "a pathname string" } }
-{ $description "Deletes a file or directory, recursing into subdirectories." }
-{ $errors "Throws an error if the deletion fails." }
-{ $warning "Misuse of this word can lead to catastrophic data loss." } ;
-
-HELP: move-file
-{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
-{ $description "Moves or renames a file." }
-{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
-
-HELP: move-file-into
-{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
-{ $description "Moves a file to another directory without renaming it." }
-{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
-
-HELP: move-files-into
-{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
-{ $description "Moves a set of files to another directory." }
-{ $errors "Throws an error if the file does not exist or if the move operation fails." } ;
-
-HELP: copy-file
-{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
-{ $description "Copies a file." }
-{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." }
-{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
-
-HELP: copy-file-into
-{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
-{ $description "Copies a file to another directory." }
-{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
-
-HELP: copy-files-into
-{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
-{ $description "Copies a set of files to another directory." }
-{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ;
-
-HELP: copy-tree
-{ $values { "from" "a pathname string" } { "to" "a pathname string" } }
-{ $description "Copies a directory tree recursively." }
-{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." }
-{ $errors "Throws an error if the copy operation fails." } ;
-
-HELP: copy-tree-into
-{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } }
-{ $description "Copies a directory tree to another directory, recursively." }
-{ $errors "Throws an error if the copy operation fails." } ;
-
-HELP: copy-trees-into
-{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } }
-{ $description "Copies a set of directory trees to another directory, recursively." }
-{ $errors "Throws an error if the copy operation fails." } ;
-
-
+USING: tools.test io.files io.files.private io.files.temp
+io.directories io.encodings.8-bit arrays make system
+io.encodings.binary io
+threads kernel continuations io.encodings.ascii sequences
+strings accessors io.encodings.utf8 math destructors namespaces
+;
IN: io.files.tests
-USING: tools.test io.files io.files.private io threads kernel
-continuations io.encodings.ascii sequences
-strings accessors io.encodings.utf8 math destructors
-namespaces ;
\ exists? must-infer
\ (exists?) must-infer
-\ file-info must-infer
-\ link-info must-infer
-[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
-[ ] [ "blahblah" temp-file make-directory ] unit-test
-[ t ] [ "blahblah" temp-file file-info directory? ] unit-test
-
-[ t ] [
- [ temp-directory "loldir" append-path delete-directory ] ignore-errors
- temp-directory [
- "loldir" make-directory
- ] with-directory
- temp-directory "loldir" append-path exists?
-] unit-test
-
-[ ] [
- [ temp-directory "loldir" append-path delete-directory ] ignore-errors
- temp-directory [
- "loldir" make-directory
- "loldir" delete-directory
- ] with-directory
-] unit-test
-
-[ "file1 contents" ] [
- [ temp-directory "loldir" append-path delete-directory ] ignore-errors
- temp-directory [
- "file1 contents" "file1" utf8 set-file-contents
- "file1" "file2" copy-file
- "file2" utf8 file-contents
- ] with-directory
- "file1" temp-file delete-file
- "file2" temp-file delete-file
-] unit-test
-
-[ "file3 contents" ] [
- temp-directory [
- "file3 contents" "file3" utf8 set-file-contents
- "file3" "file4" move-file
- "file4" utf8 file-contents
- ] with-directory
- "file4" temp-file delete-file
-] unit-test
-
-[ "file5" temp-file delete-file ] ignore-errors
-
-[ ] [
- temp-directory [
- "file5" touch-file
- "file5" delete-file
- ] with-directory
-] unit-test
-
-[ "file6" temp-file delete-file ] ignore-errors
-
-[ ] [
- temp-directory [
- "file6" touch-file
- "file6" link-info drop
- ] with-directory
-] unit-test
-
-[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
-[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
-[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
-[ "" ] [ "" file-name ] unit-test
+[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
-[ "freetype6.dll" ] [ "resource:freetype6.dll" file-name ] unit-test
-[ "freetype6.dll" ] [ "resource:/freetype6.dll" file-name ] unit-test
+[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
-[ ] [
- { "Hello world." }
- "test-foo.txt" temp-file ascii set-file-lines
+[
+ "This is a line.\rThis is another line.\r"
+] [
+ "resource:core/io/test/mac-os-eol.txt" latin1 <file-reader>
+ [ 500 read ] with-input-stream
] unit-test
-[ ] [
- "test-foo.txt" temp-file ascii [
- "Hello appender." print
- ] with-file-appender
+[
+ 255
+] [
+ "resource:core/io/test/binary.txt" latin1 <file-reader>
+ [ read1 ] with-input-stream >fixnum
] unit-test
[ ] [
- "test-bar.txt" temp-file ascii [
- "Hello appender." print
- ] with-file-appender
+ "It seems Jobs has lost his grasp on reality again.\n"
+ "separator-test.txt" temp-file latin1 set-file-contents
] unit-test
-[ "Hello world.\nHello appender.\n" ] [
- "test-foo.txt" temp-file ascii file-contents
-] unit-test
-
-[ "Hello appender.\n" ] [
- "test-bar.txt" temp-file ascii file-contents
+[
+ {
+ { "It seems " CHAR: J }
+ { "obs has lost h" CHAR: i }
+ { "s grasp on reality again.\n" f }
+ }
+] [
+ [
+ "separator-test.txt" temp-file
+ latin1 <file-reader> [
+ "J" read-until 2array ,
+ "i" read-until 2array ,
+ "X" read-until 2array ,
+ ] with-input-stream
+ ] { } make
] unit-test
-[ ] [ "test-foo.txt" temp-file delete-file ] unit-test
-
-[ ] [ "test-bar.txt" temp-file delete-file ] unit-test
-
-[ f ] [ "test-foo.txt" temp-file exists? ] unit-test
-
-[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
-
-[ "test-blah" temp-file delete-tree ] ignore-errors
-
-[ ] [ "test-blah" temp-file make-directory ] unit-test
-
[ ] [
- "test-blah/fooz" temp-file ascii <file-writer> dispose
+ image binary [
+ 10 [ 65536 read drop ] times
+ ] with-file-reader
] unit-test
-[ t ] [
- "test-blah/fooz" temp-file exists?
+! Test EOF behavior
+[ 10 ] [
+ image binary [
+ 0 read drop
+ 10 read length
+ ] with-file-reader
] unit-test
-[ ] [ "test-blah/fooz" temp-file delete-file ] unit-test
-
-[ ] [ "test-blah" temp-file delete-directory ] unit-test
-
-[ f ] [ "test-blah" temp-file exists? ] unit-test
-
USE: debugger.threads
[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
-
-[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test
-
-[ ] [
- { "Hi" }
- "delete-tree-test/a/b/c/d" temp-file ascii set-file-lines
-] unit-test
-
-[ ] [
- "delete-tree-test" temp-file delete-tree
-] unit-test
-
-[ { "kernel" } ] [
- "core" resource-path [
- "." directory-files [ "kernel" = ] filter
- ] with-directory
-] unit-test
-
-[ { "kernel" } ] [
- "resource:core" [
- "." directory-files [ "kernel" = ] filter
- ] with-directory
-] unit-test
-
-[ { "kernel" } ] [
- "resource:core" [
- [ "kernel" = ] filter
- ] with-directory-files
-] unit-test
-
-[ ] [
- "copy-tree-test/a/b/c" temp-file make-directories
-] unit-test
-
-[ ] [
- "Foobar"
- "copy-tree-test/a/b/c/d" temp-file
- ascii set-file-contents
-] unit-test
-
-[ ] [
- "copy-tree-test" temp-file
- "copy-destination" temp-file copy-tree
-] unit-test
-
-[ "Foobar" ] [
- "copy-destination/a/b/c/d" temp-file ascii file-contents
-] unit-test
-
-[ ] [
- "copy-destination" temp-file delete-tree
-] unit-test
-
-[ ] [
- "copy-tree-test" temp-file
- "copy-destination" temp-file copy-tree-into
-] unit-test
-
-[ "Foobar" ] [
- "copy-destination/copy-tree-test/a/b/c/d" temp-file ascii file-contents
-] unit-test
-
-[ ] [
- "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into
-] unit-test
-
-[ "Foobar" ] [
- "d" temp-file ascii file-contents
-] unit-test
-
-[ ] [ "d" temp-file delete-file ] unit-test
-
-[ ] [ "copy-destination" temp-file delete-tree ] unit-test
-
-[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
-
-[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
-
-[ t ] [
- temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
- temp-directory "test41" append-path utf8 file-contents "hi41" =
-] unit-test
-
-[ t ] [
- temp-directory [ "test41" file-info size>> ] with-directory 4 =
-] unit-test
-
-[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
-
-[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
-
-[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
-[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
-[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
-[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
-[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
-[ "/lib/" ] [ "/usr" "../lib/" append-path ] unit-test
-
-[ "" ] [ "" "." append-path ] unit-test
-[ "" ".." append-path ] must-fail
-
-[ "/" ] [ "/" "./." append-path ] unit-test
-[ "/" ] [ "/" "././" append-path ] unit-test
-[ "/a/b/lib" ] [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test
-[ "/a/b/lib/" ] [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test
-
-[ "" "../lib/" append-path ] must-fail
-[ "lib" ] [ "" "lib" append-path ] unit-test
-[ "lib" ] [ "" "./lib" append-path ] unit-test
-
-[ "foo/bar/." parent-directory ] must-fail
-[ "foo/bar/./" parent-directory ] must-fail
-[ "foo/bar/baz/.." parent-directory ] must-fail
-[ "foo/bar/baz/../" parent-directory ] must-fail
-
-[ "." parent-directory ] must-fail
-[ "./" parent-directory ] must-fail
-[ ".." parent-directory ] must-fail
-[ "../" parent-directory ] must-fail
-[ "../../" parent-directory ] must-fail
-[ "foo/.." parent-directory ] must-fail
-[ "foo/../" parent-directory ] must-fail
-[ "" parent-directory ] must-fail
-[ "." ] [ "boot.x86.64.image" parent-directory ] unit-test
-
-[ "bar/foo" ] [ "bar/baz" "..///foo" append-path ] unit-test
-[ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test
-[ "bar/foo" ] [ "bar/baz" "./..//foo" append-path ] unit-test
-[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
-
-[ t ] [ "resource:core" absolute-path? ] unit-test
-[ f ] [ "" absolute-path? ] unit-test
-
-[ "touch-twice-test" temp-file delete-file ] ignore-errors
-[ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test
-
-! aum's bug
-[
- "." current-directory set
- ".." "resource-path" set
- [ "../core/bootstrap/stage2.factor" ]
- [ "resource:core/bootstrap/stage2.factor" (normalize-path) ]
- unit-test
-] with-scope
-
-[ t ] [ "/" file-system-info file-system-info? ] unit-test
-[ t ] [ file-systems [ file-system-info? ] all? ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.backend io.files.private io hashtables kernel
-kernel.private math memory namespaces sequences strings assocs
-arrays definitions system combinators splitting sbufs
-continuations destructors io.encodings io.encodings.binary init
-accessors math.order ;
+USING: kernel kernel.private sequences init namespaces system io
+io.backend io.pathnames io.encodings io.files.private ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
: with-file-appender ( path encoding quot -- )
[ <file-appender> ] dip with-output-stream ; inline
-! Pathnames
-: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
-
-: path-separator ( -- string ) os windows? "\\" "/" ? ;
-
-: trim-right-separators ( str -- newstr )
- [ path-separator? ] trim-right ;
-
-: trim-left-separators ( str -- newstr )
- [ path-separator? ] trim-left ;
-
-: last-path-separator ( path -- n ? )
- [ length 1- ] keep [ path-separator? ] find-last-from ;
-
-HOOK: root-directory? io-backend ( path -- ? )
-
-M: object root-directory? ( path -- ? )
- [ f ] [ [ path-separator? ] all? ] if-empty ;
-
-ERROR: no-parent-directory path ;
-
-: parent-directory ( path -- parent )
- dup root-directory? [
- trim-right-separators
- dup last-path-separator [
- 1+ cut
- ] [
- drop "." swap
- ] if
- { "" "." ".." } member? [
- no-parent-directory
- ] when
- ] unless ;
-
-<PRIVATE
-
-: head-path-separator? ( path1 ? -- ?' )
- [
- [ t ] [ first path-separator? ] if-empty
- ] [
- drop f
- ] if ;
-
-: head.? ( path -- ? ) "." ?head head-path-separator? ;
-
-: head..? ( path -- ? ) ".." ?head head-path-separator? ;
-
-: append-path-empty ( path1 path2 -- path' )
- {
- { [ dup head.? ] [
- rest trim-left-separators append-path-empty
- ] }
- { [ dup head..? ] [ drop no-parent-directory ] }
- [ nip ]
- } cond ;
-
-PRIVATE>
-
-: windows-absolute-path? ( path -- path ? )
- {
- { [ dup "\\\\?\\" head? ] [ t ] }
- { [ dup length 2 < ] [ f ] }
- { [ dup second CHAR: : = ] [ t ] }
- [ f ]
- } cond ;
-
-: absolute-path? ( path -- ? )
- {
- { [ dup empty? ] [ f ] }
- { [ dup "resource:" head? ] [ t ] }
- { [ os windows? ] [ windows-absolute-path? ] }
- { [ dup first path-separator? ] [ t ] }
- [ f ]
- } cond nip ;
-
-: append-path ( str1 str2 -- str )
- {
- { [ over empty? ] [ append-path-empty ] }
- { [ dup empty? ] [ drop ] }
- { [ over trim-right-separators "." = ] [ nip ] }
- { [ dup absolute-path? ] [ nip ] }
- { [ dup head.? ] [ rest trim-left-separators append-path ] }
- { [ dup head..? ] [
- 2 tail trim-left-separators
- [ parent-directory ] dip append-path
- ] }
- { [ over absolute-path? over first path-separator? and ] [
- [ 2 head ] dip append
- ] }
- [
- [ trim-right-separators "/" ] dip
- trim-left-separators 3append
- ]
- } cond ;
-
-: prepend-path ( str1 str2 -- str )
- swap append-path ; inline
-
-: file-name ( path -- string )
- dup root-directory? [
- trim-right-separators
- dup last-path-separator [ 1+ tail ] [
- drop "resource:" ?head [ file-name ] when
- ] if
- ] unless ;
-
-: file-extension ( filename -- extension )
- "." split1-last nip ;
-
-! File info
-TUPLE: file-info type size permissions created modified
-accessed ;
-
-HOOK: file-info io-backend ( path -- info )
-
-! Symlinks
-HOOK: link-info io-backend ( path -- info )
-
-HOOK: make-link io-backend ( target symlink -- )
-
-HOOK: read-link io-backend ( symlink -- path )
-
-: copy-link ( target symlink -- )
- [ read-link ] dip make-link ;
-
-SYMBOL: +regular-file+
-SYMBOL: +directory+
-SYMBOL: +symbolic-link+
-SYMBOL: +character-device+
-SYMBOL: +block-device+
-SYMBOL: +fifo+
-SYMBOL: +socket+
-SYMBOL: +whiteout+
-SYMBOL: +unknown+
-
-! File metadata
: exists? ( path -- ? ) normalize-path (exists?) ;
-: directory? ( file-info -- ? ) type>> +directory+ = ;
-
-! File-system
-
-HOOK: file-systems os ( -- array )
-
-TUPLE: file-system-info device-name mount-point type
-available-space free-space used-space total-space ;
-
-HOOK: file-system-info os ( path -- file-system-info )
-
+! Current directory
<PRIVATE
HOOK: cd io-backend ( path -- )
PRIVATE>
-SYMBOL: current-directory
-
[
cwd current-directory set-global
13 getenv cwd prepend-path \ image set-global
14 getenv cwd prepend-path \ vm set-global
image parent-directory "resource-path" set-global
-] "io.files" add-init-hook
-
-: resource-path ( path -- newpath )
- "resource-path" get prepend-path ;
-
-: (normalize-path) ( path -- path' )
- "resource:" ?head [
- trim-left-separators resource-path
- (normalize-path)
- ] [
- current-directory get prepend-path
- ] if ;
-
-M: object normalize-path ( path -- path' )
- (normalize-path) ;
-
-: set-current-directory ( path -- )
- (normalize-path) current-directory set ;
-
-: with-directory ( path quot -- )
- [ (normalize-path) current-directory ] dip with-variable ; inline
-
-! Creating directories
-HOOK: make-directory io-backend ( path -- )
-
-: make-directories ( path -- )
- normalize-path trim-right-separators {
- { [ dup "." = ] [ ] }
- { [ dup root-directory? ] [ ] }
- { [ dup empty? ] [ ] }
- { [ dup exists? ] [ ] }
- [
- dup parent-directory make-directories
- dup make-directory
- ]
- } cond drop ;
-
-TUPLE: directory-entry name type ;
-
-HOOK: >directory-entry os ( byte-array -- directory-entry )
-
-HOOK: (directory-entries) os ( path -- seq )
-
-: directory-entries ( path -- seq )
- normalize-path
- (directory-entries)
- [ name>> { "." ".." } member? not ] filter ;
-
-: directory-files ( path -- seq )
- directory-entries [ name>> ] map ;
-
-: with-directory-files ( path quot -- )
- [ "" directory-files ] prepose with-directory ; inline
-
-! Touching files
-HOOK: touch-file io-backend ( path -- )
-
-! Deleting files
-HOOK: delete-file io-backend ( path -- )
-
-HOOK: delete-directory io-backend ( path -- )
-
-: delete-tree ( path -- )
- dup link-info type>> +directory+ = [
- [ [ [ delete-tree ] each ] with-directory-files ]
- [ delete-directory ]
- bi
- ] [ delete-file ] if ;
-
-: to-directory ( from to -- from to' )
- over file-name append-path ;
-
-! Moving and renaming files
-HOOK: move-file io-backend ( from to -- )
-
-: move-file-into ( from to -- )
- to-directory move-file ;
-
-: move-files-into ( files to -- )
- [ move-file-into ] curry each ;
-
-! Copying files
-HOOK: copy-file io-backend ( from to -- )
-
-M: object copy-file
- dup parent-directory make-directories
- binary <file-writer> [
- swap binary <file-reader> [
- swap stream-copy
- ] with-disposal
- ] with-disposal ;
-
-: copy-file-into ( from to -- )
- to-directory copy-file ;
-
-: copy-files-into ( files to -- )
- [ copy-file-into ] curry each ;
-
-DEFER: copy-tree-into
-
-: copy-tree ( from to -- )
- normalize-path
- over link-info type>>
- {
- { +symbolic-link+ [ copy-link ] }
- { +directory+ [
- swap [
- [ swap copy-tree-into ] with each
- ] with-directory-files
- ] }
- [ drop copy-file ]
- } case ;
-
-: copy-tree-into ( from to -- )
- to-directory copy-tree ;
-
-: copy-trees-into ( files to -- )
- [ copy-tree-into ] curry each ;
-
-! Special paths
-
-: temp-directory ( -- path )
- "temp" resource-path dup make-directories ;
-
-: temp-file ( name -- path )
- temp-directory prepend-path ;
-
-! Pathname presentations
-TUPLE: pathname string ;
-
-C: <pathname> pathname
-
-M: pathname <=> [ string>> ] compare ;
-
-! Home directory
-HOOK: home io-backend ( -- dir )
-
-M: object home "" resource-path ;
+] "io.files" add-init-hook
\ No newline at end of file
"foo" "io.tests" lookup
] unit-test
-[
- "This is a line.\rThis is another line.\r"
-] [
- "resource:core/io/test/mac-os-eol.txt" latin1 <file-reader>
- [ 500 read ] with-input-stream
-] unit-test
-
-[
- 255
-] [
- "resource:core/io/test/binary.txt" latin1 <file-reader>
- [ read1 ] with-input-stream >fixnum
-] unit-test
-
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
-
-[ ] [
- "It seems Jobs has lost his grasp on reality again.\n"
- "separator-test.txt" temp-file latin1 set-file-contents
-] unit-test
-
-[
- {
- { "It seems " CHAR: J }
- { "obs has lost h" CHAR: i }
- { "s grasp on reality again.\n" f }
- }
-] [
- [
- "separator-test.txt" temp-file
- latin1 <file-reader> [
- "J" read-until 2array ,
- "i" read-until 2array ,
- "X" read-until 2array ,
- ] with-input-stream
- ] { } make
-] unit-test
-
-[ ] [
- image binary [
- 10 [ 65536 read drop ] times
- ] with-file-reader
-] unit-test
-
-! Test EOF behavior
-[ 10 ] [
- image binary [
- 0 read drop
- 10 read length
- ] with-file-reader
-] unit-test
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax io.backend io.files strings ;
+IN: io.pathnames
+
+HELP: path-separator?
+{ $values { "ch" "a code point" } { "?" "a boolean" } }
+{ $description "Tests if the code point is a platform-specific path separator." }
+{ $examples
+ "On Unix:"
+ { $example "USING: io.pathnames prettyprint ;" "CHAR: / path-separator? ." "t" }
+} ;
+
+HELP: parent-directory
+{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
+{ $description "Strips the last component off a pathname." }
+{ $examples { $example "USING: io io.pathnames ;" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
+
+HELP: file-name
+{ $values { "path" "a pathname string" } { "string" string } }
+{ $description "Outputs the last component of a pathname string." }
+{ $examples
+ { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-name ." "\"gcc\"" }
+ { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
+} ;
+
+HELP: append-path
+{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
+{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
+
+HELP: prepend-path
+{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
+{ $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ;
+
+{ append-path prepend-path } related-words
+
+HELP: absolute-path?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is absolute. Examples of absolute pathnames are " { $snippet "/foo/bar" } " on Unix and " { $snippet "c:\\foo\\bar" } " on Windows." } ;
+
+HELP: windows-absolute-path?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is absolute on Windows. Examples of absolute pathnames on Windows are " { $snippet "c:\\foo\\bar" } " and " { $snippet "\\\\?\\c:\\foo\\bar" } " for absolute Unicode pathnames." } ;
+
+HELP: root-directory?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is a root directory. Examples of root directory pathnames are " { $snippet "/" } " on Unix and " { $snippet "c:\\" } " on Windows." } ;
+
+{ absolute-path? windows-absolute-path? root-directory? } related-words
+
+HELP: resource-path
+{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
+{ $description "Resolve a path relative to the Factor source code location." } ;
+
+HELP: pathname
+{ $class-description "Class of path name objects. Path name objects can be created by calling " { $link <pathname> } "." } ;
+
+HELP: normalize-path
+{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
+{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
+
+HELP: <pathname>
+{ $values { "string" "a pathname string" } { "pathname" pathname } }
+{ $description "Creates a new " { $link pathname } "." } ;
+
+HELP: home
+{ $values { "dir" string } }
+{ $description "Outputs the user's home directory." } ;
+
+ARTICLE: "io.pathnames" "Pathname manipulation"
+"Pathname manipulation:"
+{ $subsection parent-directory }
+{ $subsection file-name }
+{ $subsection last-path-separator }
+{ $subsection append-path }
+"Pathname presentations:"
+{ $subsection pathname }
+{ $subsection <pathname> } ;
+
+ABOUT: "io.pathnames"
--- /dev/null
+USING: io.pathnames io.files.temp io.directories
+continuations math io.files.private kernel
+namespaces tools.test ;
+IN: io.pathnames.tests
+
+[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
+[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
+[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
+[ "" ] [ "" file-name ] unit-test
+
+[ "freetype6.dll" ] [ "resource:freetype6.dll" file-name ] unit-test
+[ "freetype6.dll" ] [ "resource:/freetype6.dll" file-name ] unit-test
+
+[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
+[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
+[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
+[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
+[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
+[ "/lib/" ] [ "/usr" "../lib/" append-path ] unit-test
+
+[ "" ] [ "" "." append-path ] unit-test
+[ "" ".." append-path ] must-fail
+
+[ "/" ] [ "/" "./." append-path ] unit-test
+[ "/" ] [ "/" "././" append-path ] unit-test
+[ "/a/b/lib" ] [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test
+[ "/a/b/lib/" ] [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test
+
+[ "" "../lib/" append-path ] must-fail
+[ "lib" ] [ "" "lib" append-path ] unit-test
+[ "lib" ] [ "" "./lib" append-path ] unit-test
+
+[ "foo/bar/." parent-directory ] must-fail
+[ "foo/bar/./" parent-directory ] must-fail
+[ "foo/bar/baz/.." parent-directory ] must-fail
+[ "foo/bar/baz/../" parent-directory ] must-fail
+
+[ "." parent-directory ] must-fail
+[ "./" parent-directory ] must-fail
+[ ".." parent-directory ] must-fail
+[ "../" parent-directory ] must-fail
+[ "../../" parent-directory ] must-fail
+[ "foo/.." parent-directory ] must-fail
+[ "foo/../" parent-directory ] must-fail
+[ "" parent-directory ] must-fail
+[ "." ] [ "boot.x86.64.image" parent-directory ] unit-test
+
+[ "bar/foo" ] [ "bar/baz" "..///foo" append-path ] unit-test
+[ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test
+[ "bar/foo" ] [ "bar/baz" "./..//foo" append-path ] unit-test
+[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
+
+[ t ] [ "resource:core" absolute-path? ] unit-test
+[ f ] [ "" absolute-path? ] unit-test
+
+[ "touch-twice-test" temp-file delete-file ] ignore-errors
+[ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test
+
+! aum's bug
+[
+ "." current-directory set
+ ".." "resource-path" set
+ [ "../core/bootstrap/stage2.factor" ]
+ [ "resource:core/bootstrap/stage2.factor" (normalize-path) ]
+ unit-test
+] with-scope
+
+[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators io.backend kernel math math.order
+namespaces sequences splitting strings system ;
+IN: io.pathnames
+
+SYMBOL: current-directory
+
+: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
+
+: path-separator ( -- string ) os windows? "\\" "/" ? ;
+
+: trim-right-separators ( str -- newstr )
+ [ path-separator? ] trim-right ;
+
+: trim-left-separators ( str -- newstr )
+ [ path-separator? ] trim-left ;
+
+: last-path-separator ( path -- n ? )
+ [ length 1- ] keep [ path-separator? ] find-last-from ;
+
+HOOK: root-directory? io-backend ( path -- ? )
+
+M: object root-directory? ( path -- ? )
+ [ f ] [ [ path-separator? ] all? ] if-empty ;
+
+ERROR: no-parent-directory path ;
+
+: parent-directory ( path -- parent )
+ dup root-directory? [
+ trim-right-separators
+ dup last-path-separator [
+ 1+ cut
+ ] [
+ drop "." swap
+ ] if
+ { "" "." ".." } member? [
+ no-parent-directory
+ ] when
+ ] unless ;
+
+<PRIVATE
+
+: head-path-separator? ( path1 ? -- ?' )
+ [
+ [ t ] [ first path-separator? ] if-empty
+ ] [
+ drop f
+ ] if ;
+
+: head.? ( path -- ? ) "." ?head head-path-separator? ;
+
+: head..? ( path -- ? ) ".." ?head head-path-separator? ;
+
+: append-path-empty ( path1 path2 -- path' )
+ {
+ { [ dup head.? ] [
+ rest trim-left-separators append-path-empty
+ ] }
+ { [ dup head..? ] [ drop no-parent-directory ] }
+ [ nip ]
+ } cond ;
+
+PRIVATE>
+
+: windows-absolute-path? ( path -- path ? )
+ {
+ { [ dup "\\\\?\\" head? ] [ t ] }
+ { [ dup length 2 < ] [ f ] }
+ { [ dup second CHAR: : = ] [ t ] }
+ [ f ]
+ } cond ;
+
+: absolute-path? ( path -- ? )
+ {
+ { [ dup empty? ] [ f ] }
+ { [ dup "resource:" head? ] [ t ] }
+ { [ os windows? ] [ windows-absolute-path? ] }
+ { [ dup first path-separator? ] [ t ] }
+ [ f ]
+ } cond nip ;
+
+: append-path ( str1 str2 -- str )
+ {
+ { [ over empty? ] [ append-path-empty ] }
+ { [ dup empty? ] [ drop ] }
+ { [ over trim-right-separators "." = ] [ nip ] }
+ { [ dup absolute-path? ] [ nip ] }
+ { [ dup head.? ] [ rest trim-left-separators append-path ] }
+ { [ dup head..? ] [
+ 2 tail trim-left-separators
+ [ parent-directory ] dip append-path
+ ] }
+ { [ over absolute-path? over first path-separator? and ] [
+ [ 2 head ] dip append
+ ] }
+ [
+ [ trim-right-separators "/" ] dip
+ trim-left-separators 3append
+ ]
+ } cond ;
+
+: prepend-path ( str1 str2 -- str )
+ swap append-path ; inline
+
+: file-name ( path -- string )
+ dup root-directory? [
+ trim-right-separators
+ dup last-path-separator [ 1+ tail ] [
+ drop "resource:" ?head [ file-name ] when
+ ] if
+ ] unless ;
+
+: file-extension ( filename -- extension )
+ "." split1-last nip ;
+
+: resource-path ( path -- newpath )
+ "resource-path" get prepend-path ;
+
+GENERIC: (normalize-path) ( path -- path' )
+
+M: string (normalize-path)
+ "resource:" ?head [
+ trim-left-separators resource-path
+ (normalize-path)
+ ] [
+ current-directory get prepend-path
+ ] if ;
+
+M: object normalize-path ( path -- path' )
+ (normalize-path) ;
+
+TUPLE: pathname string ;
+
+C: <pathname> pathname
+
+M: pathname (normalize-path) string>> (normalize-path) ;
+
+M: pathname <=> [ string>> ] compare ;
+
+HOOK: home io-backend ( -- dir )
+
+M: object home "" resource-path ;
\ No newline at end of file
--- /dev/null
+Pathname manipulation
ABOUT: "io.streams.c"
-HELP: <c-reader> ( in -- stream )
-{ $values { "in" "a C FILE* handle" } { "stream" "a new stream" } }
+HELP: <c-reader>
+{ $values { "handle" "a C FILE* handle" } { "stream" "a new stream" } }
{ $description "Creates a stream which reads data by calling C standard library functions." }
{ $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ;
-HELP: <c-writer> ( out -- stream )
-{ $values { "out" "a C FILE* handle" } { "stream" "a new stream" } }
+HELP: <c-writer>
+{ $values { "handle" "a C FILE* handle" } { "stream" "a new stream" } }
{ $description "Creates a stream which writes data by calling C standard library functions." }
{ $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ;
-USING: tools.test io.files io io.streams.c
+USING: tools.test io.files io.files.temp io io.streams.c
io.encodings.ascii strings ;
IN: io.streams.c.tests
: cell-bits ( -- n ) 8 cells ; inline
-: bootstrap-cell \ cell get cell or ; inline
+: bootstrap-cell ( -- n ) \ cell get cell or ; inline
-: bootstrap-cells bootstrap-cell * ; inline
+: bootstrap-cells ( m -- n ) bootstrap-cell * ; inline
-: bootstrap-cell-bits 8 bootstrap-cells ; inline
+: bootstrap-cell-bits ( -- n ) 8 bootstrap-cells ; inline
: first-bignum ( -- n )
cell-bits (first-bignum) ; inline
} ;
HELP: ?1+
+{ $values { "x" { $maybe number } } { "y" number } }
{ $description "If the input is not " { $link f } ", adds one. Otherwise, outputs a " { $snippet "0" } "." } ;
HELP: sq
: recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
-: ?1+ [ 1+ ] [ 0 ] if* ; inline
+: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline
: rem ( x y -- z ) abs tuck mod over + swap mod ; foldable
<PRIVATE
-: iterate-prep 0 -rot ; inline
+: iterate-prep ( n quot -- i n quot ) 0 -rot ; inline
-: if-iterate? [ 2over < ] 2dip if ; inline
+: if-iterate? ( i n true false -- ) [ 2over < ] 2dip if ; inline
: iterate-step ( i n quot -- i n quot )
#! Apply quot to i, keep i and quot, hide n.
swap [ 2dup 2slip ] dip swap ; inline
-: iterate-next [ 1+ ] 2dip ; inline
+: iterate-next ( i n quot -- i' n quot ) [ 1+ ] 2dip ; inline
PRIVATE>
USING: help.markup help.syntax kernel math quotations
-math.private words ;
+math.private words words.symbol ;
IN: math.order
HELP: <=>
USING: help.markup help.syntax kernel sequences words
math strings vectors quotations generic effects classes
vocabs.loader definitions io vocabs source-files
-quotations namespaces compiler.units assocs lexer ;
+quotations namespaces compiler.units assocs lexer
+words.symbol words.alias words.constant vocabs.parser ;
IN: parser
-ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
-"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, we say that the old word has been " { $emphasis "shadowed" } "."
-$nl
-"Here is an example where shadowing occurs:"
-{ $code
- "IN: foe"
- "USING: sequences io ;"
- ""
- ": append"
- " \"foe::append calls sequences:append\" print append ;"
- ""
- "IN: fee"
- ""
- ": append"
- " \"fee::append calls fee:append\" print append ;"
- ""
- "IN: fox"
- "USE: foe"
- ""
- ": append"
- " \"fox::append calls foe:append\" print append ;"
- ""
- "\"1234\" \"5678\" append print"
- ""
- "USE: fox"
- "\"1234\" \"5678\" append print"
-}
-"When placed in a source file and run, the above code produces the following output:"
-{ $code
- "foe:append calls sequences:append"
- "12345678"
- "fee:append calls foe:append"
- "foe:append calls sequences:append"
- "12345678"
-}
-"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
-
-ARTICLE: "vocabulary-search-errors" "Word lookup errors"
-"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."
-$nl
-"If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used."
-$nl
-"If " { $link auto-use? } " mode is on and only one vocabulary has a word with this name, the vocabulary is added to the search path and parsing continues."
-$nl
-"If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file."
-{ $subsection auto-use? } ;
-
-ARTICLE: "vocabulary-search" "Vocabulary search path"
-"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
-$nl
-"For a source file the vocabulary search path starts off with one vocabulary:"
-{ $code "syntax" }
-"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words."
-$nl
-"In the listener, the " { $vocab-link "scratchpad" } " is the default vocabulary for new word definitions. However, when loading source files, there is no default vocabulary. Defining words before declaring a vocabulary with " { $link POSTPONE: IN: } " results in an error."
-$nl
-"At the interactive listener, the default search path contains many more vocabularies. Details on the default search path and parser invocation are found in " { $link "parser" } "."
-$nl
-"Three parsing words deal with the vocabulary search path:"
-{ $subsection POSTPONE: USE: }
-{ $subsection POSTPONE: USING: }
-{ $subsection POSTPONE: IN: }
-"Private words can be defined; note that this is just a convention and they can be called from other vocabularies anyway:"
-{ $subsection POSTPONE: <PRIVATE }
-{ $subsection POSTPONE: PRIVATE> }
-{ $subsection "vocabulary-search-errors" }
-{ $subsection "vocabulary-search-shadow" }
-{ $see-also "words" "qualified" } ;
-
ARTICLE: "reading-ahead" "Reading ahead"
"Parsing words can consume input:"
{ $subsection scan }
USING: arrays math parser tools.test kernel generic words
-io.streams.string namespaces classes effects source-files
-assocs sequences strings io.files definitions continuations
-sorting classes.tuple compiler.units debugger vocabs
-vocabs.loader accessors eval combinators lexer ;
+io.streams.string namespaces classes effects source-files assocs
+sequences strings io.files io.pathnames definitions
+continuations sorting classes.tuple compiler.units debugger
+vocabs vocabs.loader accessors eval combinators lexer ;
IN: parser.tests
\ run-file must-infer
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
[ "CHAR: \\u9999999999999" eval ] must-fail
+
+SYMBOLS: a b c ;
+
+[ a ] [ a ] unit-test
+[ b ] [ b ] unit-test
+[ c ] [ c ] unit-test
+
+DEFER: blah
+
+[ ] [ "IN: symbols.tests GENERIC: blah" eval ] unit-test
+[ ] [ "IN: symbols.tests USE: symbols SYMBOLS: blah ;" eval ] unit-test
+
+[ f ] [ \ blah generic? ] unit-test
+[ t ] [ \ blah symbol? ] unit-test
+
+[ "IN: symbols.tests USE: symbols SINGLETONS: blah blah blah ;" eval ]
+[ error>> error>> def>> \ blah eq? ]
+must-fail-with
+
+IN: qualified.tests.foo
+: x 1 ;
+: y 5 ;
+IN: qualified.tests.bar
+: x 2 ;
+: y 4 ;
+IN: qualified.tests.baz
+: x 3 ;
+
+QUALIFIED: qualified.tests.foo
+QUALIFIED: qualified.tests.bar
+[ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test
+
+QUALIFIED-WITH: qualified.tests.bar p
+[ 2 ] [ p:x ] unit-test
+
+RENAME: x qualified.tests.baz => y
+[ 3 ] [ y ] unit-test
+
+FROM: qualified.tests.baz => x ;
+[ 3 ] [ x ] unit-test
+[ 3 ] [ y ] unit-test
+
+EXCLUDE: qualified.tests.bar => x ;
+[ 3 ] [ x ] unit-test
+[ 4 ] [ y ] unit-test
+
+[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
+[ error>> no-word-error? ] must-fail-with
+
+[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ]
+[ error>> no-word-error? ] must-fail-with
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces
-sequences strings vectors words quotations io
+sequences strings vectors words words.symbol quotations io
combinators sorting splitting math.parser effects continuations
io.files io.streams.string vocabs io.encodings.utf8 source-files
classes hashtables compiler.errors compiler.units accessors sets
-lexer ;
+lexer vocabs.parser ;
IN: parser
: location ( -- loc )
"Note: " write dup print
] when drop ;
-SYMBOL: use
-SYMBOL: in
-
-: (use+) ( vocab -- )
- vocab-words use get push ;
-
-: use+ ( vocab -- )
- load-vocab (use+) ;
-
-: add-use ( seq -- ) [ use+ ] each ;
-
-: set-use ( seq -- )
- [ vocab-words ] V{ } map-as sift use set ;
-
-: check-vocab-string ( name -- name )
- dup string?
- [ "Vocabulary name must be a string" throw ] unless ;
-
-: set-in ( name -- )
- check-vocab-string dup in set create-vocab (use+) ;
-
M: parsing-word stack-effect drop (( parsed -- parsed )) ;
TUPLE: no-current-vocab ;
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
-: word-restarts ( name possibilities -- restarts )
- natural-sort
- [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
- swap "Defer word in current vocabulary" swap 2array
- suffix ;
-
-ERROR: no-word-error name ;
-
-: <no-word-error> ( name possibilities -- error restarts )
- [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
-
SYMBOL: amended-use
SYMBOL: auto-use?
<PRIVATE
-: uncurry dup 2 slot swap 3 slot ; inline
+: uncurry ( curry -- obj quot )
+ dup 2 slot swap 3 slot ; inline
-: uncompose dup 2 slot swap 3 slot ; inline
+: uncompose ( compose -- quot quot2 )
+ dup 2 slot swap 3 slot ; inline
PRIVATE>
{ $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
{ $description "Unsafe variant of " { $link exchange } " that does not perform bounds checks." } ;
+HELP: first-unsafe
+{ $values { "seq" sequence } { "first" "the first element" } }
+{ $contract "Unsafe variant of " { $link first } " that does not perform bounds checks." } ;
+
HELP: first2-unsafe
{ $values { "seq" sequence } { "first" "the first element" } { "second" "the second element" } }
{ $contract "Unsafe variant of " { $link first2 } " that does not perform bounds checks." } ;
{ reverse <reversed> reverse-here } related-words
-HELP: <reversed> ( seq -- reversed )
+HELP: <reversed>
{ $values { "seq" sequence } { "reversed" "a new sequence" } }
{ $description "Creates an instance of the " { $link reversed } " class." }
{ $see-also "virtual-sequences" } ;
HELP: repetition
{ $class-description "A virtual sequence consisting of " { $snippet "elt" } " repeated " { $snippet "len" } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
-HELP: <repetition> ( len elt -- repetition )
+HELP: <repetition>
{ $values { "len" "a non-negative integer" } { "elt" object } { "repetition" repetition } }
{ $description "Creates a new " { $link repetition } "." }
{ $examples
INSTANCE: integer immutable-sequence
-: first-unsafe
+: first-unsafe ( seq -- first )
0 swap nth-unsafe ; inline
-: first2-unsafe
+: first2-unsafe ( seq -- first second )
[ first-unsafe ] [ 1 swap nth-unsafe ] bi ; inline
-: first3-unsafe
+: first3-unsafe ( seq -- first second third )
[ first2-unsafe ] [ 2 swap nth-unsafe ] bi ; inline
-: first4-unsafe
+: first4-unsafe ( seq -- first second third fourth )
[ first3-unsafe ] [ 3 swap nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- )
: (tail) ( seq n -- from to seq ) over length rot ; inline
-: from-end [ dup length ] dip - ; inline
+: from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
-: (2sequence)
+: (2sequence) ( obj1 obj2 seq -- seq )
tuck 1 swap set-nth-unsafe
tuck 0 swap set-nth-unsafe ; inline
-: (3sequence)
+: (3sequence) ( obj1 obj2 obj3 seq -- seq )
tuck 2 swap set-nth-unsafe
(2sequence) ; inline
-: (4sequence)
+: (4sequence) ( obj1 obj2 obj3 obj4 seq -- seq )
tuck 3 swap set-nth-unsafe
(3sequence) ; inline
<PRIVATE
: (each) ( seq quot -- n quot' )
- [ dup length swap [ nth-unsafe ] curry ] dip compose ; inline
+ [ [ length ] keep [ nth-unsafe ] curry ] dip compose ; inline
: (collect) ( quot into -- quot' )
[ [ keep ] dip set-nth-unsafe ] 2curry ; inline
over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline
: monotonic? ( seq quot -- ? )
- [ dup length 1- swap ] dip (monotonic) all? ; inline
+ [ [ length 1- ] keep ] dip (monotonic) all? ; inline
: interleave ( seq between quot -- )
- [ (interleave) ] 2curry [ dup length swap ] dip 2each ; inline
+ [ (interleave) ] 2curry [ [ length ] keep ] dip 2each ; inline
: accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
<PRIVATE
: joined-length ( seq glue -- n )
- [ dup sum-lengths swap length 1 [-] ] dip length * + ;
+ [ [ sum-lengths ] [ length 1 [-] ] bi ] dip length * + ;
PRIVATE>
[ drop define ]
3bi ;
-: create-accessor ( name effect -- word )
- [ "accessors" create dup ] dip
- "declared-effect" set-word-prop ;
-
: reader-quot ( slot-spec -- quot )
[
dup offset>> ,
] [ ] make ;
: reader-word ( name -- word )
- ">>" append (( object -- value )) create-accessor
+ ">>" append "accessors" create
+ dup (( object -- value )) "declared-effect" set-word-prop
dup t "reader" set-word-prop ;
: reader-props ( slot-spec -- assoc )
define-typecheck ;
: writer-word ( name -- word )
- "(>>" ")" surround (( value object -- )) create-accessor
+ "(>>" ")" surround "accessors" create
+ dup (( value object -- )) "declared-effect" set-word-prop
dup t "writer" set-word-prop ;
ERROR: bad-slot-value value class ;
define-typecheck ;
: setter-word ( name -- word )
- ">>" prepend (( object value -- object )) create-accessor ;
+ ">>" prepend "accessors" create ;
: define-setter ( name -- )
dup setter-word dup deferred? [
- [ \ over , swap writer-word , ] [ ] make define-inline
+ [ \ over , swap writer-word , ] [ ] make
+ (( object value -- object )) define-inline
] [ 2drop ] if ;
: changer-word ( name -- word )
- "change-" prepend (( object quot -- object )) create-accessor ;
+ "change-" prepend "accessors" create ;
: define-changer ( name -- )
dup changer-word dup deferred? [
over reader-word 1quotation
[ dip call ] curry [ dip swap ] curry %
swap setter-word ,
- ] [ ] make define-inline
+ ] [ ] make (( object quot -- object )) define-inline
] [ 2drop ] if ;
: define-slot-methods ( class slot-spec -- )
] if
] if ; inline
-: l-elt [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
-: r-elt [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
-: l-done? [ from1>> ] [ to1>> ] bi number= ; inline
-: r-done? [ from2>> ] [ to2>> ] bi number= ; inline
-: dump-l [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
-: dump-r [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
-: l-next [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
-: r-next [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
-: decide [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
+: l-elt ( merge -- elt ) [ from1>> ] [ seq>> ] bi nth-unsafe ; inline
+
+: r-elt ( merge -- elt ) [ from2>> ] [ seq>> ] bi nth-unsafe ; inline
+
+: l-done? ( merge -- ? ) [ from1>> ] [ to1>> ] bi eq? ; inline
+
+: r-done? ( merge -- ? ) [ from2>> ] [ to2>> ] bi eq? ; inline
+
+: dump-l ( merge -- )
+ [ [ from1>> ] [ to1>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+
+: dump-r ( merge -- )
+ [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
+
+: l-next ( merge -- )
+ [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
+
+: r-next ( merge -- )
+ [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
+
+: decide ( merge -- ? )
+ [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
: (merge) ( merge quot: ( elt1 elt2 -- <=> ) -- )
over r-done? [ drop dump-l ] [
-USING: help.markup help.syntax vocabs.loader io.files strings
+USING: help.markup help.syntax vocabs.loader io.pathnames strings
definitions quotations compiler.units ;
IN: source-files
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces
-sequences strings vectors words quotations io
-combinators sorting splitting math.parser effects continuations
-io.files checksums checksums.crc32 vocabs hashtables graphs
+sequences strings vectors words quotations io io.files
+io.pathnames combinators sorting splitting math.parser effects
+continuations checksums checksums.crc32 vocabs hashtables graphs
compiler.units io.encodings.utf8 accessors ;
IN: source-files
<PRIVATE
-: string-hashcode 3 slot ; inline
+: string-hashcode ( str -- n ) 3 slot ; inline
-: set-string-hashcode 3 set-slot ; inline
+: set-string-hashcode ( n str -- ) 3 set-slot ; inline
-: reset-string-hashcode f swap set-string-hashcode ; inline
+: reset-string-hashcode ( str -- )
+ f swap set-string-hashcode ; inline
: rehash-string ( str -- )
1 over sequence-hashcode swap set-string-hashcode ; inline
USING: generic help.syntax help.markup kernel math parser words
effects classes generic.standard classes.tuple generic.math
-generic.standard arrays io.files vocabs.loader io sequences
-assocs ;
+generic.standard arrays io.pathnames vocabs.loader io sequences
+assocs words.symbol words.alias words.constant ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
ARTICLE: "syntax-pathnames" "Pathname syntax"
{ $subsection POSTPONE: P" }
-"Pathnames are documented in " { $link "pathnames" } "." ;
+"Pathnames are documented in " { $link "io.pathnames" } "." ;
ARTICLE: "syntax-literals" "Literals"
"Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words."
{ $description "Defines a new symbol word in the current vocabulary. Symbols push themselves on the stack when executed, and are used to identify variables (see " { $link "namespaces" } ") as well as for storing crufties in word properties (see " { $link "word-props" } ")." }
{ $examples { $example "USE: prettyprint" "IN: scratchpad" "SYMBOL: foo\nfoo ." "foo" } } ;
-{ define-symbol POSTPONE: SYMBOL: } related-words
+{ define-symbol POSTPONE: SYMBOL: POSTPONE: SYMBOLS: } related-words
+
+HELP: SYMBOLS:
+{ $syntax "SYMBOLS: words... ;" }
+{ $values { "words" "a sequence of new words to define" } }
+{ $description "Creates a new symbol for every token until the " { $snippet ";" } "." }
+{ $examples { $example "USING: prettyprint ;" "IN: scratchpad" "SYMBOLS: foo bar baz ;\nfoo . bar . baz ." "foo\nbar\nbaz" } } ;
+
+HELP: SINGLETONS:
+{ $syntax "SINGLETONS: words... ;" }
+{ $values { "words" "a sequence of new words to define" } }
+{ $description "Creates a new singleton for every token until the " { $snippet ";" } "." } ;
+
+HELP: ALIAS:
+{ $syntax "ALIAS: new-word existing-word" }
+{ $values { "new-word" word } { "existing-word" word } }
+{ $description "Creates a new inlined word that calls the existing word." }
+{ $examples
+ { $example "USING: prettyprint sequences ;"
+ "IN: alias.test"
+ "ALIAS: sequence-nth nth"
+ "0 { 10 20 30 } sequence-nth ."
+ "10"
+ }
+} ;
+
+{ define-alias POSTPONE: ALIAS: } related-words
+
+HELP: CONSTANT:
+{ $syntax "CONSTANT: word value" }
+{ $values { "word" word } { "value" object } }
+{ $description "Creates a word which pushes a value on the stack." }
+{ $examples { $code "CONSTANT: magic 1" "CONSTANT: science HEX: ff0f" } } ;
+
+{ define-constant POSTPONE: CONSTANT: } related-words
HELP: \
{ $syntax "\\ word" }
{ $description "Adds a list of vocabularies to the front of the search path, with later vocabularies taking precedence." }
{ $errors "Throws an error if one of the vocabularies does not exist." } ;
+HELP: QUALIFIED:
+{ $syntax "QUALIFIED: vocab" }
+{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
+{ $examples { $example
+ "USING: prettyprint qualified ;"
+ "QUALIFIED: math"
+ "1 2 math:+ ." "3"
+} } ;
+
+HELP: QUALIFIED-WITH:
+{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
+{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
+{ $examples { $code
+ "USING: prettyprint qualified ;"
+ "QUALIFIED-WITH: math m"
+ "1 2 m:+ ."
+ "3"
+} } ;
+
+HELP: FROM:
+{ $syntax "FROM: vocab => words ... ;" }
+{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." }
+{ $examples { $code
+ "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
+
+HELP: EXCLUDE:
+{ $syntax "EXCLUDE: vocab => words ... ;" }
+{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." }
+{ $examples { $code
+ "EXCLUDE: math.parser => bin> hex> ; ! imports everything but bin> and hex>" } } ;
+
+HELP: RENAME:
+{ $syntax "RENAME: word vocab => newname" }
+{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
+{ $examples { $example
+ "USING: prettyprint qualified ;"
+ "RENAME: + math => -"
+ "2 3 - ."
+ "5"
+} } ;
+
HELP: IN:
{ $syntax "IN: vocabulary" }
{ $values { "vocabulary" "a new vocabulary name" } }
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays byte-arrays definitions generic
hashtables kernel math namespaces parser lexer sequences strings
-strings.parser sbufs vectors words quotations io assocs
-splitting classes.tuple generic.standard generic.math
-generic.parser classes io.files vocabs classes.parser
-classes.union classes.intersection classes.mixin
-classes.predicate classes.singleton classes.tuple.parser
-compiler.units combinators effects.parser slots ;
+strings.parser sbufs vectors words words.symbol words.constant
+words.alias quotations io assocs splitting classes.tuple
+generic.standard generic.math generic.parser classes
+io.pathnames vocabs vocabs.parser classes.parser classes.union
+classes.intersection classes.mixin classes.predicate
+classes.singleton classes.tuple.parser compiler.units
+combinators effects.parser slots ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
"syntax" lookup t "delimiter" set-word-prop ;
: define-syntax ( name quot -- )
- [ "syntax" lookup dup ] dip define make-parsing ;
+ [ dup "syntax" lookup [ dup ] [ no-word-error ] ?if ] dip
+ define make-parsing ;
[
{ "]" "}" ";" ">>" } [ define-delimiter ] each
"USING:" [ ";" parse-tokens add-use ] define-syntax
+ "QUALIFIED:" [ scan dup add-qualified ] define-syntax
+
+ "QUALIFIED-WITH:" [ scan scan add-qualified ] define-syntax
+
+ "FROM:" [
+ scan "=>" expect ";" parse-tokens swap add-words-from
+ ] define-syntax
+
+ "EXCLUDE:" [
+ scan "=>" expect ";" parse-tokens swap add-words-excluding
+ ] define-syntax
+
+ "RENAME:" [
+ scan scan "=>" expect scan add-renamed-word
+ ] define-syntax
+
"HEX:" [ 16 parse-base ] define-syntax
"OCT:" [ 8 parse-base ] define-syntax
"BIN:" [ 2 parse-base ] define-syntax
CREATE-WORD define-symbol
] define-syntax
+ "SYMBOLS:" [
+ ";" parse-tokens
+ [ create-in dup reset-generic define-symbol ] each
+ ] define-syntax
+
+ "SINGLETONS:" [
+ ";" parse-tokens
+ [ create-class-in define-singleton-class ] each
+ ] define-syntax
+
+ "ALIAS:" [
+ CREATE-WORD scan-word define-alias
+ ] define-syntax
+
+ "CONSTANT:" [
+ CREATE scan-object define-constant
+ ] define-syntax
+
"DEFER:" [
scan current-vocab create
dup old-definitions get [ delete-at ] with each
] define-syntax
"C:" [
- CREATE-WORD
- scan-word [ boa ] curry define-inline
+ CREATE-WORD scan-word define-boa-word
] define-syntax
"ERROR:" [
! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make sequences io.files kernel assocs words
-vocabs definitions parser continuations io hashtables sorting
-source-files arrays combinators strings system math.parser
-compiler.errors splitting init accessors sets ;
+USING: namespaces make sequences io io.files io.pathnames kernel
+assocs words vocabs definitions parser continuations hashtables
+sorting source-files arrays combinators strings system
+math.parser compiler.errors splitting init accessors sets ;
IN: vocabs.loader
SYMBOL: vocab-roots
--- /dev/null
+Daniel Ehrenberg
+Bruno Deferrari
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax parser ;
+IN: vocabs.parser
+
+ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
+"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, we say that the old word has been " { $emphasis "shadowed" } "."
+$nl
+"Here is an example where shadowing occurs:"
+{ $code
+ "IN: foe"
+ "USING: sequences io ;"
+ ""
+ ": append"
+ " \"foe::append calls sequences:append\" print append ;"
+ ""
+ "IN: fee"
+ ""
+ ": append"
+ " \"fee::append calls fee:append\" print append ;"
+ ""
+ "IN: fox"
+ "USE: foe"
+ ""
+ ": append"
+ " \"fox::append calls foe:append\" print append ;"
+ ""
+ "\"1234\" \"5678\" append print"
+ ""
+ "USE: fox"
+ "\"1234\" \"5678\" append print"
+}
+"When placed in a source file and run, the above code produces the following output:"
+{ $code
+ "foe:append calls sequences:append"
+ "12345678"
+ "fee:append calls foe:append"
+ "foe:append calls sequences:append"
+ "12345678"
+}
+"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
+
+ARTICLE: "vocabulary-search-errors" "Word lookup errors"
+"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."
+$nl
+"If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used."
+$nl
+"If " { $link auto-use? } " mode is on and only one vocabulary has a word with this name, the vocabulary is added to the search path and parsing continues."
+$nl
+"If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file."
+{ $subsection auto-use? } ;
+
+ARTICLE: "vocabulary-search" "Vocabulary search path"
+"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
+$nl
+"For a source file the vocabulary search path starts off with one vocabulary:"
+{ $code "syntax" }
+"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words."
+$nl
+"In the listener, the " { $vocab-link "scratchpad" } " is the default vocabulary for new word definitions. However, when loading source files, there is no default vocabulary. Defining words before declaring a vocabulary with " { $link POSTPONE: IN: } " results in an error."
+$nl
+"At the interactive listener, the default search path contains many more vocabularies. Details on the default search path and parser invocation are found in " { $link "parser" } "."
+$nl
+"Three parsing words deal with the vocabulary search path:"
+{ $subsection POSTPONE: IN: }
+{ $subsection POSTPONE: USE: }
+{ $subsection POSTPONE: USING: }
+"There are some additional parsing words give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } ":"
+{ $subsection POSTPONE: QUALIFIED: }
+{ $subsection POSTPONE: QUALIFIED-WITH: }
+{ $subsection POSTPONE: FROM: }
+{ $subsection POSTPONE: EXCLUDE: }
+{ $subsection POSTPONE: RENAME: }
+"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file."
+$nl
+"Private words can be defined; note that this is just a convention and they can be called from other vocabularies anyway:"
+{ $subsection POSTPONE: <PRIVATE }
+{ $subsection POSTPONE: PRIVATE> }
+{ $subsection "vocabulary-search-errors" }
+{ $subsection "vocabulary-search-shadow" }
+{ $see-also "words" } ;
+
+ABOUT: "vocabulary-search"
--- /dev/null
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Bruno Deferrari,
+! Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs hashtables kernel namespaces sequences
+sets strings vocabs sorting accessors arrays ;
+IN: vocabs.parser
+
+ERROR: no-word-error name ;
+
+: word-restarts ( name possibilities -- restarts )
+ natural-sort
+ [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
+ swap "Defer word in current vocabulary" swap 2array
+ suffix ;
+
+: <no-word-error> ( name possibilities -- error restarts )
+ [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
+
+SYMBOL: use
+SYMBOL: in
+
+: (use+) ( vocab -- )
+ vocab-words use get push ;
+
+: use+ ( vocab -- )
+ load-vocab (use+) ;
+
+: add-use ( seq -- ) [ use+ ] each ;
+
+: set-use ( seq -- )
+ [ vocab-words ] V{ } map-as sift use set ;
+
+: add-qualified ( vocab prefix -- )
+ [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
+ [ swap [ prepend ] dip ] curry assoc-map
+ use get push ;
+
+: partial-vocab ( words vocab -- assoc )
+ load-vocab vocab-words
+ [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
+
+: add-words-from ( words vocab -- )
+ partial-vocab use get push ;
+
+: partial-vocab-excluding ( words vocab -- assoc )
+ load-vocab [ vocab-words keys swap diff ] keep partial-vocab ;
+
+: add-words-excluding ( words vocab -- )
+ partial-vocab-excluding use get push ;
+
+: add-renamed-word ( word vocab new-name -- )
+ [ load-vocab vocab-words dupd at [ ] [ no-word-error ] ?if ] dip
+ associate use get push ;
+
+: check-vocab-string ( name -- name )
+ dup string? [ "Vocabulary name must be a string" throw ] unless ;
+
+: set-in ( name -- )
+ check-vocab-string dup in set create-vocab (use+) ;
--- /dev/null
+USING: help.markup help.syntax words.alias ;
+IN: words.alias
+
+ARTICLE: "words.alias" "Word aliasing"
+"There is a syntax for defining new names for existing words. This useful for C library bindings, for example in the Win32 API, where words need to be renamed for symmetry."
+$nl
+"Define a new word that aliases another word:"
+{ $subsection POSTPONE: ALIAS: }
+"Define an alias at run-time:"
+{ $subsection define-alias } ;
+
+ABOUT: "words.alias"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: quotations effects accessors sequences words kernel ;
+IN: words.alias
+
+PREDICATE: alias < word "alias" word-prop ;
+
+: define-alias ( new old -- )
+ [ [ 1quotation ] [ stack-effect ] bi define-inline ]
+ [ drop t "alias" set-word-prop ] 2bi ;
+
+M: alias reset-word
+ [ call-next-method ] [ f "alias" set-word-prop ] bi ;
+
+M: alias stack-effect
+ def>> first stack-effect ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Defining multiple words with the same name
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences words ;
+IN: words.constant
+
+PREDICATE: constant < word ( obj -- ? )
+ def>> dup length 1 = [ first word? not ] [ drop f ] if ;
+
+: define-constant ( word value -- )
+ [ ] curry (( -- value )) define-inline ;
--- /dev/null
+USING: help.syntax help.markup words.symbol words compiler.units ;
+IN: words.symbol
+
+HELP: symbol
+{ $description "The class of symbols created by " { $link POSTPONE: SYMBOL: } "." } ;
+
+HELP: define-symbol
+{ $values { "word" word } }
+{ $description "Defines the word to push itself on the stack when executed. This is the run time equivalent of " { $link POSTPONE: SYMBOL: } "." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
+{ $side-effects "word" } ;
+
+ARTICLE: "words.symbol" "Symbols"
+"A symbol pushes itself on the stack when executed. By convention, symbols are used as variable names (" { $link "namespaces" } ")."
+{ $subsection symbol }
+{ $subsection symbol? }
+"Defining symbols at parse time:"
+{ $subsection POSTPONE: SYMBOL: }
+{ $subsection POSTPONE: SYMBOLS: }
+"Defining symbols at run time:"
+{ $subsection define-symbol }
+"Symbols are just compound definitions in disguise. The following two lines are equivalent:"
+{ $code
+ "SYMBOL: foo"
+ ": foo ( -- value ) \\ foo ;"
+} ;
+
+ABOUT: "words.symbol"
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors definitions
+words words.constant ;
+IN: words.symbol
+
+PREDICATE: symbol < constant ( obj -- ? )
+ [ def>> ] [ [ ] curry ] bi sequence= ;
+
+M: symbol definer drop \ SYMBOL: f ;
+
+M: symbol definition drop f ;
+
+: define-symbol ( word -- )
+ dup define-constant ;
$nl
"All other types of word definitions, such as " { $link "symbols" } " and " { $link "generic" } ", are just special cases of the above." ;
-ARTICLE: "symbols" "Symbols"
-"A symbol pushes itself on the stack when executed. By convention, symbols are used as variable names (" { $link "namespaces" } ")."
-{ $subsection symbol }
-{ $subsection symbol? }
-"Defining symbols at parse time:"
-{ $subsection POSTPONE: SYMBOL: }
-"Defining symbols at run time:"
-{ $subsection define-symbol }
-"Symbols are just compound definitions in disguise. The following two lines are equivalent:"
-{ $code
- "SYMBOL: foo"
- ": foo \\ foo ;"
-} ;
-
ARTICLE: "primitives" "Primitives"
"Primitives are words defined in the Factor VM. They provide the essential low-level services to the rest of the system."
{ $subsection primitive }
}
"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words."
{ $subsection "colon-definition" }
-{ $subsection "symbols" }
+{ $subsection "words.symbol" }
+{ $subsection "words.alias" }
{ $subsection "primitives" }
{ $subsection "deferred" }
{ $subsection "declarations" }
HELP: primitive
{ $description "The class of primitive words." } ;
-HELP: symbol
-{ $description "The class of symbols created by " { $link POSTPONE: SYMBOL: } "." } ;
-
HELP: word-prop
{ $values { "word" word } { "name" "a property name" } { "value" "a property value" } }
{ $description "Retrieves a word property. Word property names are conventionally strings." } ;
{ $values { "word" word } { "start" "the word's start address" } { "end" "the word's end address" } }
{ $description "Outputs the machine code address of the word's definition." } ;
-HELP: define-symbol
-{ $values { "word" word } }
-{ $description "Defines the word to push itself on the stack when executed. This is the run time equivalent of " { $link POSTPONE: SYMBOL: } "." }
-{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
-{ $side-effects "word" } ;
-
HELP: define
{ $values { "word" word } { "def" quotation } }
{ $description "Defines the word to call a quotation when executed. This is the run time equivalent of " { $link POSTPONE: : } "." }
{ $side-effects "word" } ;
HELP: define-inline
-{ $values { "word" word } { "quot" quotation } }
+{ $values { "word" word } { "def" quotation } { "effect" effect } }
{ $description "Defines a word and makes it " { $link POSTPONE: inline } "." }
{ $side-effects "word" } ;
M: deferred definer drop \ DEFER: f ;
M: deferred definition drop f ;
-PREDICATE: symbol < word ( obj -- ? )
- [ def>> ] [ [ ] curry ] bi sequence= ;
-M: symbol definer drop \ SYMBOL: f ;
-M: symbol definition drop f ;
-
PREDICATE: primitive < word ( obj -- ? )
[ def>> [ do-primitive ] tail? ]
[ sub-primitive>> >boolean ]
: make-foldable ( word -- )
dup make-flushable t "foldable" set-word-prop ;
-: define-inline ( word quot -- )
- dupd define make-inline ;
-
-: define-symbol ( word -- )
- dup [ ] curry define-inline ;
+: define-inline ( word def effect -- )
+ [ define-declared ] [ 2drop make-inline ] 3bi ;
GENERIC: reset-word ( word -- )
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences symbols fry words assocs linked-assocs tools.annotations
+USING: kernel sequences fry words assocs linked-assocs tools.annotations
coroutines lexer parser quotations arrays namespaces continuations ;
IN: advice
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.streams.string ;
+USING: help.markup help.syntax io.streams.string assocs
+heaps.private ;
IN: assoc-heaps
HELP: <assoc-heap>
+{ $values { "assoc" assoc } { "heap" heap } { "assoc-heap" assoc-heap } }
{ $description "Constructs a new " { $link assoc-heap } " from two existing data structures." } ;
HELP: <unique-max-heap>
-{ $values
-
- { "unique-heap" assoc-heap } }
+{ $values { "unique-heap" assoc-heap } }
{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a max-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
HELP: <unique-min-heap>
-{ $values
- { "unique-heap" assoc-heap } }
+{ $values { "unique-heap" assoc-heap } }
{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a min-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
{ <unique-max-heap> <unique-min-heap> } related-words
: balance>> ( account -- balance ) transactions>> total ;
: open-account ( name interest-rate interest-payment-day opening-date opening-balance -- account )
- >r [ <account> ] keep r> "Account Opened" <transaction> >>transaction ;
+ [ [ <account> ] keep ] dip "Account Opened" <transaction> >>transaction ;
: daily-rate ( yearly-rate day -- daily-rate )
days-in-year / ;
: each-day ( quot start end -- )
2dup before? [
- >r dup >r over >r swap call r> r> 1 days time+ r> each-day
+ [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [
3drop
] if ;
colors.hsv benchmark.mandel.params accessors colors ;
IN: benchmark.mandel.colors
-: scale 255 * >fixnum ; inline
+: scale ( x -- y ) 255 * >fixnum ; inline
: scale-rgb ( rgba -- n )
[ red>> scale ] [ green>> scale ] [ blue>> scale ] tri 3byte-array ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math math.functions sequences prettyprint
-io.files io.encodings io.encodings.ascii io.encodings.binary fry
-benchmark.mandel.params benchmark.mandel.colors ;
+io.files io.files.temp io.encodings io.encodings.ascii
+io.encodings.binary fry benchmark.mandel.params
+benchmark.mandel.colors ;
IN: benchmark.mandel
-: x-inc width 200000 zoom-fact * / ; inline
-: y-inc height 150000 zoom-fact * / ; inline
+: x-inc ( -- x ) width 200000 zoom-fact * / ; inline
+: y-inc ( -- y ) height 150000 zoom-fact * / ; inline
: c ( i j -- c )
[ x-inc * center real-part x-inc width 2 / * - + >float ]
sequences hints arrays ;
IN: benchmark.nbody
-: solar-mass 4 pi sq * ; inline
+: solar-mass ( -- x ) 4 pi sq * ; inline
: days-per-year 365.24 ; inline
TUPLE: body
-USING: io.files io.encodings.ascii random math.parser io math ;
+USING: io io.files io.files.temp io.encodings.ascii random
+math.parser math ;
IN: benchmark.random
: random-numbers-path ( -- path )
! http://www.ffconsultancy.com/free/ray_tracer/languages.html
USING: arrays accessors specialized-arrays.double io io.files
-io.encodings.binary kernel math math.functions math.vectors
-math.parser make sequences sequences.private words hints ;
+io.files.temp io.encodings.binary kernel math math.functions
+math.vectors math.parser make sequences sequences.private words
+hints ;
IN: benchmark.raytracer
! parameters
-USING: io io.files io.streams.duplex kernel sequences
-sequences.private strings vectors words memoize splitting
-grouping hints tr continuations io.encodings.ascii
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files io.files.temp io.streams.duplex kernel
+sequences sequences.private strings vectors words memoize
+splitting grouping hints tr continuations io.encodings.ascii
unicode.case ;
IN: benchmark.reverse-complement
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.encodings.utf8 io.files kernel sequences xml ;
+USING: io.encodings.utf8 io.directories io.files kernel
+sequences xml ;
IN: benchmark.xml
: xml-benchmark ( -- )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes kernel sequences sets
-io prettyprint multi-methods symbols ;
+io prettyprint multi-methods ;
IN: boolean-expr
! Demonstrates the use of Unicode symbols in source files, and
+++ /dev/null
-
-USING: help.syntax help.markup ;
-
-USING: bubble-chamber.particle.muon
- bubble-chamber.particle.quark
- bubble-chamber.particle.hadron
- bubble-chamber.particle.axion ;
-
-IN: bubble-chamber
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: muon
-
- { $class-description
- "The muon is a colorful particle with an entangled friend."
- "It draws both itself and its horizontally symmetric partner."
- "A high range of speed and almost no speed decay allow the"
- "muon to reach the extents of the window, often forming rings"
- "where theta has decayed but speed remains stable. The result"
- "is color almost everywhere in the general direction of collision,"
- "stabilized into fuzzy rings." } ;
-
-HELP: quark
-
- { $class-description
- "The quark draws as a translucent black. Their large numbers"
- "create fields of blackness overwritten only by the glowing shadows of "
- "Hadrons. "
- "quarks are allowed to accelerate away with speed decay values above 1.0. "
- "Each quark has an entangled friend. Both particles are drawn identically,"
- "mirrored along the y-axis." } ;
-
-HELP: hadron
-
- { $class-description
- "Hadrons collide from totally random directions. "
- "Those hadrons that do not exit the drawing area, "
- "tend to stabilize into perfect circular orbits. "
- "Each hadron draws with a slight glowing emboss. "
- "The hadron itself is not drawn." } ;
-
-HELP: axion
-
- { $class-description
- "The axion particle draws a bold black path. Axions exist "
- "in a slightly higher dimension and as such are drawn with "
- "elevated embossed shadows. Axions are quick to stabilize "
- "and fall into single pixel orbits axions automatically "
- "recollide themselves after stabilizing." } ;
-
-{ muon quark hadron axion } related-words
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "bubble-chamber" "Bubble Chamber"
-
-"The " { $vocab-link "bubble-chamber" }
-" is a generative painting system of imaginary "
-"colliding particles. A single super-massive collision produces a "
-"discrete universe of four particle types. Particles draw their "
-"positions over time as pixel exposures.\n"
-"\n"
-"Four types of particles exist. The behavior and graphic appearance of "
-"each particle type is unique.\n"
- { $subsection muon }
- { $subsection quark }
- { $subsection hadron }
- { $subsection axion }
-"\n"
-"After you run the vocabulary, a window will appear. Click the "
-"mouse in a random area to fire 11 particles of each type. "
-"Another way to fire particles is to press the "
-"spacebar. This fires all the particles.\n"
-"\n"
-"Bubble Chamber was created by Jared Tarbell. "
-"It was originally implemented in Processing. "
-"It was ported to Factor by Eduardo Cavazos. "
-"The original work is on display here: "
-{ $url
-"http://www.complexification.net/gallery/machines/bubblechamber/" } ;
-
-ABOUT: "bubble-chamber"
-
-USING: kernel namespaces sequences random math math.constants math.libm vars
- ui
- processing
- processing.gadget
- bubble-chamber.common
- bubble-chamber.particle
- bubble-chamber.particle.muon
- bubble-chamber.particle.quark
- bubble-chamber.particle.hadron
- bubble-chamber.particle.axion ;
+USING: kernel syntax accessors sequences
+ arrays calendar
+ combinators.cleave combinators.short-circuit
+ locals math math.constants math.functions math.libm
+ math.order math.points math.vectors
+ namespaces random sequences threads ui ui.gadgets ui.gestures
+ math.ranges
+ colors
+ colors.gray
+ vars
+ multi-methods
+ multi-method-syntax
+ processing.shapes
+ frame-buffer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
IN: bubble-chamber
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-VARS: particles muons quarks hadrons axions ;
+! This is a Factor implementation of an art piece by Jared Tarbell:
+!
+! http://complexification.net/gallery/machines/bubblechamber/
+!
+! Jared's version is written in Processing (Java)
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! processing
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
+
+: 1random ( b -- num ) 0 swap 2random ;
+
+: at-fraction ( seq fraction -- val ) over length 1- * swap nth ;
+
+: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
+
+: mouse ( -- point ) hand-loc get ;
+
+: mouse-x ( -- x ) mouse first ;
+: mouse-y ( -- y ) mouse second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: collide ( particle -- )
+GENERIC: move ( particle -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: particle
+ bubble-chamber pos vel speed speed-d theta theta-d theta-dd myc mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: initialize-particle ( particle -- particle )
+
+ 0 0 {2} >>pos
+ 0 0 {2} >>vel
+
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
-VAR: boom
+ 0 0 0 1 rgba boa >>myc
+ 0 0 0 1 rgba boa >>mya ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: collide-all ( -- )
+: center ( particle -- point ) bubble-chamber>> size>> 2 v/n ;
- 2 pi * 1random >collision-theta
+DEFER: collision-theta
- particles> [ collide ] each ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: collide-one ( -- )
+: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
+
+: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: turn ( particle -- particle )
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
+: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
+: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
+: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: out-of-bounds? ( PARTICLE -- ? )
+ [let | X [ PARTICLE pos>> first ]
+ Y [ PARTICLE pos>> second ]
+ WIDTH [ PARTICLE bubble-chamber>> size>> first ]
+ HEIGHT [ PARTICLE bubble-chamber>> size>> second ] |
+
+ [let | LEFT [ WIDTH neg ]
+ RIGHT [ WIDTH 2 * ]
+ BOTTOM [ HEIGHT neg ]
+ TOP [ HEIGHT 2 * ] |
+
+ { [ X LEFT < ] [ X RIGHT > ] [ Y BOTTOM < ] [ Y TOP > ] } 0|| ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.axion
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <axion> < particle ;
+
+: axion ( -- <axion> ) <axion> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <axion> -- )
+
+ dup center >>pos
+ 2 pi * 1random >>theta
+ 1.0 6.0 2random >>speed
+ 0.998 1.000 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
+
+! : axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} \ stroke-color set ;
+! : axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} \ stroke-color set ;
+
+: axion-white ( dy -- dy ) dup 1 swap dy>alpha gray boa \ stroke-color set ;
+: axion-black ( dy -- dy ) dup 0 swap dy>alpha gray boa \ stroke-color set ;
+
+: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
+: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <axion> -- )
+
+ T{ gray f 0.06 0.59 } \ stroke-color set
+ dup pos>> point
+
+ 1 4 [a,b] [ axion-white axion-point- ] each
+ 1 4 [a,b] [ axion-black axion-point+ ] each
- dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
+ dup vel>> move-by
- hadrons> random collide
- quarks> random collide
- muons> random collide ;
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
+
+ 1000 random 996 >
+ [
+ dup speed>> neg >>speed
+ dup speed-d>> neg 2 + >>speed-d
+
+ 100 random 30 > [ collide ] [ drop ] if
+ ]
+ [ drop ]
+ if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.hadron
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <hadron> < particle ;
+
+: hadron ( -- <hadron> ) <hadron> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <hadron> -- )
+
+ dup center >>pos
+ 2 pi * 1random >>theta
+ 0.5 3.5 2random >>speed
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ 0 1 0 1 rgba boa >>myc
-: mouse-pressed ( -- )
- boom on
- 1 background ! kludge
- 11 [ drop collide-one ] each ;
+ drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: key-released ( -- )
- key " " =
+METHOD: move ( <hadron> -- )
+
+ T{ gray f 1 0.11 } \ stroke-color set dup pos>> 1 v-y point
+ T{ gray f 0 0.11 } \ stroke-color set dup pos>> 1 v+y point
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
[
- boom on
- 1 background
- collide-all
+ 1.0 >>speed-d
+ 0.00001 >>theta-dd
+
+ 100 random 70 > [ dup collide ] when
]
- when ;
+ when
+ dup out-of-bounds? [ collide ] [ drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.muon.colors
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: bubble-chamber ( -- )
+: good-colors ( -- seq )
+ {
+ T{ rgba f 0.23 0.14 0.17 1 }
+ T{ rgba f 0.23 0.14 0.15 1 }
+ T{ rgba f 0.21 0.14 0.15 1 }
+ T{ rgba f 0.51 0.39 0.33 1 }
+ T{ rgba f 0.49 0.33 0.20 1 }
+ T{ rgba f 0.55 0.45 0.32 1 }
+ T{ rgba f 0.69 0.63 0.51 1 }
+ T{ rgba f 0.64 0.39 0.18 1 }
+ T{ rgba f 0.73 0.42 0.20 1 }
+ T{ rgba f 0.71 0.45 0.29 1 }
+ T{ rgba f 0.79 0.45 0.22 1 }
+ T{ rgba f 0.82 0.56 0.34 1 }
+ T{ rgba f 0.88 0.72 0.49 1 }
+ T{ rgba f 0.85 0.69 0.40 1 }
+ T{ rgba f 0.96 0.92 0.75 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.85 0.82 0.69 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.82 0.82 0.79 1 }
+ T{ rgba f 0.65 0.69 0.67 1 }
+ T{ rgba f 0.53 0.60 0.55 1 }
+ T{ rgba f 0.57 0.53 0.68 1 }
+ T{ rgba f 0.47 0.42 0.56 1 }
+ } ;
- 1000 1000 size*
+: anti-colors ( -- seq ) good-colors <reversed> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
+
+: set-good-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ good-colors at-fraction-of >>myc ]
+ [ drop ]
+ if ;
+
+: set-anti-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ anti-colors at-fraction-of >>mya ]
+ [ drop ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.muon
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <muon> < particle ;
+
+: muon ( -- <muon> ) <muon> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide ( <muon> -- )
+
+ dup center >>pos
+ 2 32 [a,b] random >>speed
+ 0.0001 0.001 2random >>speed-d
+
+ dup collision-theta -0.1 0.1 2random + >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
+
+ set-good-color
+ set-anti-color
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <muon> -- )
+
+ [let | MUON [ ] |
+
+ [let | WIDTH [ MUON bubble-chamber>> size>> first ] |
+
+ MUON
+
+ dup myc>> 0.16 >>alpha \ stroke-color set
+ dup pos>> point
+
+ dup mya>> 0.16 >>alpha \ stroke-color set
+ dup pos>> first2 [ WIDTH swap - ] dip 2array point
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ move-by
+
+ step-theta
+ step-theta-d
+ step-speed-sub
+
+ dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! bubble-chamber.particle.quark
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <quark> < particle ;
+
+: quark ( -- <quark> ) <quark> new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+METHOD: collide ( <quark> -- )
+
+ dup center >>pos
+ dup collision-theta -0.11 0.11 2random + >>theta
+ 0.5 3.0 2random >>speed
+
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move ( <quark> -- )
+
+ [let | QUARK [ ] |
+
+ [let | WIDTH [ QUARK bubble-chamber>> size>> first ] |
+
+ QUARK
+
+ dup myc>> 0.13 >>alpha \ stroke-color set
+ dup pos>> point
+
+ dup pos>> first2 [ WIDTH swap - ] dip 2array point
+
+ [ ] [ vel>> ] bi move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ dup speed>> neg >>speed
+ 2 over speed-d>> - >>speed-d
+ ]
+ when
+
+ dup out-of-bounds? [ collide ] [ drop ] if ] ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE: syntax ! Switch back to non-multi-method 'TUPLE:' syntax
+
+TUPLE: <bubble-chamber> < <frame-buffer>
+ paused particles collision-theta size ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
+! 0 2 pi * 0.001 <range> random >>collision-theta ;
+
+: randomize-collision-theta ( bubble-chamber -- bubble-chamber )
+ pi neg pi 0.001 <range> random >>collision-theta ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collision-theta ( particle -- theta ) bubble-chamber>> collision-theta>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: <bubble-chamber> pref-dim* ( gadget -- dim ) size>> ;
+
+M: <bubble-chamber> ungraft* ( <bubble-chamber> -- ) t >>paused drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-particle ( particle -- ) move ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <bubble-chamber> update-frame-buffer ( BUBBLE-CHAMBER -- )
+
+ BUBBLE-CHAMBER particles>> [ iterate-particle ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: iterate-system ( <bubble-chamber> -- ) drop ;
+
+:: start-bubble-chamber-thread ( GADGET -- )
+ GADGET f >>paused drop
[
- 1 background
- no-stroke
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber ( -- <bubble-chamber> )
+ <bubble-chamber> new-gadget
+ { 1000 1000 } >>size
+ randomize-collision-theta ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber-window ( -- <bubble-chamber> )
+ bubble-chamber
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: add-particle ( BUBBLE-CHAMBER PARTICLE -- bubble-chamber )
- 1789 [ drop <muon> ] map >muons
- 1300 [ drop <quark> ] map >quarks
- 1000 [ drop <hadron> ] map >hadrons
- 111 [ drop <axion> ] map >axions
+ PARTICLE BUBBLE-CHAMBER >>bubble-chamber drop
+
+ BUBBLE-CHAMBER BUBBLE-CHAMBER particles>> PARTICLE suffix >>particles ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: mouse->collision-theta ( BUBBLE-CHAMBER -- BUBBLE-CHAMBER )
+ mouse
+ BUBBLE-CHAMBER size>> 2 v/n
+ v-
+ first2
+ fatan2
+ BUBBLE-CHAMBER (>>collision-theta)
+ BUBBLE-CHAMBER ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- muons> quarks> hadrons> axions> 3append append >particles
+:: mouse-pressed ( BUBBLE-CHAMBER -- )
- collide-one
- ] setup
+ BUBBLE-CHAMBER mouse->collision-theta drop
+ 11
[
- boom>
- [ particles> [ move ] each ]
- when
- ] draw
+ BUBBLE-CHAMBER particles>> [ <hadron>? ] filter random [ collide ] when*
+ BUBBLE-CHAMBER particles>> [ <quark>? ] filter random [ collide ] when*
+ BUBBLE-CHAMBER particles>> [ <muon>? ] filter random [ collide ] when*
+ ]
+ times ;
- [ mouse-pressed ] button-down
- [ key-released ] key-up ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<bubble-chamber> H{ { T{ button-down } [ mouse-pressed ] } } set-gestures
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-random-particle ( bubble-chamber -- bubble-chamber )
+ dup particles>> random collide ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: big-bang ( bubble-chamber -- bubble-chamber )
+ dup particles>> [ collide ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-one-of-each ( bubble-chamber -- bubble-chamber )
+ dup
+ particles>>
+ [ [ <muon>? ] filter random collide ]
+ [ [ <quark>? ] filter random collide ]
+ [ [ <hadron>? ] filter random collide ]
+ tri ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Some initial configurations
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ten-hadrons ( -- )
+ bubble-chamber-window
+ 10 [ drop hadron add-particle ] each
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original ( -- )
+
+ bubble-chamber-window
+
+ 1789 [ muon add-particle ] times
+ 1300 [ quark add-particle ] times
+ 1000 [ hadron add-particle ] times
+ 111 [ axion add-particle ] times
+
+ particles>>
+ [ [ <muon>? ] filter random collide ]
+ [ [ <quark>? ] filter random collide ]
+ [ [ <hadron>? ] filter random collide ]
+ tri ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hadron-chamber ( -- )
+ bubble-chamber-window
+ 1000 [ hadron add-particle ] times
+ big-bang
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: quark-chamber ( -- )
+ bubble-chamber-window
+ 100 [ quark add-particle ] times
+ big-bang
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: small ( -- )
+ <bubble-chamber> new-gadget
+ { 200 200 } >>size
+ randomize-collision-theta
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
-: go ( -- ) [ bubble-chamber run ] with-ui ;
+ 42 [ muon add-particle ] times
+ 30 [ quark add-particle ] times
+ 21 [ hadron add-particle ] times
+ 7 [ axion add-particle ] times
+
+ collide-one-of-each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: medium ( -- )
+ <bubble-chamber> new-gadget
+ { 400 400 } >>size
+ randomize-collision-theta
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 100 [ muon add-particle ] times
+ 81 [ quark add-particle ] times
+ 60 [ hadron add-particle ] times
+ 9 [ axion add-particle ] times
+
+ collide-one-of-each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: large ( -- )
+ <bubble-chamber> new-gadget
+ { 600 600 } >>size
+ randomize-collision-theta
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 550 [ muon add-particle ] times
+ 339 [ quark add-particle ] times
+ 100 [ hadron add-particle ] times
+ 11 [ axion add-particle ] times
+
+ collide-one-of-each
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Experimental
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: muon-chamber ( -- )
+ bubble-chamber-window
+ 1000 [ muon add-particle ] times
+ dup particles>> [ collide randomize-collision-theta ] each
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original-big-bang ( -- )
+ bubble-chamber
+ { 1000 1000 } >>size
+ dup start-bubble-chamber-thread
+ dup "Bubble Chamber" open-window
+
+ 1789 [ muon add-particle ] times
+ 1300 [ quark add-particle ] times
+ 1000 [ hadron add-particle ] times
+ 111 [ axion add-particle ] times
+
+ big-bang
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: original-big-bang-variant ( -- )
+ bubble-chamber-window
+ 1789 [ muon add-particle ] times
+ 1300 [ quark add-particle ] times
+ 1000 [ hadron add-particle ] times
+ 111 [ axion add-particle ] times
+ dup particles>> [ collide randomize-collision-theta ] each
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MAIN: go
\ No newline at end of file
+++ /dev/null
-
-USING: kernel math accessors combinators.cleave vars ;
-
-IN: bubble-chamber.common
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: collision-theta
-
-: dim ( -- dim ) 1000 ;
-
-: center ( -- point ) dim 2 / dup {2} ; foldable
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.hadron-chamber
+
+: main ( -- ) [ hadron-chamber ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.large
+
+: main ( -- ) [ large ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.medium
+
+: main ( -- ) [ medium ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.original
+
+: main ( -- ) [ original ] with-ui ;
+
+MAIN: main
\ No newline at end of file
+++ /dev/null
-
-USING: kernel sequences random accessors multi-methods
- math math.constants math.ranges math.points combinators.cleave
- processing processing.shapes
- bubble-chamber.common bubble-chamber.particle ;
-
-IN: bubble-chamber.particle.axion
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: axion < particle ;
-
-: <axion> ( -- axion ) axion new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { axion }
-
- center >>pos
- 2 pi * 1random >>theta
- 1.0 6.0 2random >>speed
- 0.998 1.000 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
-
-: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
-: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
-
-: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
-: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { axion }
-
- { 0.06 0.59 } stroke
- dup pos>> point
-
- 1 4 [a,b] [ axion-white axion-point- ] each
- 1 4 [a,b] [ axion-black axion-point+ ] each
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
-
- 1000 random 996 >
- [
- dup speed>> neg >>speed
- dup speed-d>> neg 2 + >>speed-d
-
- 100 random 30 > [ collide ] [ drop ] if
- ]
- [ drop ]
- if ;
+++ /dev/null
-
-USING: kernel random math math.constants math.points accessors multi-methods
- processing processing.shapes
- bubble-chamber.common
- bubble-chamber.particle colors ;
-
-IN: bubble-chamber.particle.hadron
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: hadron < particle ;
-
-: <hadron> ( -- hadron ) hadron new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { hadron }
-
- center >>pos
- 2 pi * 1random >>theta
- 0.5 3.5 2random >>speed
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
- 0 1 0 1 rgba boa >>myc
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { hadron }
-
- { 1 0.11 } stroke
- dup pos>> 1 v-y point
-
- { 0 0.11 } stroke
- dup pos>> 1 v+y point
-
- dup vel>> move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- 1.0 >>speed-d
- 0.00001 >>theta-dd
-
- 100 random 70 > [ dup collide ] when
- ]
- when
-
- out-of-bounds? [ collide ] [ drop ] if ;
+++ /dev/null
-
-USING: kernel sequences math math.constants math.order accessors
- processing
- colors ;
-
-IN: bubble-chamber.particle.muon.colors
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: good-colors ( -- seq )
- {
- T{ rgba f 0.23 0.14 0.17 1 }
- T{ rgba f 0.23 0.14 0.15 1 }
- T{ rgba f 0.21 0.14 0.15 1 }
- T{ rgba f 0.51 0.39 0.33 1 }
- T{ rgba f 0.49 0.33 0.20 1 }
- T{ rgba f 0.55 0.45 0.32 1 }
- T{ rgba f 0.69 0.63 0.51 1 }
- T{ rgba f 0.64 0.39 0.18 1 }
- T{ rgba f 0.73 0.42 0.20 1 }
- T{ rgba f 0.71 0.45 0.29 1 }
- T{ rgba f 0.79 0.45 0.22 1 }
- T{ rgba f 0.82 0.56 0.34 1 }
- T{ rgba f 0.88 0.72 0.49 1 }
- T{ rgba f 0.85 0.69 0.40 1 }
- T{ rgba f 0.96 0.92 0.75 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.85 0.82 0.69 1 }
- T{ rgba f 0.99 0.98 0.87 1 }
- T{ rgba f 0.82 0.82 0.79 1 }
- T{ rgba f 0.65 0.69 0.67 1 }
- T{ rgba f 0.53 0.60 0.55 1 }
- T{ rgba f 0.57 0.53 0.68 1 }
- T{ rgba f 0.47 0.42 0.56 1 }
- } ;
-
-: anti-colors ( -- seq ) good-colors <reversed> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
-
-: set-good-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ good-colors at-fraction-of >>myc ]
- [ drop ]
- if ;
-
-: set-anti-color ( particle -- particle )
- color-fraction dup 0 1 between?
- [ anti-colors at-fraction-of >>mya ]
- [ drop ]
- if ;
+++ /dev/null
-
-USING: kernel arrays sequences random
- math
- math.ranges
- math.functions
- math.vectors
- multi-methods accessors
- combinators.cleave
- processing
- processing.shapes
- bubble-chamber.common
- bubble-chamber.particle
- bubble-chamber.particle.muon.colors ;
-
-IN: bubble-chamber.particle.muon
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: muon < particle ;
-
-: <muon> ( -- muon ) muon new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { muon }
-
- center >>pos
- 2 32 [a,b] random >>speed
- 0.0001 0.001 2random >>speed-d
-
- collision-theta> -0.1 0.1 2random + >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
-
- set-good-color
- set-anti-color
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { muon }
-
- dup myc>> 0.16 >>alpha stroke
- dup pos>> point
-
- dup mya>> 0.16 >>alpha stroke
- dup pos>> first2 >r dim swap - r> 2array point
-
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- move-by
-
- step-theta
- step-theta-d
- step-speed-sub
-
- out-of-bounds? [ collide ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel sequences combinators
- math math.vectors math.functions multi-methods
- accessors combinators.cleave processing
- bubble-chamber.common colors ;
-
-IN: bubble-chamber.particle
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: collide ( particle -- )
-GENERIC: move ( particle -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: initialize-particle ( particle -- particle )
-
- 0 0 {2} >>pos
- 0 0 {2} >>vel
-
- 0 >>speed
- 0 >>speed-d
- 0 >>theta
- 0 >>theta-d
- 0 >>theta-dd
-
- 0 0 0 1 rgba boa >>myc
- 0 0 0 1 rgba boa >>mya ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
-
-: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: turn ( particle -- particle )
- dup
- [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
- >>vel ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
-: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
-: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
-: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x ( particle -- x ) pos>> first ;
-: y ( particle -- x ) pos>> second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: out-of-bounds? ( particle -- particle ? )
- dup
- { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
- or or or ;
+++ /dev/null
-
-USING: kernel arrays sequences random math accessors multi-methods
- processing processing.shapes
- bubble-chamber.common
- bubble-chamber.particle ;
-
-IN: bubble-chamber.particle.quark
-
-TUPLE: quark < particle ;
-
-: <quark> ( -- quark ) quark new initialize-particle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: collide { quark }
-
- center >>pos
- collision-theta> -0.11 0.11 2random + >>theta
- 0.5 3.0 2random >>speed
-
- 0.996 1.001 2random >>speed-d
- 0 >>theta-d
- 0 >>theta-dd
-
- [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: move { quark }
-
- dup myc>> 0.13 >>alpha stroke
- dup pos>> point
-
- dup pos>> first2 >r dim swap - r> 2array point
-
- [ ] [ vel>> ] bi move-by
-
- turn
-
- step-theta
- step-theta-d
- step-speed-mul
-
- 1000 random 997 >
- [
- dup speed>> neg >>speed
- 2 over speed-d>> - >>speed-d
- ]
- when
-
- out-of-bounds? [ collide ] [ drop ] if ;
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.quark-chamber
+
+: main ( -- ) [ quark-chamber ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.small
+
+: main ( -- ) [ small ] with-ui ;
+
+MAIN: main
\ No newline at end of file
--- /dev/null
+
+USING: ui bubble-chamber ;
+
+IN: bubble-chamber.ten-hadrons
+
+: main ( -- ) [ ten-hadrons ] with-ui ;
+
+MAIN: main
\ No newline at end of file
USING: arrays bunny.model continuations destructors kernel
multiline opengl opengl.shaders opengl.capabilities opengl.gl
-sequences sequences.lib accessors combinators ;
+sequences accessors combinators ;
IN: bunny.cel-shaded
STRING: vertex-shader-source
USING: accessors alien.c-types arrays combinators destructors
-http.client io io.encodings.ascii io.files kernel math
-math.matrices math.parser math.vectors opengl
+http.client io io.encodings.ascii io.files io.files.temp kernel
+math math.matrices math.parser math.vectors opengl
opengl.capabilities opengl.gl opengl.demo-support sequences
-sequences.lib splitting vectors words
-specialized-arrays.float specialized-arrays.uint ;
+splitting vectors words specialized-arrays.float
+specialized-arrays.uint ;
IN: bunny.model
: numbers ( str -- seq )
vneg normalize ;
: normal ( ns vs triple -- )
- [ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;
+ [ n ] keep [ rot [ v+ ] change-nth ] with with each ;
: normals ( vs is -- ns )
over length { 0.0 0.0 0.0 } <array> -rot
] unless ;
: (draw-triangle) ( ns vs triple -- )
- [ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
+ [ dup roll nth gl-normal swap nth gl-vertex ] with with each ;
: draw-triangles ( ns vs is -- )
- GL_TRIANGLES [ [ (draw-triangle) ] each-with2 ] do-state ;
+ GL_TRIANGLES [ [ (draw-triangle) ] with with each ] do-state ;
TUPLE: bunny-dlist list ;
TUPLE: bunny-buffers array element-array nv ni ;
vars colors self self.slots
random-weighted colors.hsv cfdg.gl accessors
ui.gadgets.handler ui.gestures assocs ui.gadgets macros
- qualified specialized-arrays.double ;
+ specialized-arrays.double ;
QUALIFIED: syntax
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.launcher io.styles io.encodings.ascii
-prettyprint io hashtables kernel sequences assocs system sorting
-math.parser sets ;
+USING: io.files io.launcher io.directories io.pathnames
+io.encodings.ascii io prettyprint hashtables kernel sequences
+assocs system sorting math.parser sets ;
IN: contributors
: changelog ( -- authors )
initialize-sha1 process-sha1-block
stream>sha1 get-sha1
initialize-sha1
- >r process-sha1-block r>
- process-sha1-block get-sha1 ;
+ [ process-sha1-block ]
+ [ process-sha1-block ] bi* get-sha1 ;
: md5-hmac ( Ko Ki -- hmac )
initialize-md5 process-md5-block
stream>md5 get-md5
initialize-md5
- >r process-md5-block r>
- process-md5-block get-md5 ;
+ [ process-md5-block ]
+ [ process-md5-block ] bi* get-md5 ;
: seq-bitxor ( seq seq -- seq )
[ bitxor ] 2map ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel base64 checksums.md5 symbols sequences checksums
+USING: kernel base64 checksums.md5 sequences checksums
locals prettyprint math math.bitwise grouping io combinators
fry make combinators.short-circuit math.functions splitting ;
IN: crypto.passwd-md5
accessors
combinators.cleave
newfx
- symbols
;
IN: dns
--- /dev/null
+John Benediktsson
--- /dev/null
+
+USING: help.syntax help.markup kernel prettyprint sequences strings ;
+
+IN: formatting
+
+HELP: printf
+{ $values { "format-string" string } }
+{ $description
+ "Writes the arguments (specified on the stack) formatted according to the format string.\n"
+ "\n"
+ "Several format specifications exist for handling arguments of different types, and "
+ "specifying attributes for the result string, including such things as maximum width, "
+ "padding, and decimals.\n"
+ { $table
+ { "%%" "Single %" "" }
+ { "%P.Ds" "String format" "string" }
+ { "%P.DS" "String format uppercase" "string" }
+ { "%c" "Character format" "char" }
+ { "%C" "Character format uppercase" "char" }
+ { "%+Pd" "Integer format" "fixnum" }
+ { "%+P.De" "Scientific notation" "fixnum, float" }
+ { "%+P.DE" "Scientific notation" "fixnum, float" }
+ { "%+P.Df" "Fixed format" "fixnum, float" }
+ { "%+Px" "Hexadecimal" "hex" }
+ { "%+PX" "Hexadecimal uppercase" "hex" }
+ }
+ "\n"
+ "A plus sign ('+') is used to optionally specify that the number should be "
+ "formatted with a '+' preceeding it if positive.\n"
+ "\n"
+ "Padding ('P') is used to optionally specify the minimum width of the result "
+ "string, the padding character, and the alignment. By default, the padding "
+ "character defaults to a space and the alignment defaults to right-aligned. "
+ "For example:\n"
+ { $list
+ "\"%5s\" formats a string padding with spaces up to 5 characters wide."
+ "\"%08d\" formats an integer padding with zeros up to 3 characters wide."
+ "\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
+ "\"%-10d\" formats an integer to 10 characters wide and left-aligns."
+ }
+ "\n"
+ "Digits ('D') is used to optionally specify the maximum digits in the result "
+ "string. For example:\n"
+ { $list
+ "\"%.3s\" formats a string to truncate at 3 characters (from the left)."
+ "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
+ "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
+ }
+}
+{ $examples
+ { $example
+ "USING: formatting ;"
+ "123 \"%05d\" printf"
+ "00123" }
+ { $example
+ "USING: formatting ;"
+ "HEX: ff \"%04X\" printf"
+ "00FF" }
+ { $example
+ "USING: formatting ;"
+ "1.23456789 \"%.3f\" printf"
+ "1.235" }
+ { $example
+ "USING: formatting ;"
+ "1234567890 \"%.5e\" printf"
+ "1.23457e+09" }
+ { $example
+ "USING: formatting ;"
+ "12 \"%'#4d\" printf"
+ "##12" }
+ { $example
+ "USING: formatting ;"
+ "1234 \"%+d\" printf"
+ "+1234" }
+} ;
+
+HELP: sprintf
+{ $values { "format-string" string } { "result" string } }
+{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." }
+{ $see-also printf } ;
+
+HELP: strftime
+{ $values { "format-string" string } }
+{ $description
+ "Writes the timestamp (specified on the stack) formatted according to the format string.\n"
+ "\n"
+ "Different attributes of the timestamp can be retrieved using format specifications.\n"
+ { $table
+ { "%a" "Abbreviated weekday name." }
+ { "%A" "Full weekday name." }
+ { "%b" "Abbreviated month name." }
+ { "%B" "Full month name." }
+ { "%c" "Date and time representation." }
+ { "%d" "Day of the month as a decimal number [01,31]." }
+ { "%H" "Hour (24-hour clock) as a decimal number [00,23]." }
+ { "%I" "Hour (12-hour clock) as a decimal number [01,12]." }
+ { "%j" "Day of the year as a decimal number [001,366]." }
+ { "%m" "Month as a decimal number [01,12]." }
+ { "%M" "Minute as a decimal number [00,59]." }
+ { "%p" "Either AM or PM." }
+ { "%S" "Second as a decimal number [00,59]." }
+ { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal number [00,53]." }
+ { "%w" "Weekday as a decimal number [0(Sunday),6]." }
+ { "%W" "Week number of the year (Monday as the first day of the week) as a decimal number [00,53]." }
+ { "%x" "Date representation." }
+ { "%X" "Time representation." }
+ { "%y" "Year without century as a decimal number [00,99]." }
+ { "%Y" "Year with century as a decimal number." }
+ { "%Z" "Time zone name (no characters if no time zone exists)." }
+ { "%%" "A literal '%' character." }
+ }
+}
+{ $examples
+ { $unchecked-example
+ "USING: calendar formatting io ;"
+ "now \"%c\" strftime print"
+ "Mon Dec 15 14:40:43 2008" }
+} ;
+
+ARTICLE: "formatting" "Formatted printing"
+"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing.\n"
+{ $subsection printf }
+{ $subsection sprintf }
+{ $subsection strftime }
+;
+
+ABOUT: "formatting"
+
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: calendar kernel formatting tools.test ;
+
+IN: formatting.tests
+
+[ "%s" printf ] must-infer
+[ "%s" sprintf ] must-infer
+
+[ t ] [ "" "" sprintf = ] unit-test
+[ t ] [ "asdf" "asdf" sprintf = ] unit-test
+[ t ] [ "10" 10 "%d" sprintf = ] unit-test
+[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test
+[ t ] [ "-10" -10 "%d" sprintf = ] unit-test
+[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test
+[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test
+[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
+[ t ] [ "123.456000" 123.456 "%f" sprintf = ] unit-test
+[ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test
+[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
+[ t ] [ "1.2346" 1.23456789 "%.4f" sprintf = ] unit-test
+[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
+[ t ] [ "1.234000e+08" 123400000 "%e" sprintf = ] unit-test
+[ t ] [ "-1.234000e+08" -123400000 "%e" sprintf = ] unit-test
+[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
+[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
+[ t ] [ "2.500000e-03" 0.0025 "%e" sprintf = ] unit-test
+[ t ] [ "2.500000E-03" 0.0025 "%E" sprintf = ] unit-test
+[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test
+[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test
+[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test
+[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test
+[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test
+[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test
+[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test
+[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test
+[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test
+[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
+[ t ] [ "2008-09-10"
+ 2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
+[ t ] [ "Hello, World!"
+ "Hello, World!" "%s" sprintf = ] unit-test
+[ t ] [ "printf test"
+ "printf test" sprintf = ] unit-test
+[ t ] [ "char a = 'a'"
+ CHAR: a "char %c = 'a'" sprintf = ] unit-test
+[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
+[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
+[ t ] [ "0 message(s)"
+ 0 "message" "%d %s(s)" sprintf = ] unit-test
+[ t ] [ "0 message(s) with %"
+ 0 "message" "%d %s(s) with %%" sprintf = ] unit-test
+[ t ] [ "justif: \"left \""
+ "left" "justif: \"%-10s\"" sprintf = ] unit-test
+[ t ] [ "justif: \" right\""
+ "right" "justif: \"%10s\"" sprintf = ] unit-test
+[ t ] [ " 3: 0003 zero padded"
+ 3 " 3: %04d zero padded" sprintf = ] unit-test
+[ t ] [ " 3: 3 left justif"
+ 3 " 3: %-4d left justif" sprintf = ] unit-test
+[ t ] [ " 3: 3 right justif"
+ 3 " 3: %4d right justif" sprintf = ] unit-test
+[ t ] [ " -3: -003 zero padded"
+ -3 " -3: %04d zero padded" sprintf = ] unit-test
+[ t ] [ " -3: -3 left justif"
+ -3 " -3: %-4d left justif" sprintf = ] unit-test
+[ t ] [ " -3: -3 right justif"
+ -3 " -3: %4d right justif" sprintf = ] unit-test
+[ t ] [ "There are 10 monkeys in the kitchen"
+ 10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
+[ f ] [ "%d" 10 "%d" sprintf = ] unit-test
+[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test
+[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test
+[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test
+[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
+[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
+[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
+
+
+[ "%H:%M:%S" strftime ] must-infer
+
+: testtime ( -- timestamp )
+ 2008 10 9 12 3 15 instant <timestamp> ;
+
+[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
+[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
+
+[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
+[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
+
+[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
+[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
+
+[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
+[ t ] [ "October" testtime "%B" strftime = ] unit-test
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays ascii calendar combinators fry kernel
+io io.encodings.ascii io.files io.streams.string
+macros math math.functions math.parser peg.ebnf quotations
+sequences splitting strings unicode.case vectors ;
+
+IN: formatting
+
+<PRIVATE
+
+: compose-all ( seq -- quot )
+ [ ] [ compose ] reduce ;
+
+: fix-sign ( string -- string )
+ dup CHAR: 0 swap index 0 =
+ [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
+ [ dup 1- rot dup [ nth ] dip swap
+ {
+ { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
+ { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
+ [ drop swap drop ]
+ } case
+ ] [ drop ] if
+ ] when ;
+
+: >digits ( string -- digits )
+ [ 0 ] [ string>number ] if-empty ;
+
+: pad-digits ( string digits -- string' )
+ [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
+
+: max-digits ( n digits -- n' )
+ 10 swap ^ [ * round ] keep / ;
+
+: max-width ( string length -- string' )
+ short head ;
+
+: >exp ( x -- exp base )
+ [
+ abs 0 swap
+ [ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
+ [ dup 10.0 >=
+ [ 10.0 / [ 1+ ] dip ]
+ [ 10.0 * [ 1- ] dip ] if
+ ] [ ] while
+ ] keep 0 < [ neg ] when ;
+
+: exp>string ( exp base digits -- string )
+ [ max-digits ] keep -rot
+ [
+ [ 0 < "-" "+" ? ]
+ [ abs number>string 2 CHAR: 0 pad-left ] bi
+ "e" -rot 3append
+ ]
+ [ number>string ] bi*
+ rot pad-digits prepend ;
+
+EBNF: parse-printf
+
+zero = "0" => [[ CHAR: 0 ]]
+char = "'" (.) => [[ second ]]
+
+pad-char = (zero|char)? => [[ CHAR: \s or ]]
+pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
+pad-width = ([0-9])* => [[ >digits ]]
+pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
+
+sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]]
+
+width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]]
+width = (width_)? => [[ [ ] or ]]
+
+digits_ = "." ([0-9])* => [[ second >digits ]]
+digits = (digits_)? => [[ 6 or ]]
+
+fmt-% = "%" => [[ [ "%" ] ]]
+fmt-c = "c" => [[ [ 1string ] ]]
+fmt-C = "C" => [[ [ 1string >upper ] ]]
+fmt-s = "s" => [[ [ ] ]]
+fmt-S = "S" => [[ [ >upper ] ]]
+fmt-d = "d" => [[ [ >fixnum number>string ] ]]
+fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
+fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
+fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
+fmt-x = "x" => [[ [ >hex ] ]]
+fmt-X = "X" => [[ [ >hex >upper ] ]]
+unknown = (.)* => [[ "Unknown directive" throw ]]
+
+strings_ = fmt-c|fmt-C|fmt-s|fmt-S
+strings = pad width strings_ => [[ reverse compose-all ]]
+
+numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
+numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
+
+formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
+
+text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: printf ( format-string -- )
+ parse-printf [ length ] keep compose-all '[ _ <vector> @ reverse [ write ] each ] ;
+
+: sprintf ( format-string -- result )
+ [ printf ] with-string-writer ; inline
+
+
+<PRIVATE
+
+: zero-pad ( str -- str' ) 2 CHAR: 0 pad-left ; inline
+
+: >time ( timestamp -- string )
+ [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
+ [ number>string zero-pad ] map ":" join ; inline
+
+: >date ( timestamp -- string )
+ [ month>> ] [ day>> ] [ year>> ] tri 3array
+ [ number>string zero-pad ] map "/" join ; inline
+
+: >datetime ( timestamp -- string )
+ { [ day-of-week day-abbreviation3 ]
+ [ month>> month-abbreviation ]
+ [ day>> number>string zero-pad ]
+ [ >time ]
+ [ year>> number>string ]
+ } cleave 3array [ 2array ] dip append " " join ; inline
+
+: (week-of-year) ( timestamp day -- n )
+ [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
+ [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
+
+: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
+
+: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline
+
+EBNF: parse-strftime
+
+fmt-% = "%" => [[ [ "%" ] ]]
+fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]]
+fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
+fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
+fmt-B = "B" => [[ [ dup month>> month-name ] ]]
+fmt-c = "c" => [[ [ dup >datetime ] ]]
+fmt-d = "d" => [[ [ dup day>> number>string zero-pad ] ]]
+fmt-H = "H" => [[ [ dup hour>> number>string zero-pad ] ]]
+fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when number>string zero-pad ] ]]
+fmt-j = "j" => [[ [ dup day-of-year number>string ] ]]
+fmt-m = "m" => [[ [ dup month>> number>string zero-pad ] ]]
+fmt-M = "M" => [[ [ dup minute>> number>string zero-pad ] ]]
+fmt-p = "p" => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]]
+fmt-S = "S" => [[ [ dup second>> round number>string zero-pad ] ]]
+fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]]
+fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
+fmt-W = "W" => [[ [ dup week-of-year-monday ] ]]
+fmt-x = "x" => [[ [ dup >date ] ]]
+fmt-X = "X" => [[ [ dup >time ] ]]
+fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]]
+fmt-Y = "Y" => [[ [ dup year>> number>string ] ]]
+fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
+unknown = (.)* => [[ "Unknown directive" throw ]]
+
+formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
+ fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|
+ fmt-X|fmt-y|fmt-Y|fmt-Z|unknown
+
+formats = "%" (formats_) => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
+
+text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: strftime ( format-string -- )
+ parse-strftime [ length ] keep [ ] join
+ '[ _ <vector> @ reverse concat nip ] ;
+
+
--- /dev/null
+Format data according to a specified format string, and writes (or returns) the result string.
--- /dev/null
+
+USING: accessors alien.c-types combinators grouping kernel
+ locals math math.geometry.rect math.vectors opengl.gl sequences
+ ui.gadgets ui.render ;
+
+IN: frame-buffer
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <frame-buffer> < gadget pixels last-dim ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: update-frame-buffer ( <frame-buffer> -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-frame-buffer-pixels ( frame-buffer -- )
+ dup
+ rect-dim product "uint[4]" <c-array>
+ >>pixels
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: frame-buffer ( -- <frame-buffer> ) <frame-buffer> new-gadget ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: draw-pixels ( FRAME-BUFFER -- )
+
+ FRAME-BUFFER rect-dim first2
+ GL_RGBA
+ GL_UNSIGNED_INT
+ FRAME-BUFFER pixels>>
+ glDrawPixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: read-pixels ( FRAME-BUFFER -- )
+
+ 0
+ 0
+ FRAME-BUFFER rect-dim first2
+ GL_RGBA
+ GL_UNSIGNED_INT
+ FRAME-BUFFER pixels>>
+ glReadPixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: copy-row ( OLD NEW -- )
+
+ [let | LEN [ OLD NEW min-length ] |
+
+ OLD LEN head-slice 0 NEW copy ] ;
+
+: copy-pixels ( old-pixels old-width new-pixels new-width -- )
+ [ 16 * <sliced-groups> ] 2bi@
+ [ copy-row ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update-last-dim ( frame-buffer -- ) dup rect-dim >>last-dim drop ;
+
+M:: <frame-buffer> layout* ( FRAME-BUFFER -- )
+
+ {
+ {
+ [ FRAME-BUFFER last-dim>> f = ]
+ [
+ FRAME-BUFFER init-frame-buffer-pixels
+
+ FRAME-BUFFER update-last-dim
+ ]
+ }
+ {
+ [ FRAME-BUFFER [ rect-dim ] [ last-dim>> ] bi = not ]
+ [
+ [let | OLD-PIXELS [ FRAME-BUFFER pixels>> ]
+ OLD-WIDTH [ FRAME-BUFFER last-dim>> first ] |
+
+ FRAME-BUFFER init-frame-buffer-pixels
+
+ FRAME-BUFFER update-last-dim
+
+ [let | NEW-PIXELS [ FRAME-BUFFER pixels>> ]
+ NEW-WIDTH [ FRAME-BUFFER last-dim>> first ] |
+
+ OLD-PIXELS OLD-WIDTH NEW-PIXELS NEW-WIDTH copy-pixels ] ]
+ ]
+ }
+ { [ t ] [ ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <frame-buffer> draw-gadget* ( FRAME-BUFFER -- )
+
+ FRAME-BUFFER rect-dim { 0 1 } v* first2 glRasterPos2i
+
+ FRAME-BUFFER draw-pixels
+
+ FRAME-BUFFER update-frame-buffer
+
+ glFlush
+
+ FRAME-BUFFER read-pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes classes.tuple compiler.units
-combinators continuations debugger definitions eval help
-io io.files io.streams.string kernel lexer listener listener.private
-make math namespaces parser prettyprint prettyprint.config
-quotations sequences strings source-files vectors vocabs.loader ;
+USING: accessors arrays assocs classes classes.tuple
+combinators compiler.units continuations debugger definitions
+eval help io io.files io.pathnames io.streams.string kernel
+lexer listener listener.private make math memoize namespaces
+parser prettyprint prettyprint.config quotations sequences sets
+sorting source-files strings tools.vocabs vectors vocabs
+vocabs.loader ;
IN: fuel
M: condition fuel-pprint
[ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
+M: lexer-error fuel-pprint
+ {
+ [ line>> ]
+ [ column>> ]
+ [ line-text>> ]
+ [ fuel-restarts ]
+ } cleave 4array lexer-error prefix fuel-pprint ;
+
M: source-file-error fuel-pprint
[ file>> ] [ error>> ] bi 2array source-file-error prefix
fuel-pprint ;
error get
fuel-eval-result get-global
fuel-eval-output get-global
- 3array fuel-pprint ;
+ 3array fuel-pprint flush nl "EOT:" write ;
: fuel-forget-error ( -- ) f error set-global ; inline
: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
: fuel-get-edit-location ( defspec -- )
- where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ]
- when* ;
+ where [
+ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result
+ ] when* ; inline
+
+: fuel-get-vocab-location ( vocab -- )
+ >vocab-link fuel-get-edit-location ; inline
+
+: (fuel-get-vocabs) ( -- seq )
+ all-vocabs-seq [ vocab-name ] map ; inline
+
+: fuel-get-vocabs ( -- )
+ (fuel-get-vocabs) fuel-eval-set-result ; inline
+
+MEMO: (fuel-vocab-words) ( name -- seq )
+ >vocab-link words [ name>> ] map ;
+
+: fuel-current-words ( -- seq )
+ use get [ keys ] map concat ; inline
+
+: fuel-vocabs-words ( names -- seq )
+ prune [ (fuel-vocab-words) ] map concat ; inline
+
+: (fuel-get-words) ( prefix names/f -- seq )
+ [ fuel-vocabs-words ] [ fuel-current-words ] if* natural-sort
+ swap [ drop-prefix nip length 0 = ] curry filter ;
+
+: fuel-get-words ( prefix names -- )
+ (fuel-get-words) fuel-eval-set-result ; inline
: fuel-run-file ( path -- ) run-file ; inline
-: fuel-startup ( -- ) "listener" run ; inline
+: fuel-startup ( -- ) "listener" run-file ; inline
MAIN: fuel-startup
+++ /dev/null
-USING: eval multiline system combinators ;
-IN: game-input.backend
-
-STRING: set-backend-for-macosx
-USING: namespaces parser game-input.backend.iokit ;
-<< "game-input" (use+) >>
-iokit-game-input-backend game-input-backend set-global
-;
-
-STRING: set-backend-for-windows
-USING: namespaces parser game-input.backend.dinput ;
-<< "game-input" (use+) >>
-dinput-game-input-backend game-input-backend set-global
-;
-
-{
- { [ os macosx? ] [ set-backend-for-macosx eval ] }
- { [ os windows? ] [ set-backend-for-windows eval ] }
- { [ t ] [ ] }
-} cond
-
+++ /dev/null
-USING: windows.dinput windows.dinput.constants parser symbols
-alien.c-types windows.ole32 namespaces assocs kernel arrays
-vectors windows.kernel32 windows.com windows.dinput shuffle
-windows.user32 windows.messages sequences combinators
-math.geometry.rect ui.windows accessors math windows alien
-alien.strings io.encodings.utf16 io.encodings.utf16n
-continuations byte-arrays locals
-game-input.backend.dinput.keys-array ;
-<< "game-input" (use+) >>
-IN: game-input.backend.dinput
-
-SINGLETON: dinput-game-input-backend
-
-SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
- +controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+ ;
-
-: create-dinput ( -- )
- f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
- f <void*> [ f DirectInput8Create ole32-error ] keep *void*
- +dinput+ set-global ;
-
-: delete-dinput ( -- )
- +dinput+ global [ com-release f ] change-at ;
-
-: device-for-guid ( guid -- device )
- +dinput+ get swap f <void*>
- [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
-
-: set-coop-level ( device -- )
- +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
- IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
-
-: set-data-format ( device format-symbol -- )
- get IDirectInputDevice8W::SetDataFormat ole32-error ;
-
-: configure-keyboard ( keyboard -- )
- [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
-: configure-controller ( controller -- )
- [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
-
-: find-keyboard ( -- )
- GUID_SysKeyboard device-for-guid
- [ configure-keyboard ]
- [ +keyboard-device+ set-global ] bi
- 256 <byte-array> <keys-array> keyboard-state boa
- +keyboard-state+ set-global ;
-
-: device-info ( device -- DIDEVICEIMAGEINFOW )
- "DIDEVICEINSTANCEW" <c-object>
- "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
- [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
-: device-caps ( device -- DIDEVCAPS )
- "DIDEVCAPS" <c-object>
- "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
- [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
-
-: <guid> ( memory -- byte-array )
- "GUID" heap-size memory>byte-array ;
-
-: device-guid ( device -- guid )
- device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
-
-: device-attached? ( device -- ? )
- +dinput+ get swap device-guid
- IDirectInput8W::GetDeviceStatus S_OK = ;
-
-: find-device-axes-callback ( -- alien )
- [ ! ( lpddoi pvRef -- BOOL )
- +controller-devices+ get at
- swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
- { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
- { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
- { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
- { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
- { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
- { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
- { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
- [ drop ]
- } cond drop
- DIENUM_CONTINUE
- ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
-
-: find-device-axes ( device controller-state -- controller-state )
- swap [ +controller-devices+ get set-at ] 2keep
- find-device-axes-callback over DIDFT_AXIS
- IDirectInputDevice8W::EnumObjects ole32-error ;
-
-: controller-state-template ( device -- controller-state )
- controller-state new
- over device-caps
- [ DIDEVCAPS-dwButtons f <array> >>buttons ]
- [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
- find-device-axes ;
-
-: device-known? ( guid -- ? )
- +controller-guids+ get key? ; inline
-
-: (add-controller) ( guid -- )
- device-for-guid {
- [ configure-controller ]
- [ controller-state-template ]
- [ dup device-guid +controller-guids+ get set-at ]
- [ +controller-devices+ get set-at ]
- } cleave ;
-
-: add-controller ( guid -- )
- dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
-
-: remove-controller ( device -- )
- [ +controller-devices+ get delete-at ]
- [ device-guid +controller-guids+ get delete-at ]
- [ com-release ] tri ;
-
-: find-controller-callback ( -- alien )
- [ ! ( lpddi pvRef -- BOOL )
- drop DIDEVICEINSTANCEW-guidInstance add-controller
- DIENUM_CONTINUE
- ] LPDIENUMDEVICESCALLBACKW ;
-
-: find-controllers ( -- )
- +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
- f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
-
-: set-up-controllers ( -- )
- 4 <vector> +controller-devices+ set-global
- 4 <vector> +controller-guids+ set-global
- find-controllers ;
-
-: find-and-remove-detached-devices ( -- )
- +controller-devices+ get keys
- [ device-attached? not ] filter
- [ remove-controller ] each ;
-
-: device-interface? ( dbt-broadcast-hdr -- ? )
- DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
-
-: device-arrived ( dbt-broadcast-hdr -- )
- device-interface? [ find-controllers ] when ;
-
-: device-removed ( dbt-broadcast-hdr -- )
- device-interface? [ find-and-remove-detached-devices ] when ;
-
-: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
- [ 2drop ] 2dip swap {
- { [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
- { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
- [ 2drop ]
- } cond ;
-
-TUPLE: window-rect < rect window-loc ;
-: <zero-window-rect> ( -- window-rect )
- window-rect new
- { 0 0 } >>window-loc
- { 0 0 } >>loc
- { 0 0 } >>dim ;
-
-: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
- "DEV_BROADCAST_DEVICEW" <c-object>
- "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
- DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
-
-: create-device-change-window ( -- )
- <zero-window-rect> create-window
- [
- (device-notification-filter)
- DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
- RegisterDeviceNotification
- +device-change-handle+ set-global
- ]
- [ +device-change-window+ set-global ] bi ;
-
-: close-device-change-window ( -- )
- +device-change-handle+ global
- [ UnregisterDeviceNotification drop f ] change-at
- +device-change-window+ global
- [ DestroyWindow win32-error=0/f f ] change-at ;
-
-: add-wm-devicechange ( -- )
- [ 4dup handle-wm-devicechange DefWindowProc ]
- WM_DEVICECHANGE add-wm-handler ;
-
-: remove-wm-devicechange ( -- )
- WM_DEVICECHANGE wm-handlers get-global delete-at ;
-
-: release-controllers ( -- )
- +controller-devices+ global [
- [ drop com-release ] assoc-each f
- ] change-at
- f +controller-guids+ set-global ;
-
-: release-keyboard ( -- )
- +keyboard-device+ global
- [ com-release f ] change-at
- f +keyboard-state+ set-global ;
-
-M: dinput-game-input-backend (open-game-input)
- create-dinput
- create-device-change-window
- find-keyboard
- set-up-controllers
- add-wm-devicechange ;
-
-M: dinput-game-input-backend (close-game-input)
- remove-wm-devicechange
- release-controllers
- release-keyboard
- close-device-change-window
- delete-dinput ;
-
-M: dinput-game-input-backend (reset-game-input)
- {
- +dinput+ +keyboard-device+ +keyboard-state+
- +controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+
- } [ f swap set-global ] each ;
-
-M: dinput-game-input-backend get-controllers
- +controller-devices+ get
- [ drop controller boa ] { } assoc>map ;
-
-M: dinput-game-input-backend product-string
- handle>> device-info DIDEVICEINSTANCEW-tszProductName
- utf16n alien>string ;
-
-M: dinput-game-input-backend product-id
- handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
-M: dinput-game-input-backend instance-id
- handle>> device-guid ;
-
-:: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
- device IDirectInputDevice8W::Acquire succeeded? [
- device acquired-quot call
- succeeded-quot call
- ] failed-quot if ; inline
-
-: pov-values
- {
- pov-up pov-up-right pov-right pov-down-right
- pov-down pov-down-left pov-left pov-up-left
- } ; inline
-
-: >axis ( long -- float )
- 32767 - 32767.0 /f ;
-: >slider ( long -- float )
- 65535.0 /f ;
-: >pov ( long -- symbol )
- dup HEX: FFFF bitand HEX: FFFF =
- [ drop pov-neutral ]
- [ 2750 + 4500 /i pov-values nth ] if ;
-: >buttons ( alien length -- array )
- memory>byte-array <keys-array> ;
-
-: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
- [ drop ] compose [ 2drop ] if ; inline
-
-: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
- {
- [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
- [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
- [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
- [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
- [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
- [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
- [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
- [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
- [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
- } 2cleave ;
-
-: get-device-state ( device byte-array -- )
- [ dup IDirectInputDevice8W::Poll ole32-error ] dip
- [ length ] keep
- IDirectInputDevice8W::GetDeviceState ole32-error ;
-
-: (read-controller) ( handle template -- state )
- swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
- [ fill-controller-state ] [ drop f ] with-acquisition ;
-
-M: dinput-game-input-backend read-controller
- handle>> dup +controller-devices+ get at
- [ (read-controller) ] [ drop f ] if* ;
-
-M: dinput-game-input-backend calibrate-controller
- handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
-
-M: dinput-game-input-backend read-keyboard
- +keyboard-device+ get
- [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
- [ ] [ f ] with-acquisition ;
+++ /dev/null
-USING: sequences sequences.private math alien.c-types
-accessors ;
-IN: game-input.backend.dinput.keys-array
-
-TUPLE: keys-array underlying ;
-C: <keys-array> keys-array
-
-: >key ( byte -- ? )
- HEX: 80 bitand c-bool> ;
-
-M: keys-array length underlying>> length ;
-M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
-
-INSTANCE: keys-array sequence
-
+++ /dev/null
-DirectInput backend for game-input
+++ /dev/null
-unportable
-games
+++ /dev/null
-USING: cocoa cocoa.plists core-foundation iokit iokit.hid
-kernel cocoa.enumeration destructors math.parser cocoa.application
-sequences locals combinators.short-circuit threads
-symbols namespaces assocs vectors arrays combinators
-core-foundation.run-loop accessors sequences.private
-alien.c-types math parser ;
-<< "game-input" (use+) >>
-IN: game-input.backend.iokit
-
-SINGLETON: iokit-game-input-backend
-
-: hid-manager-matching ( matching-seq -- alien )
- f 0 IOHIDManagerCreate
- [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
- keep ;
-
-: devices-from-hid-manager ( manager -- vector )
- [
- IOHIDManagerCopyDevices
- [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
- ] with-destructors ;
-
-: game-devices-matching-seq
- {
- H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
- H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
- H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
- } ; inline
-
-: buttons-matching-hash
- H{ { "UsagePage" 9 } { "Type" 2 } } ; inline
-: keys-matching-hash
- H{ { "UsagePage" 7 } { "Type" 2 } } ; inline
-: x-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } } ; inline
-: y-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } } ; inline
-: z-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } } ; inline
-: rx-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } } ; inline
-: ry-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } } ; inline
-: rz-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } ; inline
-: slider-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } ; inline
-: hat-switch-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } ; inline
-
-: device-elements-matching ( device matching-hash -- vector )
- [
- >plist 0 IOHIDDeviceCopyMatchingElements
- [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
- ] with-destructors ;
-
-: button-count ( device -- button-count )
- buttons-matching-hash device-elements-matching length ;
-
-: ?axis ( device hash -- axis/f )
- device-elements-matching [ f ] [ first ] if-empty ;
-
-: ?x-axis ( device -- ? )
- x-axis-matching-hash ?axis ;
-: ?y-axis ( device -- ? )
- y-axis-matching-hash ?axis ;
-: ?z-axis ( device -- ? )
- z-axis-matching-hash ?axis ;
-: ?rx-axis ( device -- ? )
- rx-axis-matching-hash ?axis ;
-: ?ry-axis ( device -- ? )
- ry-axis-matching-hash ?axis ;
-: ?rz-axis ( device -- ? )
- rz-axis-matching-hash ?axis ;
-: ?slider ( device -- ? )
- slider-matching-hash ?axis ;
-: ?hat-switch ( device -- ? )
- hat-switch-matching-hash ?axis ;
-
-: hid-manager-matching-game-devices ( -- alien )
- game-devices-matching-seq hid-manager-matching ;
-
-: device-property ( device key -- value )
- <NSString> IOHIDDeviceGetProperty plist> ;
-: element-property ( element key -- value )
- <NSString> IOHIDElementGetProperty plist> ;
-: set-element-property ( element key value -- )
- [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
-: transfer-element-property ( element from-key to-key -- )
- [ dupd element-property ] dip swap set-element-property ;
-
-: controller-device? ( device -- ? )
- {
- [ 1 4 IOHIDDeviceConformsTo ]
- [ 1 5 IOHIDDeviceConformsTo ]
- } 1|| ;
-
-: element-usage ( element -- {usage-page,usage} )
- [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
- 2array ;
-
-: button? ( {usage-page,usage} -- ? )
- first 9 = ; inline
-: keyboard-key? ( {usage-page,usage} -- ? )
- first 7 = ; inline
-: x-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 30 } = ; inline
-: y-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 31 } = ; inline
-: z-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 32 } = ; inline
-: rx-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 33 } = ; inline
-: ry-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 34 } = ; inline
-: rz-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 35 } = ; inline
-: slider? ( {usage-page,usage} -- ? )
- { 1 HEX: 36 } = ; inline
-: hat-switch? ( {usage-page,usage} -- ? )
- { 1 HEX: 39 } = ; inline
-
-: pov-values
- {
- pov-up pov-up-right pov-right pov-down-right
- pov-down pov-down-left pov-left pov-up-left
- pov-neutral
- } ; inline
-
-: button-value ( value -- f/(0,1] )
- IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
-: axis-value ( value -- [-1,1] )
- kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
-: pov-value ( value -- pov-direction )
- IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
-
-: record-controller ( controller-state value -- )
- dup IOHIDValueGetElement element-usage {
- { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
- { [ dup x-axis? ] [ drop axis-value >>x drop ] }
- { [ dup y-axis? ] [ drop axis-value >>y drop ] }
- { [ dup z-axis? ] [ drop axis-value >>z drop ] }
- { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
- { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
- { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
- { [ dup slider? ] [ drop axis-value >>slider drop ] }
- { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
- [ 3drop ]
- } cond ;
-
-SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
-
-: ?set-nth ( value nth seq -- )
- 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
-
-: record-keyboard ( value -- )
- dup IOHIDValueGetElement element-usage keyboard-key? [
- [ IOHIDValueGetIntegerValue c-bool> ]
- [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
- +keyboard-state+ get ?set-nth
- ] [ drop ] if ;
-
-: default-calibrate-saturation ( element -- )
- [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
- [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
- bi ;
-
-: default-calibrate-axis ( element -- )
- [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
- [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
- [ default-calibrate-saturation ]
- tri ;
-
-: default-calibrate-slider ( element -- )
- [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
- [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
- [ default-calibrate-saturation ]
- tri ;
-
-: (default) ( ? quot -- )
- [ f ] if* ; inline
-
-: <device-controller-state> ( device -- controller-state )
- {
- [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
- [ ?hat-switch pov-neutral and ]
- [ button-count f <array> ]
- } cleave controller-state boa ;
-
-: device-matched-callback ( -- alien )
- [| context result sender device |
- device controller-device? [
- device <device-controller-state>
- device +controller-states+ get set-at
- ] when
- ] IOHIDDeviceCallback ;
-
-: device-removed-callback ( -- alien )
- [| context result sender device |
- device +controller-states+ get delete-at
- ] IOHIDDeviceCallback ;
-
-: device-input-callback ( -- alien )
- [| context result sender value |
- sender controller-device?
- [ sender +controller-states+ get at value record-controller ]
- [ value record-keyboard ]
- if
- ] IOHIDValueCallback ;
-
-: initialize-variables ( manager -- )
- +hid-manager+ set-global
- 4 <vector> +controller-states+ set-global
- 256 f <array> +keyboard-state+ set-global ;
-
-M: iokit-game-input-backend (open-game-input)
- hid-manager-matching-game-devices {
- [ initialize-variables ]
- [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
- [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
- [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
- [ 0 IOHIDManagerOpen mach-error ]
- [
- CFRunLoopGetMain CFRunLoopDefaultMode
- IOHIDManagerScheduleWithRunLoop
- ]
- } cleave ;
-
-M: iokit-game-input-backend (reset-game-input)
- { +hid-manager+ +keyboard-state+ +controller-states+ }
- [ f swap set-global ] each ;
-
-M: iokit-game-input-backend (close-game-input)
- +hid-manager+ get-global [
- +hid-manager+ global [
- [
- CFRunLoopGetMain CFRunLoopDefaultMode
- IOHIDManagerUnscheduleFromRunLoop
- ]
- [ 0 IOHIDManagerClose drop ]
- [ CFRelease ] tri
- f
- ] change-at
- f +keyboard-state+ set-global
- f +controller-states+ set-global
- ] when ;
-
-M: iokit-game-input-backend get-controllers ( -- sequence )
- +controller-states+ get keys [ controller boa ] map ;
-
-: ?join ( pre post sep -- string )
- 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
-
-M: iokit-game-input-backend product-string ( controller -- string )
- handle>>
- [ kIOHIDManufacturerKey device-property ]
- [ kIOHIDProductKey device-property ] bi " " ?join ;
-M: iokit-game-input-backend product-id ( controller -- integer )
- handle>>
- [ kIOHIDVendorIDKey device-property ]
- [ kIOHIDProductIDKey device-property ] bi 2array ;
-M: iokit-game-input-backend instance-id ( controller -- integer )
- handle>> kIOHIDLocationIDKey device-property ;
-
-M: iokit-game-input-backend read-controller ( controller -- controller-state )
- handle>> +controller-states+ get at clone ;
-
-M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
- +keyboard-state+ get clone keyboard-state boa ;
-
-M: iokit-game-input-backend calibrate-controller ( controller -- )
- drop ;
+++ /dev/null
-IOKit HID Manager backend for game-input
+++ /dev/null
-unportable
-games
+++ /dev/null
-Platform-specific backends for game-input
--- /dev/null
+USING: windows.dinput windows.dinput.constants parser
+alien.c-types windows.ole32 namespaces assocs kernel arrays
+vectors windows.kernel32 windows.com windows.dinput shuffle
+windows.user32 windows.messages sequences combinators locals
+math.geometry.rect ui.windows accessors math windows alien
+alien.strings io.encodings.utf16 io.encodings.utf16n
+continuations byte-arrays game-input.dinput.keys-array
+game-input ;
+IN: game-input.dinput
+
+SINGLETON: dinput-game-input-backend
+
+dinput-game-input-backend game-input-backend set-global
+
+SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+ ;
+
+: create-dinput ( -- )
+ f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
+ f <void*> [ f DirectInput8Create ole32-error ] keep *void*
+ +dinput+ set-global ;
+
+: delete-dinput ( -- )
+ +dinput+ global [ com-release f ] change-at ;
+
+: device-for-guid ( guid -- device )
+ +dinput+ get swap f <void*>
+ [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
+
+: set-coop-level ( device -- )
+ +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
+ IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
+
+: set-data-format ( device format-symbol -- )
+ get IDirectInputDevice8W::SetDataFormat ole32-error ;
+
+: configure-keyboard ( keyboard -- )
+ [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
+: configure-controller ( controller -- )
+ [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
+
+: find-keyboard ( -- )
+ GUID_SysKeyboard device-for-guid
+ [ configure-keyboard ]
+ [ +keyboard-device+ set-global ] bi
+ 256 <byte-array> <keys-array> keyboard-state boa
+ +keyboard-state+ set-global ;
+
+: device-info ( device -- DIDEVICEIMAGEINFOW )
+ "DIDEVICEINSTANCEW" <c-object>
+ "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
+ [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
+: device-caps ( device -- DIDEVCAPS )
+ "DIDEVCAPS" <c-object>
+ "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
+ [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
+
+: <guid> ( memory -- byte-array )
+ "GUID" heap-size memory>byte-array ;
+
+: device-guid ( device -- guid )
+ device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
+
+: device-attached? ( device -- ? )
+ +dinput+ get swap device-guid
+ IDirectInput8W::GetDeviceStatus S_OK = ;
+
+: find-device-axes-callback ( -- alien )
+ [ ! ( lpddoi pvRef -- BOOL )
+ +controller-devices+ get at
+ swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
+ { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
+ { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
+ { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
+ { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
+ { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
+ { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
+ { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
+ [ drop ]
+ } cond drop
+ DIENUM_CONTINUE
+ ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
+
+: find-device-axes ( device controller-state -- controller-state )
+ swap [ +controller-devices+ get set-at ] 2keep
+ find-device-axes-callback over DIDFT_AXIS
+ IDirectInputDevice8W::EnumObjects ole32-error ;
+
+: controller-state-template ( device -- controller-state )
+ controller-state new
+ over device-caps
+ [ DIDEVCAPS-dwButtons f <array> >>buttons ]
+ [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
+ find-device-axes ;
+
+: device-known? ( guid -- ? )
+ +controller-guids+ get key? ; inline
+
+: (add-controller) ( guid -- )
+ device-for-guid {
+ [ configure-controller ]
+ [ controller-state-template ]
+ [ dup device-guid +controller-guids+ get set-at ]
+ [ +controller-devices+ get set-at ]
+ } cleave ;
+
+: add-controller ( guid -- )
+ dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
+
+: remove-controller ( device -- )
+ [ +controller-devices+ get delete-at ]
+ [ device-guid +controller-guids+ get delete-at ]
+ [ com-release ] tri ;
+
+: find-controller-callback ( -- alien )
+ [ ! ( lpddi pvRef -- BOOL )
+ drop DIDEVICEINSTANCEW-guidInstance add-controller
+ DIENUM_CONTINUE
+ ] LPDIENUMDEVICESCALLBACKW ;
+
+: find-controllers ( -- )
+ +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
+ f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
+
+: set-up-controllers ( -- )
+ 4 <vector> +controller-devices+ set-global
+ 4 <vector> +controller-guids+ set-global
+ find-controllers ;
+
+: find-and-remove-detached-devices ( -- )
+ +controller-devices+ get keys
+ [ device-attached? not ] filter
+ [ remove-controller ] each ;
+
+: device-interface? ( dbt-broadcast-hdr -- ? )
+ DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
+
+: device-arrived ( dbt-broadcast-hdr -- )
+ device-interface? [ find-controllers ] when ;
+
+: device-removed ( dbt-broadcast-hdr -- )
+ device-interface? [ find-and-remove-detached-devices ] when ;
+
+: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
+ [ 2drop ] 2dip swap {
+ { [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
+ { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
+ [ 2drop ]
+ } cond ;
+
+TUPLE: window-rect < rect window-loc ;
+: <zero-window-rect> ( -- window-rect )
+ window-rect new
+ { 0 0 } >>window-loc
+ { 0 0 } >>loc
+ { 0 0 } >>dim ;
+
+: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
+ "DEV_BROADCAST_DEVICEW" <c-object>
+ "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
+ DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
+
+: create-device-change-window ( -- )
+ <zero-window-rect> create-window
+ [
+ (device-notification-filter)
+ DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
+ RegisterDeviceNotification
+ +device-change-handle+ set-global
+ ]
+ [ +device-change-window+ set-global ] bi ;
+
+: close-device-change-window ( -- )
+ +device-change-handle+ global
+ [ UnregisterDeviceNotification drop f ] change-at
+ +device-change-window+ global
+ [ DestroyWindow win32-error=0/f f ] change-at ;
+
+: add-wm-devicechange ( -- )
+ [ 4dup handle-wm-devicechange DefWindowProc ]
+ WM_DEVICECHANGE add-wm-handler ;
+
+: remove-wm-devicechange ( -- )
+ WM_DEVICECHANGE wm-handlers get-global delete-at ;
+
+: release-controllers ( -- )
+ +controller-devices+ global [
+ [ drop com-release ] assoc-each f
+ ] change-at
+ f +controller-guids+ set-global ;
+
+: release-keyboard ( -- )
+ +keyboard-device+ global
+ [ com-release f ] change-at
+ f +keyboard-state+ set-global ;
+
+M: dinput-game-input-backend (open-game-input)
+ create-dinput
+ create-device-change-window
+ find-keyboard
+ set-up-controllers
+ add-wm-devicechange ;
+
+M: dinput-game-input-backend (close-game-input)
+ remove-wm-devicechange
+ release-controllers
+ release-keyboard
+ close-device-change-window
+ delete-dinput ;
+
+M: dinput-game-input-backend (reset-game-input)
+ {
+ +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+
+ } [ f swap set-global ] each ;
+
+M: dinput-game-input-backend get-controllers
+ +controller-devices+ get
+ [ drop controller boa ] { } assoc>map ;
+
+M: dinput-game-input-backend product-string
+ handle>> device-info DIDEVICEINSTANCEW-tszProductName
+ utf16n alien>string ;
+
+M: dinput-game-input-backend product-id
+ handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
+M: dinput-game-input-backend instance-id
+ handle>> device-guid ;
+
+:: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
+ device IDirectInputDevice8W::Acquire succeeded? [
+ device acquired-quot call
+ succeeded-quot call
+ ] failed-quot if ; inline
+
+: pov-values
+ {
+ pov-up pov-up-right pov-right pov-down-right
+ pov-down pov-down-left pov-left pov-up-left
+ } ; inline
+
+: >axis ( long -- float )
+ 32767 - 32767.0 /f ;
+: >slider ( long -- float )
+ 65535.0 /f ;
+: >pov ( long -- symbol )
+ dup HEX: FFFF bitand HEX: FFFF =
+ [ drop pov-neutral ]
+ [ 2750 + 4500 /i pov-values nth ] if ;
+: >buttons ( alien length -- array )
+ memory>byte-array <keys-array> ;
+
+: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
+ [ drop ] compose [ 2drop ] if ; inline
+
+: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
+ {
+ [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
+ [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
+ [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
+ [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
+ [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
+ [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
+ [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
+ [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
+ [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
+ } 2cleave ;
+
+: get-device-state ( device byte-array -- )
+ [ dup IDirectInputDevice8W::Poll ole32-error ] dip
+ [ length ] keep
+ IDirectInputDevice8W::GetDeviceState ole32-error ;
+
+: (read-controller) ( handle template -- state )
+ swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
+ [ fill-controller-state ] [ drop f ] with-acquisition ;
+
+M: dinput-game-input-backend read-controller
+ handle>> dup +controller-devices+ get at
+ [ (read-controller) ] [ drop f ] if* ;
+
+M: dinput-game-input-backend calibrate-controller
+ handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
+
+M: dinput-game-input-backend read-keyboard
+ +keyboard-device+ get
+ [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
+ [ ] [ f ] with-acquisition ;
--- /dev/null
+USING: sequences sequences.private math alien.c-types
+accessors ;
+IN: game-input.dinput.keys-array
+
+TUPLE: keys-array underlying ;
+C: <keys-array> keys-array
+
+: >key ( byte -- ? )
+ HEX: 80 bitand c-bool> ;
+
+M: keys-array length underlying>> length ;
+M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
+
+INSTANCE: keys-array sequence
+
--- /dev/null
+DirectInput backend for game-input
--- /dev/null
+unportable
+games
-USING: arrays accessors continuations kernel symbols
-combinators.lib sequences namespaces init vocabs ;
+USING: arrays accessors continuations kernel system
+combinators.lib sequences namespaces init vocabs vocabs.loader
+combinators ;
IN: game-input
SYMBOLS: game-input-backend game-input-opened ;
game-input-opened off
(reset-game-input) ;
-: load-game-input-backend ( -- )
- game-input-backend get
- [ "game-input.backend" load-vocab drop ] unless ;
-
[ reset-game-input ] "game-input" add-init-hook
PRIVATE>
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
-load-game-input-backend
-
+{
+ { [ os windows? ] [ "game-input.dinput" require ] }
+ { [ os macosx? ] [ "game-input.iokit" require ] }
+ { [ t ] [ ] }
+} cond
--- /dev/null
+USING: cocoa cocoa.plists core-foundation iokit iokit.hid
+kernel cocoa.enumeration destructors math.parser cocoa.application
+sequences locals combinators.short-circuit threads
+symbols namespaces assocs vectors arrays combinators
+core-foundation.run-loop accessors sequences.private
+alien.c-types math parser game-input ;
+IN: game-input.iokit
+
+SINGLETON: iokit-game-input-backend
+
+iokit-game-input-backend game-input-backend set-global
+
+: hid-manager-matching ( matching-seq -- alien )
+ f 0 IOHIDManagerCreate
+ [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
+ keep ;
+
+: devices-from-hid-manager ( manager -- vector )
+ [
+ IOHIDManagerCopyDevices
+ [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
+ ] with-destructors ;
+
+: game-devices-matching-seq
+ {
+ H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
+ H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
+ H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
+ } ; inline
+
+: buttons-matching-hash
+ H{ { "UsagePage" 9 } { "Type" 2 } } ; inline
+: keys-matching-hash
+ H{ { "UsagePage" 7 } { "Type" 2 } } ; inline
+: x-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } } ; inline
+: y-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } } ; inline
+: z-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } } ; inline
+: rx-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } } ; inline
+: ry-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } } ; inline
+: rz-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } ; inline
+: slider-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } ; inline
+: hat-switch-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } ; inline
+
+: device-elements-matching ( device matching-hash -- vector )
+ [
+ >plist 0 IOHIDDeviceCopyMatchingElements
+ [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
+ ] with-destructors ;
+
+: button-count ( device -- button-count )
+ buttons-matching-hash device-elements-matching length ;
+
+: ?axis ( device hash -- axis/f )
+ device-elements-matching [ f ] [ first ] if-empty ;
+
+: ?x-axis ( device -- ? )
+ x-axis-matching-hash ?axis ;
+: ?y-axis ( device -- ? )
+ y-axis-matching-hash ?axis ;
+: ?z-axis ( device -- ? )
+ z-axis-matching-hash ?axis ;
+: ?rx-axis ( device -- ? )
+ rx-axis-matching-hash ?axis ;
+: ?ry-axis ( device -- ? )
+ ry-axis-matching-hash ?axis ;
+: ?rz-axis ( device -- ? )
+ rz-axis-matching-hash ?axis ;
+: ?slider ( device -- ? )
+ slider-matching-hash ?axis ;
+: ?hat-switch ( device -- ? )
+ hat-switch-matching-hash ?axis ;
+
+: hid-manager-matching-game-devices ( -- alien )
+ game-devices-matching-seq hid-manager-matching ;
+
+: device-property ( device key -- value )
+ <NSString> IOHIDDeviceGetProperty plist> ;
+: element-property ( element key -- value )
+ <NSString> IOHIDElementGetProperty plist> ;
+: set-element-property ( element key value -- )
+ [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
+: transfer-element-property ( element from-key to-key -- )
+ [ dupd element-property ] dip swap set-element-property ;
+
+: controller-device? ( device -- ? )
+ {
+ [ 1 4 IOHIDDeviceConformsTo ]
+ [ 1 5 IOHIDDeviceConformsTo ]
+ } 1|| ;
+
+: element-usage ( element -- {usage-page,usage} )
+ [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
+ 2array ;
+
+: button? ( {usage-page,usage} -- ? )
+ first 9 = ; inline
+: keyboard-key? ( {usage-page,usage} -- ? )
+ first 7 = ; inline
+: x-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 30 } = ; inline
+: y-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 31 } = ; inline
+: z-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 32 } = ; inline
+: rx-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 33 } = ; inline
+: ry-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 34 } = ; inline
+: rz-axis? ( {usage-page,usage} -- ? )
+ { 1 HEX: 35 } = ; inline
+: slider? ( {usage-page,usage} -- ? )
+ { 1 HEX: 36 } = ; inline
+: hat-switch? ( {usage-page,usage} -- ? )
+ { 1 HEX: 39 } = ; inline
+
+: pov-values
+ {
+ pov-up pov-up-right pov-right pov-down-right
+ pov-down pov-down-left pov-left pov-up-left
+ pov-neutral
+ } ; inline
+
+: button-value ( value -- f/(0,1] )
+ IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
+: axis-value ( value -- [-1,1] )
+ kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
+: pov-value ( value -- pov-direction )
+ IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
+
+: record-controller ( controller-state value -- )
+ dup IOHIDValueGetElement element-usage {
+ { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
+ { [ dup x-axis? ] [ drop axis-value >>x drop ] }
+ { [ dup y-axis? ] [ drop axis-value >>y drop ] }
+ { [ dup z-axis? ] [ drop axis-value >>z drop ] }
+ { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
+ { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
+ { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
+ { [ dup slider? ] [ drop axis-value >>slider drop ] }
+ { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+ [ 3drop ]
+ } cond ;
+
+SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
+
+: ?set-nth ( value nth seq -- )
+ 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
+
+: record-keyboard ( value -- )
+ dup IOHIDValueGetElement element-usage keyboard-key? [
+ [ IOHIDValueGetIntegerValue c-bool> ]
+ [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
+ +keyboard-state+ get ?set-nth
+ ] [ drop ] if ;
+
+: default-calibrate-saturation ( element -- )
+ [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
+ [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
+ bi ;
+
+: default-calibrate-axis ( element -- )
+ [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
+ [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
+ [ default-calibrate-saturation ]
+ tri ;
+
+: default-calibrate-slider ( element -- )
+ [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
+ [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
+ [ default-calibrate-saturation ]
+ tri ;
+
+: (default) ( ? quot -- )
+ [ f ] if* ; inline
+
+: <device-controller-state> ( device -- controller-state )
+ {
+ [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
+ [ ?hat-switch pov-neutral and ]
+ [ button-count f <array> ]
+ } cleave controller-state boa ;
+
+: device-matched-callback ( -- alien )
+ [| context result sender device |
+ device controller-device? [
+ device <device-controller-state>
+ device +controller-states+ get set-at
+ ] when
+ ] IOHIDDeviceCallback ;
+
+: device-removed-callback ( -- alien )
+ [| context result sender device |
+ device +controller-states+ get delete-at
+ ] IOHIDDeviceCallback ;
+
+: device-input-callback ( -- alien )
+ [| context result sender value |
+ sender controller-device?
+ [ sender +controller-states+ get at value record-controller ]
+ [ value record-keyboard ]
+ if
+ ] IOHIDValueCallback ;
+
+: initialize-variables ( manager -- )
+ +hid-manager+ set-global
+ 4 <vector> +controller-states+ set-global
+ 256 f <array> +keyboard-state+ set-global ;
+
+M: iokit-game-input-backend (open-game-input)
+ hid-manager-matching-game-devices {
+ [ initialize-variables ]
+ [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
+ [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
+ [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
+ [ 0 IOHIDManagerOpen mach-error ]
+ [
+ CFRunLoopGetMain CFRunLoopDefaultMode
+ IOHIDManagerScheduleWithRunLoop
+ ]
+ } cleave ;
+
+M: iokit-game-input-backend (reset-game-input)
+ { +hid-manager+ +keyboard-state+ +controller-states+ }
+ [ f swap set-global ] each ;
+
+M: iokit-game-input-backend (close-game-input)
+ +hid-manager+ get-global [
+ +hid-manager+ global [
+ [
+ CFRunLoopGetMain CFRunLoopDefaultMode
+ IOHIDManagerUnscheduleFromRunLoop
+ ]
+ [ 0 IOHIDManagerClose drop ]
+ [ CFRelease ] tri
+ f
+ ] change-at
+ f +keyboard-state+ set-global
+ f +controller-states+ set-global
+ ] when ;
+
+M: iokit-game-input-backend get-controllers ( -- sequence )
+ +controller-states+ get keys [ controller boa ] map ;
+
+: ?join ( pre post sep -- string )
+ 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
+
+M: iokit-game-input-backend product-string ( controller -- string )
+ handle>>
+ [ kIOHIDManufacturerKey device-property ]
+ [ kIOHIDProductKey device-property ] bi " " ?join ;
+M: iokit-game-input-backend product-id ( controller -- integer )
+ handle>>
+ [ kIOHIDVendorIDKey device-property ]
+ [ kIOHIDProductIDKey device-property ] bi 2array ;
+M: iokit-game-input-backend instance-id ( controller -- integer )
+ handle>> kIOHIDLocationIDKey device-property ;
+
+M: iokit-game-input-backend read-controller ( controller -- controller-state )
+ handle>> +controller-states+ get at clone ;
+
+M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
+ +keyboard-state+ get clone keyboard-state boa ;
+
+M: iokit-game-input-backend calibrate-controller ( controller -- )
+ drop ;
--- /dev/null
+IOKit HID Manager backend for game-input
--- /dev/null
+unportable
+games
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences io.files io.launcher io.encodings.ascii
-io.streams.string http.client generalizations combinators
-math.parser math.vectors math.intervals interval-maps memoize
-csv accessors assocs strings math splitting grouping arrays ;
+USING: kernel sequences io.files io.files.temp io.launcher
+io.pathnames io.encodings.ascii io.streams.string http.client
+generalizations combinators math.parser math.vectors
+math.intervals interval-maps memoize csv accessors assocs
+strings math splitting grouping arrays ;
IN: geo-ip
: db-path ( -- path ) "IpToCountry.csv" temp-file ;
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays byte-arrays combinators summary io.backend
+USING: alien arrays byte-arrays combinators summary
graphics.viewer io io.binary io.files kernel libc math
math.functions math.bitwise namespaces opengl opengl.gl
prettyprint sequences strings ui ui.gadgets.panes fry
dup color-index-length read >>color-index drop ;
: load-bitmap ( path -- bitmap )
- normalize-path binary [
+ binary [
bitmap new
dup parse-file-header
dup parse-bitmap-header
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
- swap [ >r first2 r> find-between* ] curry map
+ swap [ [ first2 ] dip find-between* ] curry map
[ [ name>> { "form" "input" } member? ] filter ] map ;
: find-html-objects ( vector string -- vector' )
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors
-combinators.short-circuit fry qualified ;
+combinators.short-circuit fry ;
RENAME: _ fry => __
IN: inverse
ERROR: invalid-baud baud ;
M: invalid-baud summary ( invalid-baud -- string )
- "Baud rate "
- swap baud>> number>string
- " not supported" 3append ;
+ baud>> number>string
+ "Baud rate " " not supported" surround ;
HOOK: lookup-baud os ( m -- n )
HOOK: open-serial os ( serial -- stream )
: kIOHIDElementDuplicateIndexKey "DuplicateIndex" ; inline
: kIOHIDElementParentCollectionKey "ParentCollection" ; inline
-: kIOHIDElementVendorSpecificKey
+: kIOHIDElementVendorSpecificKey ( -- str )
cpu ppc? "VendorSpecifc" "VendorSpecific" ? ; inline
: kIOHIDElementCookieMinKey "ElementCookieMin" ; inline
-USING: kernel tools.test accessors arrays sequences qualified
+USING: kernel tools.test accessors arrays sequences
io io.streams.duplex namespaces threads destructors
calendar irc.client.private irc.client irc.messages.private
concurrency.mailboxes classes assocs combinators ;
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
- accessors destructors namespaces io assocs arrays qualified fry
+ accessors destructors namespaces io assocs arrays fry
continuations threads strings classes combinators splitting hashtables
ascii irc.messages ;
RENAME: join sequences => sjoin
-USING: kernel tools.test accessors arrays qualified
+USING: kernel tools.test accessors arrays
irc.messages irc.messages.private ;
EXCLUDE: sequences => join ;
IN: irc.messages.tests
! Copyright (C) 2008 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel fry splitting ascii calendar accessors combinators qualified
+USING: kernel fry splitting ascii calendar accessors combinators
arrays classes.tuple math.order ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
! Copyright (C) 2008 William Schlieper\r
! See http://factorcode.org/license.txt for BSD license.\r
\r
-USING: kernel io.files parser editors sequences ;\r
+USING: kernel io.files io.pathnames parser editors sequences ;\r
\r
IN: irc.ui.load\r
\r
\r
USING: accessors kernel threads combinators concurrency.mailboxes\r
sequences strings hashtables splitting fry assocs hashtables colors\r
- sorting qualified unicode.collation math.order\r
+ sorting unicode.collation math.order\r
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
-USING: koszul tools.test kernel sequences assocs namespaces
-symbols ;
+USING: koszul tools.test kernel sequences assocs namespaces ;
IN: koszul.tests
[
USING: accessors arrays assocs hashtables assocs io kernel math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
-splitting sorting shuffle symbols sets math.order ;
+splitting sorting shuffle sets math.order ;
IN: koszul
! Utilities
-USING: kernel io io.files io.monitors io.encodings.utf8 ;\r
+USING: kernel io io.files io.pathnames io.monitors io.encodings.utf8 ;\r
IN: log-viewer\r
\r
: read-lines ( stream -- )\r
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.launcher io.encodings.utf8 prettyprint arrays
-calendar namespaces mason.common mason.child
-mason.release mason.report mason.email mason.cleanup
-mason.help ;
+USING: arrays calendar io.directories io.encodings.utf8
+io.files io.launcher mason.child mason.cleanup mason.common
+mason.email mason.help mason.release mason.report namespaces
+prettyprint ;
IN: mason.build
: create-build-dir ( -- )
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make debugger sequences io.files
-io.launcher arrays accessors calendar continuations
-combinators.short-circuit mason.common mason.report
-mason.platform mason.config http.client ;
+USING: accessors arrays calendar combinators.short-circuit
+continuations debugger http.client io.directories io.files
+io.launcher io.pathnames kernel make mason.common mason.config
+mason.platform mason.report namespaces sequences ;
IN: mason.child
: make-cmd ( -- args )
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces arrays continuations io.files io.launcher
-mason.common mason.platform mason.config ;
+USING: arrays continuations io.directories
+io.directories.hierarchy io.files io.launcher kernel
+mason.common mason.config mason.platform namespaces ;
IN: mason.cleanup
: compress-image ( -- )
IN: mason.common.tests
USING: prettyprint mason.common mason.config
-namespaces calendar tools.test io.files io.encodings.utf8 ;
+namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ;
[ "00:01:01" ] [ 61000 milli-seconds>time ] unit-test
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting system accessors
-math.functions make io io.files io.launcher io.encodings.utf8
-prettyprint combinators.short-circuit parser combinators
-calendar calendar.format arrays mason.config locals ;
+math.functions make io io.files io.pathnames io.directories
+io.launcher io.encodings.utf8 prettyprint
+combinators.short-circuit parser combinators calendar
+calendar.format arrays mason.config locals ;
IN: mason.common
: short-running-process ( command -- )
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system io.files namespaces kernel accessors assocs ;
+USING: system io.files io.pathnames namespaces kernel accessors
+assocs ;
IN: mason.config
! (Optional) Location for build directories
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.html sequences io.files io.launcher make namespaces
-kernel arrays mason.common mason.config ;
+USING: arrays help.html io.directories io.files io.launcher
+kernel make mason.common mason.config namespaces sequences ;
IN: mason.help
: make-help-archive ( -- )
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel debugger io io.files threads debugger continuations
-namespaces accessors calendar mason.common mason.updates
-mason.build mason.email ;
+USING: accessors calendar continuations debugger debugger io
+io.directories io.files kernel mason.build mason.common
+mason.email mason.updates namespaces threads ;
IN: mason
: build-loop-error ( error -- )
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators sequences make namespaces io.files
-io.launcher prettyprint arrays
-mason.common mason.platform mason.config ;
+USING: arrays combinators io.directories
+io.directories.hierarchy io.files io.launcher io.pathnames
+kernel make mason.common mason.config mason.platform namespaces
+prettyprint sequences ;
IN: mason.release.archive
: base-name ( -- string )
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces sequences prettyprint io.files
-io.launcher make mason.common mason.platform mason.config ;
+USING: io.directories io.files io.launcher kernel make
+mason.common mason.config mason.platform namespaces prettyprint
+sequences ;
IN: mason.release.branch
: branch-name ( -- string ) "clean-" platform append ;
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces continuations debugger sequences fry
-io.files io.launcher bootstrap.image qualified mason.common
-mason.config ;
+USING: bootstrap.image continuations debugger fry
+io.directories io.directories.hierarchy io.files io.launcher
+kernel mason.common namespaces sequences ;
FROM: mason.config => target-os ;
IN: mason.release.tidy
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs io.files io.encodings.utf8
-prettyprint help.lint benchmark tools.time bootstrap.stage2
-tools.test tools.vocabs help.html mason.common words generic
-accessors compiler.errors sequences sets sorting math ;
+USING: accessors assocs benchmark bootstrap.stage2
+compiler.errors generic help.html help.lint io.directories
+io.encodings.utf8 io.files kernel mason.common math namespaces
+prettyprint sequences sets sorting tools.test tools.time
+tools.vocabs words ;
IN: mason.test
: do-load ( -- )
HELP: binpack!
{ $values { "items" sequence } { "quot" quotation } { "n" "number of bins" } { "bins" "packed bins" } }
-{ $description "Packs a sequence of items into the specified number of bins, using the quotatino to determine the weight." } ;
+{ $description "Packs a sequence of items into the specified number of bins, using the quotation to determine the weight." } ;
combinators.short-circuit fry kernel locals macros
math math.blas.cblas math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order functors words
-sequences sequences.merged sequences.private shuffle symbols
+sequences sequences.merged sequences.private shuffle
specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.float specialized-arrays.double ;
IN: math.blas.matrices
0 < "Negative " "" ? ;
: 3digit-groups ( n -- seq )
- number>string <reversed> 3 <groups>
- [ reverse string>number ] map ;
+ [ dup 0 > ] [ 1000 /mod ] [ ] produce nip ;
: hundreds-place ( n -- str )
- 100 /mod swap dup zero? [
+ 100 /mod over 0 = [
2drop ""
] [
- small-numbers " Hundred" append
- swap zero? [ " and " append ] unless
+ [ small-numbers " Hundred" append ] dip
+ 0 = [ " and " append ] unless
] if ;
: tens-place ( n -- str )
100 mod dup 20 >= [
10 /mod [ tens ] dip
- dup zero? [ drop ] [ "-" swap small-numbers 3append ] if
+ dup 0 = [ drop ] [ small-numbers "-" glue ] if
] [
- dup zero? [ drop "" ] [ small-numbers ] if
+ dup 0 = [ drop "" ] [ small-numbers ] if
] if ;
: 3digits>text ( n -- str )
[ " " glue ] unless-empty ;
: append-with-conjunction ( str1 str2 -- newstr )
- over length zero? [
+ over length 0 = [
nip
] [
- and-needed? get " and " ", " ? rot 3append
- and-needed? off
+ swap and-needed? get " and " ", " ?
+ glue and-needed? off
] if ;
: (recombine) ( str index seq -- newstr )
- 2dup nth zero? [
+ 2dup nth 0 = [
2drop
] [
text-with-scale append-with-conjunction
USING: math math.constants ;
IN: math.trig
-: deg>rad pi * 180 / ; inline
-: rad>deg 180 * pi / ; inline
+: deg>rad ( x -- y ) pi * 180 / ; inline
+: rad>deg ( x -- y ) 180 * pi / ; inline
define ; parsing
! Definition protocol. We qualify core generics here
-USE: qualified
QUALIFIED: syntax
syntax:M: generic definer drop \ GENERIC: f ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: save-namestack ( quot -- ) namestack >r call r> set-namestack ;
+: save-namestack ( quot -- ) namestack slip set-namestack ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-USING: kernel sequences assocs qualified circular sets fry sequences.lib ;
+USING: kernel sequences assocs circular sets fry sequences.lib ;
USING: math multi-methods ;
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
-IN: opengl.capabilities
-
-HELP: gl-version
-{ $values { "version" "The version string from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
-
-HELP: gl-vendor-version
-{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
-
-HELP: has-gl-version?
-{ $values { "version" "A version string" } { "?" "A boolean value" } }
-{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
-
-HELP: require-gl-version
-{ $values { "version" "A version string" } }
-{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ;
-
-HELP: glsl-version
-{ $values { "version" "The GLSL version string from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
-
-HELP: glsl-vendor-version
-{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
-
-HELP: has-glsl-version?
-{ $values { "version" "A version string" } { "?" "A boolean value" } }
-{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
-
-HELP: require-glsl-version
-{ $values { "version" "A version string" } }
-{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ;
-
-HELP: gl-extensions
-{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } }
-{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ;
-
-HELP: has-gl-extensions?
-{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
-{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
-
-HELP: has-gl-version-or-extensions?
-{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }
-{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
-
-HELP: require-gl-extensions
-{ $values { "extensions" "A sequence of extension name strings" } }
-{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
-
-HELP: require-gl-version-or-extensions
-{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
-{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
-
-{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words
-
-ABOUT: "gl-utilities"
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make sequences splitting opengl.gl
-continuations math.parser math arrays sets math.order ;
-IN: opengl.capabilities
-
-: (require-gl) ( thing require-quot make-error-quot -- )
- -rot dupd call
- [ 2drop ]
- [ swap " " make throw ]
- if ; inline
-
-: gl-extensions ( -- seq )
- GL_EXTENSIONS glGetString " " split ;
-: has-gl-extensions? ( extensions -- ? )
- gl-extensions swap [ over member? ] all? nip ;
-: (make-gl-extensions-error) ( required-extensions -- )
- gl-extensions diff
- "Required OpenGL extensions not supported:\n" %
- [ " " % % "\n" % ] each ;
-: require-gl-extensions ( extensions -- )
- [ has-gl-extensions? ]
- [ (make-gl-extensions-error) ]
- (require-gl) ;
-
-: version-seq ( version-string -- version-seq )
- "." split [ string>number ] map ;
-
-: version-before? ( version1 version2 -- ? )
- swap version-seq swap version-seq before=? ;
-
-: (gl-version) ( -- version vendor )
- GL_VERSION glGetString " " split1 ;
-: gl-version ( -- version )
- (gl-version) drop ;
-: gl-vendor-version ( -- version )
- (gl-version) nip ;
-: has-gl-version? ( version -- ? )
- gl-version version-before? ;
-: (make-gl-version-error) ( required-version -- )
- "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
-: require-gl-version ( version -- )
- [ has-gl-version? ]
- [ (make-gl-version-error) ]
- (require-gl) ;
-
-: (glsl-version) ( -- version vendor )
- GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ;
-: glsl-version ( -- version )
- (glsl-version) drop ;
-: glsl-vendor-version ( -- version )
- (glsl-version) nip ;
-: has-glsl-version? ( version -- ? )
- glsl-version version-before? ;
-: require-glsl-version ( version -- )
- [ has-glsl-version? ]
- [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
- (require-gl) ;
-
-: has-gl-version-or-extensions? ( version extensions -- ? )
- has-gl-extensions? swap has-gl-version? or ;
-
-: require-gl-version-or-extensions ( version extensions -- )
- 2array [ first2 has-gl-version-or-extensions? ] [
- dup first (make-gl-version-error) "\n" %
- second (make-gl-extensions-error) "\n" %
- ] (require-gl) ;
+++ /dev/null
-Testing for OpenGL versions and extensions
\ No newline at end of file
+++ /dev/null
-opengl
-bindings
ui.render accessors combinators ;
IN: opengl.demo-support
-: FOV 2.0 sqrt 1+ ; inline
+: FOV ( -- x ) 2.0 sqrt 1+ ; inline
: MOUSE-MOTION-SCALE 0.5 ; inline
: KEY-ROTATE-STEP 10.0 ; inline
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
-IN: opengl.framebuffers
-
-HELP: gen-framebuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
-
-HELP: gen-renderbuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
-
-HELP: delete-framebuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
-
-HELP: delete-renderbuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
-
-{ gen-framebuffer delete-framebuffer } related-words
-{ gen-renderbuffer delete-renderbuffer } related-words
-
-HELP: framebuffer-incomplete?
-{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
-
-HELP: check-framebuffer
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
-
-HELP: with-framebuffer
-{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
-{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
-
-ABOUT: "gl-utilities"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: opengl opengl.gl combinators continuations kernel
-alien.c-types ;
-IN: opengl.framebuffers
-
-: gen-framebuffer ( -- id )
- [ glGenFramebuffersEXT ] (gen-gl-object) ;
-: gen-renderbuffer ( -- id )
- [ glGenRenderbuffersEXT ] (gen-gl-object) ;
-
-: delete-framebuffer ( id -- )
- [ glDeleteFramebuffersEXT ] (delete-gl-object) ;
-: delete-renderbuffer ( id -- )
- [ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
-
-: framebuffer-incomplete? ( -- status/f )
- GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
- dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
-
-: framebuffer-error ( status -- * )
- {
- { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
- { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
- [ drop gl-error "unknown framebuffer error" ]
- } case throw ;
-
-: check-framebuffer ( -- )
- framebuffer-incomplete? [ framebuffer-error ] when* ;
-
-: with-framebuffer ( id quot -- )
- GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
- [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
-
-: framebuffer-attachment ( attachment -- id )
- GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
- 0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
+++ /dev/null
-Rendering to offscreen textures using the GL_EXT_framebuffer_object extension
\ No newline at end of file
+++ /dev/null
-opengl
-bindings
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs strings ;
-IN: opengl.shaders
-
-HELP: gl-shader
-{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:"
- { $list
- { { $link <gl-shader> } " - Compile GLSL code into a shader object" }
- { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" }
- { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" }
- { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" }
- { { $link delete-gl-shader } " - Invalidate a shader object" }
- }
- "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ;
-
-HELP: vertex-shader
-{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:"
- { $list
- { { $link <vertex-shader> } " - Compile GLSL code into a vertex shader object "}
- }
-} ;
-
-HELP: fragment-shader
-{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:"
- { $list
- { { $link <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
- }
-} ;
-
-HELP: <gl-shader>
-{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } { "shader" "a new " { $link gl-shader } } }
-{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
-
-HELP: <vertex-shader>
-{ $values { "source" "The GLSL source code to compile" } { "vertex-shader" "a new " { $link vertex-shader } } }
-{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
-
-HELP: <fragment-shader>
-{ $values { "source" "The GLSL source code to compile" } { "fragment-shader" "a new " { $link fragment-shader } } }
-{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
-
-HELP: gl-shader-ok?
-{ $values { "shader" "A " { $link gl-shader } " object" } { "?" "a boolean" } }
-{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
-
-HELP: check-gl-shader
-{ $values { "shader" "A " { $link gl-shader } " object" } }
-{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ;
-
-HELP: delete-gl-shader
-{ $values { "shader" "A " { $link gl-shader } " object" } }
-{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
-
-HELP: gl-shader-info-log
-{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } }
-{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
-
-HELP: gl-program
-{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
- { $list
- { { $link <gl-program> } ", " { $link <simple-gl-program> } " - Link a set of shaders into a GLSL program" }
- { { $link gl-program-ok? } " - Check whether a program object linked successfully" }
- { { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
- { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
- { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" }
- { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
- { { $link with-gl-program } " - Use a program object" }
- }
-} ;
-
-HELP: <gl-program>
-{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } { "program" "a new " { $link gl-program } } }
-{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
-
-HELP: <simple-gl-program>
-{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } { "program" "a new " { $link gl-program } } }
-{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
-
-{ <gl-program> <simple-gl-program> } related-words
-
-HELP: gl-program-ok?
-{ $values { "program" "A " { $link gl-program } " object" } { "?" "a boolean" } }
-{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
-
-HELP: check-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } }
-{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
-
-HELP: gl-program-info-log
-{ $values { "program" "A " { $link gl-program } " object" } { "log" string } }
-{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
-
-HELP: delete-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } }
-{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
-
-HELP: with-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } }
-{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
-
-ABOUT: "gl-utilities"
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel opengl.gl alien.c-types continuations namespaces
-assocs alien alien.strings libc opengl math sequences combinators
-combinators.lib macros arrays io.encodings.ascii fry
-specialized-arrays.uint destructors accessors ;
-IN: opengl.shaders
-
-: with-gl-shader-source-ptr ( string quot -- )
- swap ascii malloc-string [ <void*> swap call ] keep free ; inline
-
-: <gl-shader> ( source kind -- shader )
- glCreateShader dup rot
- [ 1 swap f glShaderSource ] with-gl-shader-source-ptr
- [ glCompileShader ] keep
- gl-error ;
-
-: (gl-shader?) ( object -- ? )
- dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
-
-: gl-shader-get-int ( shader enum -- value )
- 0 <int> [ glGetShaderiv ] keep *int ;
-
-: gl-shader-ok? ( shader -- ? )
- GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
-
-: <vertex-shader> ( source -- vertex-shader )
- GL_VERTEX_SHADER <gl-shader> ; inline
-
-: (vertex-shader?) ( object -- ? )
- dup (gl-shader?)
- [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
- [ drop f ] if ;
-
-: <fragment-shader> ( source -- fragment-shader )
- GL_FRAGMENT_SHADER <gl-shader> ; inline
-
-: (fragment-shader?) ( object -- ? )
- dup (gl-shader?)
- [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ]
- [ drop f ] if ;
-
-: gl-shader-info-log-length ( shader -- log-length )
- GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
-
-: gl-shader-info-log ( shader -- log )
- dup gl-shader-info-log-length dup [
- 1 calloc &free
- [ 0 <int> swap glGetShaderInfoLog ] keep
- ascii alien>string
- ] with-destructors ;
-
-: check-gl-shader ( shader -- shader )
- dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
-
-: delete-gl-shader ( shader -- ) glDeleteShader ; inline
-
-PREDICATE: gl-shader < integer (gl-shader?) ;
-PREDICATE: vertex-shader < gl-shader (vertex-shader?) ;
-PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
-
-! Programs
-
-: <gl-program> ( shaders -- program )
- glCreateProgram swap
- [ dupd glAttachShader ] each
- [ glLinkProgram ] keep
- gl-error ;
-
-: (gl-program?) ( object -- ? )
- dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
-
-: gl-program-get-int ( program enum -- value )
- 0 <int> [ glGetProgramiv ] keep *int ;
-
-: gl-program-ok? ( program -- ? )
- GL_LINK_STATUS gl-program-get-int c-bool> ;
-
-: gl-program-info-log-length ( program -- log-length )
- GL_INFO_LOG_LENGTH gl-program-get-int ; inline
-
-: gl-program-info-log ( program -- log )
- dup gl-program-info-log-length dup [
- 1 calloc &free
- [ 0 <int> swap glGetProgramInfoLog ] keep
- ascii alien>string
- ] with-destructors ;
-
-: check-gl-program ( program -- program )
- dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
-
-: gl-program-shaders-length ( program -- shaders-length )
- GL_ATTACHED_SHADERS gl-program-get-int ; inline
-
-: gl-program-shaders ( program -- shaders )
- dup gl-program-shaders-length
- 0 <int>
- over <uint-array>
- [ underlying>> glGetAttachedShaders ] keep ;
-
-: delete-gl-program-only ( program -- )
- glDeleteProgram ; inline
-
-: detach-gl-program-shader ( program shader -- )
- glDetachShader ; inline
-
-: delete-gl-program ( program -- )
- dup gl-program-shaders [
- 2dup detach-gl-program-shader delete-gl-shader
- ] each delete-gl-program-only ;
-
-: with-gl-program ( program quot -- )
- over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
-
-PREDICATE: gl-program < integer (gl-program?) ;
-
-: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
- >r <vertex-shader> check-gl-shader
- r> <fragment-shader> check-gl-shader
- 2array <gl-program> check-gl-program ;
-
+++ /dev/null
-OpenGL Shading Language (GLSL) support
\ No newline at end of file
+++ /dev/null
-opengl
-bindings
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slides help.markup math arrays hashtables namespaces
+sequences kernel sequences parser memoize io.encodings.binary
+locals kernel.private tools.vocabs.browser assocs quotations
+ tools.vocabs tools.annotations tools.crossref
+help.topics math.functions compiler.tree.optimizer
+compiler.cfg.optimizer fry graphics.bitmap graphics.viewer
+ui.gadgets.panes tetris tetris.game combinators generalizations
+multiline sequences.private ;
+IN: otug-talk
+
+USING: cairo cairo.samples cairo.ffi cairo.gadgets accessors
+io.backend ui.gadgets ;
+
+TUPLE: png-gadget < cairo-gadget surface ;
+
+: <png-gadget> ( file -- gadget )
+ png-gadget new-gadget
+ swap normalize-path
+ cairo_image_surface_create_from_png >>surface ; inline
+
+M: png-gadget pref-dim* ( gadget -- )
+ surface>>
+ [ cairo_image_surface_get_width ]
+ [ cairo_image_surface_get_height ]
+ bi 2array ;
+
+M: png-gadget render-cairo* ( gadget -- )
+ cr swap surface>> 0 0 cairo_set_source_surface
+ cr cairo_paint ;
+
+M: png-gadget ungraft* ( gadget -- )
+ surface>> cairo_surface_destroy ;
+
+: $bitmap ( element -- )
+ [ first <png-gadget> gadget. ] ($block) ;
+
+: $tetris ( element -- )
+ drop [ <default-tetris> <tetris-gadget> gadget. ] ($block) ;
+
+: otug-slides
+{
+ { $slide "Factor!"
+ { $url "http://factorcode.org" }
+ "Development started in 2003"
+ "Open source (BSD license)"
+ "Influenced by Forth, Lisp, and Smalltalk"
+ "Blurs the line between language and library"
+ "Interactive development"
+ }
+ { $slide "Part 1: the language" }
+ { $slide "Basics"
+ "Stack based, dynamically typed"
+ { "A " { $emphasis "word" } " is a named piece of code" }
+ { "Values are passed between words on a " { $emphasis "stack" } }
+ "Code evaluates left to right"
+ "Example:"
+ { $code "2 3 + ." }
+ }
+ { $slide "Quotations"
+ { "A " { $emphasis "quotation" } " is a block of code pushed on the stack" }
+ { "Syntax: " { $snippet "[ ... ]" } }
+ "Example:"
+ { $code
+ "\"/etc/passwd\" ascii file-lines"
+ "[ \"#\" head? not ] filter"
+ "[ \":\" split first ] map"
+ "."
+ }
+ }
+ { $slide "Words"
+ { "We can define new words with " { $snippet ": name ... ;" } " syntax" }
+ { $code ": remove-comments ( lines -- lines' )" " [ \"#\" head? not ] filter ;" }
+ { "Words are grouped into " { $emphasis "vocabularies" } }
+ { $link "vocab-index" }
+ "Libraries and applications are vocabularies"
+ { $vocab-link "spheres" }
+ }
+ { $slide "Constructing quotations"
+ { "Suppose we want a " { $snippet "remove-comments*" } " word" }
+ { $code ": remove-comments* ( lines string -- lines' )" " [ ??? head? not ] filter ;" }
+ { "We use " { $link POSTPONE: '[ } " instead of " { $link POSTPONE: [ } }
+ { "Create “holes” with " { $link _ } }
+ "Holes filled in left to right when quotation pushed on the stack"
+ }
+ { $slide "Constructing quotations"
+ { $code ": remove-comments* ( lines string -- lines' )" " '[ _ head? not ] filter ;" "" ": remove-comments ( lines -- lines' )" " \"#\" remove-comments* ;" }
+ { { $link @ } " inserts a quotation" }
+ { $code ": replicate ( n quot -- seq )" " '[ drop @ ] map ;" }
+ { $code "10 [ 1 10 [a,b] random ] replicate ." }
+ }
+ { $slide "Combinators"
+ { "A " { $emphasis "combinator" } " is a word taking quotations as input" }
+ { "Used for control flow, data flow, iteration" }
+ { $code "100 [ 5 mod 3 = [ \"Fizz!\" print ] when ] each" }
+ { "Control flow: " { $link if } ", " { $link when } ", " { $link unless } ", " { $link cond } }
+ { "Iteration: " { $link map } ", " { $link filter } ", " { $link all? } ", ..." }
+ }
+ { $slide "Data flow combinators - simple example"
+ "All examples so far used “pipeline style”"
+ "What about using a value more than once, or operating on values not at top of stack?"
+ { $code "{ 10 70 54 } [ sum ] [ length ] bi / ." }
+ { $code "5 [ 1 + ] [ sqrt ] [ 1 - ] tri 3array ." }
+ }
+ { $slide "Data flow combinators - cleave family"
+ { { $link bi } ", " { $link tri } ", " { $link cleave } }
+ { $bitmap "resource:extra/otug-talk/bi.png" }
+ }
+ { $slide "Data flow combinators - cleave family"
+ { { $link 2bi } ", " { $link 2tri } ", " { $link 2cleave } }
+ { $bitmap "resource:extra/otug-talk/2bi.png" }
+ }
+ { $slide "Data flow combinators"
+ "First, let's define a data type:"
+ { $code "TUPLE: person first-name last-name ;" }
+ "Make an instance:"
+ { $code "person new" " \"Joe\" >>first-name" " \"Sixpack\" >>last-name" }
+ }
+ { $slide "Data flow combinators"
+ "Let's do stuff with it:"
+ { $code
+ "[ first-name>> ] [ last-name>> ] bi"
+ "[ 2 head ] [ 5 head ] bi*"
+ "[ >upper ] bi@"
+ "\".\" glue ."
+ }
+ }
+ { $slide "Data flow combinators - spread family"
+ { { $link bi* } ", " { $link tri* } ", " { $link spread } }
+ { $bitmap "resource:extra/otug-talk/bi_star.png" }
+ }
+ { $slide "Data flow combinators - spread family"
+ { { $link 2bi* } }
+ { $bitmap "resource:extra/otug-talk/2bi_star.png" }
+ }
+ { $slide "Data flow combinators - apply family"
+ { { $link bi@ } ", " { $link tri@ } ", " { $link napply } }
+ { $bitmap "resource:extra/otug-talk/bi_at.png" }
+ }
+ { $slide "Data flow combinators - apply family"
+ { { $link 2bi@ } }
+ { $bitmap "resource:extra/otug-talk/2bi_at.png" }
+ }
+ { $slide "Shuffle words"
+ "When data flow combinators are not enough"
+ { $link "shuffle-words" }
+ "Lower-level, Forth/PostScript-style stack manipulation"
+ }
+ { $slide "Locals"
+ "When data flow combinators and shuffle words are not enough"
+ "Name your input parameters"
+ "Used in about 1% of all words"
+ }
+ { $slide "Locals example"
+ "Area of a triangle using Heron's formula"
+ { $code
+ <" :: area ( a b c -- x )
+ a b c + + 2 / :> p
+ p
+ p a - *
+ p b - *
+ p c - * sqrt ;">
+ }
+ }
+ { $slide "Previous example without locals"
+ "A bit unwieldy..."
+ { $code
+ <" : area ( a b c -- x )
+ [ ] [ + + 2 / ] 3bi
+ [ '[ _ - ] tri@ ] [ neg ] bi
+ * * * sqrt ;"> }
+ }
+ { $slide "More idiomatic version"
+ "But there's a trick: put the points in an array"
+ { $code <" : v-n ( v n -- w ) '[ _ - ] map ;
+
+: area ( points -- x )
+ [ 0 suffix ] [ sum 2 / ] bi
+ v-n product sqrt ;"> }
+ }
+ ! { $slide "The parser"
+ ! "All data types have a literal syntax"
+ ! "Literal hashtables and arrays are very useful in data-driven code"
+ ! { $code "H{ { \"cookies\" 12 } { \"milk\" 10 } }" }
+ ! "Libraries can define new parsing words"
+ ! }
+ { $slide "Programming without named values"
+ "Minimal glue between words"
+ "Easy multiple return values"
+ { "Avoid useless variable names: " { $snippet "x" } ", " { $snippet "n" } ", " { $snippet "a" } ", ..." }
+ { { $link at } " and " { $link at* } }
+ { $code "at* [ ... ] [ ... ] if" }
+ }
+ { $slide "Stack language idioms"
+ "Enables new idioms not possible before"
+ "We get the effect of “keyword parameters” for free"
+ { $vocab-link "smtp-example" }
+ }
+ { $slide "“Perfect” factoring"
+ { $table
+ { { $link head } { $link head-slice } }
+ { { $link tail } { $link tail-slice } }
+ }
+ { "Modifier: " { $link from-end } }
+ { "Modifier: " { $link short } }
+ "4*2*2=16 operations, 6 words!"
+ }
+ { $slide "Modifiers"
+ "“Modifiers” can express MN combinations using M+N words"
+ { $code
+ "\"Hello, Joe\" 4 head ."
+ "\"Hello, Joe\" 3 tail ."
+ "\"Hello, Joe\" 3 from-end tail ."
+ }
+ { $code
+ "\"Hello world\" 5 short head ."
+ "\"Hi\" 5 short tail ."
+ }
+ }
+ { $slide "Modifiers"
+ { "C-style " { $snippet "while" } " and " { $snippet "do while" } " loops" }
+ }
+ { $slide "Modifiers"
+ { $code ": bank ( n -- n )" " readln string>number +" " dup \"Balance: $\" write . ;" }
+ { $code "0 [ dup 0 > ] [ bank ] [ ] while" }
+ }
+ { $slide "Modifiers"
+ { $code "0 [ dup 0 > ] [ bank ] [ ] do while" }
+ { { $link do } " executes one iteration of a " { $link while } " loop" }
+ { { $link while } " calls " { $link do } }
+ }
+ { $slide "More “pipeline style” code"
+ { "Suppose we want to get the price of the customer's first order, but any one of the steps along the way could be a nil value (" { $link f } " in Factor):" }
+ { $code
+ "dup [ orders>> ] when"
+ "dup [ first ] when"
+ "dup [ price>> ] when"
+ }
+ }
+ { $slide "This is hard with mainstream syntax!"
+ { $code
+ <" var customer = ...;
+var orders = (customer == null ? null : customer.orders);
+var order = (orders == null ? null : orders[0]);
+var price = (order == null ? null : order.price);"> }
+ }
+ { $slide "An ad-hoc solution"
+ "Something like..."
+ { $code "var price = customer.?orders.?[0].?price;" }
+ }
+ ! { $slide "Stack languages are fundamental"
+ ! "Very simple semantics"
+ ! "Easy to generate stack code programatically"
+ ! "Everything is almost entirely library code in Factor"
+ ! "Factor is easy to extend"
+ ! }
+ { $slide "Part 2: the implementation" }
+ { $slide "Interactive development"
+ { $tetris }
+ }
+ { $slide "Application deployment"
+ { $vocab-link "webkit-demo" }
+ "Demonstrates Cocoa binding"
+ "Let's deploy a stand-alone binary with the deploy tool"
+ "Deploy tool generates binaries with no external dependencies"
+ }
+ { $slide "The UI"
+ "Renders with OpenGL"
+ "Backends for Cocoa, Windows, X11: managing windows, input events, clipboard"
+ "Cross-platform API"
+ }
+ { $slide "UI example"
+ { $code
+ <" <pile>
+ { 5 5 } >>gap
+ 1 >>fill
+ "Hello world!" <label> add-gadget
+ "Click me!" [ drop beep ]
+ <bevel-button> add-gadget
+ <editor> <scroller> add-gadget
+"UI test" open-window "> }
+ }
+ { $slide "Help system"
+ "Help markup is just literal data"
+ { "Look at the help for " { $link T{ link f + } } }
+ "These slides are built with the help system and a custom style sheet"
+ { $vocab-link "otug-talk" }
+ }
+ { $slide "The VM"
+ "Lowest level is the VM: ~12,000 lines of C"
+ "Generational garbage collection"
+ "Non-optimizing compiler"
+ "Loads an image file and runs it"
+ "Initial image generated from another Factor instance:"
+ { $code "\"x86.32\" make-image" }
+ }
+ { $slide "The core library"
+ "Core library, ~9,000 lines of Factor"
+ "Source parser, arrays, strings, math, hashtables, basic I/O, ..."
+ "Packaged into boot image because VM doesn't have a parser"
+ }
+ { $slide "The basis library"
+ "Basis library, ~80,000 lines of Factor"
+ "Bootstrap process loads code from basis, runs compiler, saves image"
+ "Loaded by default: optimizing compiler, tools, help system, UI, ..."
+ "Optional: HTTP server, XML, database access, ..."
+ }
+ { $slide "Non-optimizing compiler"
+ "Glues together chunks of machine code"
+ "Most words compiled as calls, some inlined"
+ "Used for listener interactions, and bootstrap"
+ }
+ { $slide "Optimizing compiler"
+ "Converts Factor code into high-level SSA form"
+ "Performs global optimizations"
+ "Converts high-level SSA into low-level SSA"
+ "Performs local optimizations"
+ "Register allocation"
+ "Machine code generation: x86, x86-64, PowerPC"
+ }
+ { $slide "Optimizing compiler"
+ "Makes high-level language features cheap to use"
+ "Eliminate redundant method dispatch by inferring types"
+ "Eliminate redundant integer overflow checks by inferring ranges"
+ }
+ { $slide "Optimizing compiler"
+ "Eliminate redundant memory allocation (escape analysis)"
+ "Eliminate redundant loads/stores (alias analysis)"
+ "Eliminate redundant computations (value numbering)"
+ }
+ { $slide "Project infrastructure"
+ { $url "http://factorcode.org" }
+ { $url "http://concatenative.org" }
+ { $url "http://docs.factorcode.org" }
+ { $url "http://planet.factorcode.org" }
+ "Uses our HTTP server, SSL, DB, Atom libraries..."
+ }
+ { $slide "Project infrastructure"
+ "Build farm, written in Factor"
+ "12 platforms"
+ "Builds Factor and all libraries, runs tests, makes binaries"
+ "Good for increasing stability"
+ }
+ { $slide "Community"
+ "#concatenative irc.freenode.net: 60-70 users"
+ "factor-talk@lists.sf.net: 189 subscribers"
+ "About 30 people have code in the Factor repository"
+ "Easy to get started: binaries, lots of docs, friendly community..."
+ }
+ { $slide "Selling points"
+ "Expressive language"
+ "Comprehensive library"
+ "Efficient implementation"
+ "Powerful interactive tools"
+ "Stand-alone application deployment"
+ "Moving fast"
+ }
+ { $slide "That's all, folks"
+ "It is hard to cover everything in a single talk"
+ "Factor has many cool things that I didn't talk about"
+ "Questions?"
+ }
+} ;
+
+: otug-talk ( -- ) otug-slides slides-window ;
+
+MAIN: otug-talk
--- /dev/null
+Slides from a talk at OTUG by Slava Pestov, December 2008
+++ /dev/null
-John Benediktsson
+++ /dev/null
-
-USING: help.syntax help.markup kernel prettyprint sequences strings ;
-
-IN: printf
-
-HELP: printf
-{ $values { "format-string" string } }
-{ $description "Writes the arguments (specified on the stack) formatted according to the format string." }
-{ $examples
- { $example
- "USING: printf ;"
- "123 \"%05d\" printf"
- "00123" }
- { $example
- "USING: printf ;"
- "HEX: ff \"%04X\" printf"
- "00FF" }
- { $example
- "USING: printf ;"
- "1.23456789 \"%.3f\" printf"
- "1.235" }
- { $example
- "USING: printf ;"
- "1234567890 \"%.5e\" printf"
- "1.23457e+09" }
- { $example
- "USING: printf ;"
- "12 \"%'#4d\" printf"
- "##12" }
- { $example
- "USING: printf ;"
- "1234 \"%+d\" printf"
- "+1234" }
-} ;
-
-HELP: sprintf
-{ $values { "format-string" string } { "result" string } }
-{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." }
-{ $see-also printf } ;
-
-ARTICLE: "printf" "Formatted printing"
-"The " { $vocab-link "printf" } " vocabulary is used for formatted printing.\n"
-{ $subsection printf }
-{ $subsection sprintf }
-"\n"
-"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n"
-{ $table
- { "%%" "Single %" "" }
- { "%P.Ds" "String format" "string" }
- { "%P.DS" "String format uppercase" "string" }
- { "%c" "Character format" "char" }
- { "%C" "Character format uppercase" "char" }
- { "%+Pd" "Integer format" "fixnum" }
- { "%+P.De" "Scientific notation" "fixnum, float" }
- { "%+P.DE" "Scientific notation" "fixnum, float" }
- { "%+P.Df" "Fixed format" "fixnum, float" }
- { "%+Px" "Hexadecimal" "hex" }
- { "%+PX" "Hexadecimal uppercase" "hex" }
-}
-"\n"
-"A plus sign ('+') is used to optionally specify that the number should be formatted with a '+' preceeding it if positive.\n"
-"\n"
-"Padding ('P') is used to optionally specify the minimum width of the result string, the padding character, and the alignment. By default, the padding character defaults to a space and the alignment defaults to right-aligned. For example:\n"
-{ $list
- "\"%5s\" formats a string padding with spaces up to 5 characters wide."
- "\"%08d\" formats an integer padding with zeros up to 3 characters wide."
- "\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
- "\"%-10d\" formats an integer to 10 characters wide and left-aligns."
-}
-"\n"
-"Digits ('D') is used to optionally specify the maximum digits in the result string. For example:\n"
-{ $list
- "\"%.3s\" formats a string to truncate at 3 characters (from the left)."
- "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
- "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
-} ;
-
-ABOUT: "printf"
-
-
+++ /dev/null
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: kernel printf tools.test ;
-
-[ "%s" printf ] must-infer
-
-[ "%s" sprintf ] must-infer
-
-[ t ] [ "" "" sprintf = ] unit-test
-
-[ t ] [ "asdf" "asdf" sprintf = ] unit-test
-
-[ t ] [ "10" 10 "%d" sprintf = ] unit-test
-
-[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test
-
-[ t ] [ "-10" -10 "%d" sprintf = ] unit-test
-
-[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test
-
-[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test
-
-[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
-
-[ t ] [ "123.456000" 123.456 "%f" sprintf = ] unit-test
-
-[ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test
-
-[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
-
-[ t ] [ "1.2346" 1.23456789 "%.4f" sprintf = ] unit-test
-
-[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
-
-[ t ] [ "1.234000e+08" 123400000 "%e" sprintf = ] unit-test
-
-[ t ] [ "-1.234000e+08" -123400000 "%e" sprintf = ] unit-test
-
-[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
-
-[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
-
-[ t ] [ "2.500000e-03" 0.0025 "%e" sprintf = ] unit-test
-
-[ t ] [ "2.500000E-03" 0.0025 "%E" sprintf = ] unit-test
-
-[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test
-
-[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test
-
-[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test
-
-[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test
-
-[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test
-
-[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test
-
-[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test
-
-[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test
-
-[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test
-
-[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
-
-[ t ] [ "2008-09-10"
- 2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
-
-[ t ] [ "Hello, World!"
- "Hello, World!" "%s" sprintf = ] unit-test
-
-[ t ] [ "printf test"
- "printf test" sprintf = ] unit-test
-
-[ t ] [ "char a = 'a'"
- CHAR: a "char %c = 'a'" sprintf = ] unit-test
-
-[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
-
-[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
-
-[ t ] [ "0 message(s)"
- 0 "message" "%d %s(s)" sprintf = ] unit-test
-
-[ t ] [ "0 message(s) with %"
- 0 "message" "%d %s(s) with %%" sprintf = ] unit-test
-
-[ t ] [ "justif: \"left \""
- "left" "justif: \"%-10s\"" sprintf = ] unit-test
-
-[ t ] [ "justif: \" right\""
- "right" "justif: \"%10s\"" sprintf = ] unit-test
-
-[ t ] [ " 3: 0003 zero padded"
- 3 " 3: %04d zero padded" sprintf = ] unit-test
-
-[ t ] [ " 3: 3 left justif"
- 3 " 3: %-4d left justif" sprintf = ] unit-test
-
-[ t ] [ " 3: 3 right justif"
- 3 " 3: %4d right justif" sprintf = ] unit-test
-
-[ t ] [ " -3: -003 zero padded"
- -3 " -3: %04d zero padded" sprintf = ] unit-test
-
-[ t ] [ " -3: -3 left justif"
- -3 " -3: %-4d left justif" sprintf = ] unit-test
-
-[ t ] [ " -3: -3 right justif"
- -3 " -3: %4d right justif" sprintf = ] unit-test
-
-[ t ] [ "There are 10 monkeys in the kitchen"
- 10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
-
-[ f ] [ "%d" 10 "%d" sprintf = ] unit-test
-
-[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test
-
-[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test
-
-[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test
-
-[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
-
-[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
-
-[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
-
-
-
+++ /dev/null
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: io io.encodings.ascii io.files io.streams.string combinators
-kernel sequences splitting strings math math.functions math.parser
-macros fry peg.ebnf ascii unicode.case arrays quotations vectors ;
-
-IN: printf
-
-<PRIVATE
-
-: compose-all ( seq -- quot )
- [ ] [ compose ] reduce ;
-
-: fix-sign ( string -- string )
- dup CHAR: 0 swap index 0 =
- [ dup 0 swap [ [ CHAR: 0 = not ] keep digit? and ] find-from
- [ dup 1- rot dup [ nth ] dip swap
- {
- { CHAR: - [ [ 1- ] dip remove-nth "-" prepend ] }
- { CHAR: + [ [ 1- ] dip remove-nth "+" prepend ] }
- [ drop swap drop ]
- } case
- ] [ drop ] if
- ] when ;
-
-: >digits ( string -- digits )
- [ 0 ] [ string>number ] if-empty ;
-
-: pad-digits ( string digits -- string' )
- [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
-
-: max-digits ( n digits -- n' )
- 10 swap ^ [ * round ] keep / ;
-
-: max-width ( string length -- string' )
- short head ;
-
-: >exp ( x -- exp base )
- [
- abs 0 swap
- [ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
- [ dup 10.0 >=
- [ 10.0 / [ 1+ ] dip ]
- [ 10.0 * [ 1- ] dip ] if
- ] [ ] while
- ] keep 0 < [ neg ] when ;
-
-: exp>string ( exp base digits -- string )
- [ max-digits ] keep -rot
- [
- [ 0 < "-" "+" ? ]
- [ abs number>string 2 CHAR: 0 pad-left ] bi
- "e" -rot 3append
- ]
- [ number>string ] bi*
- rot pad-digits prepend ;
-
-EBNF: parse-format-string
-
-zero = "0" => [[ CHAR: 0 ]]
-char = "'" (.) => [[ second ]]
-
-pad-char = (zero|char)? => [[ CHAR: \s or ]]
-pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
-pad-width = ([0-9])* => [[ >digits ]]
-pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
-
-sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]]
-
-width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]]
-width = (width_)? => [[ [ ] or ]]
-
-digits_ = "." ([0-9])* => [[ second >digits ]]
-digits = (digits_)? => [[ 6 or ]]
-
-fmt-% = "%" => [[ [ "%" ] ]]
-fmt-c = "c" => [[ [ 1string ] ]]
-fmt-C = "C" => [[ [ 1string >upper ] ]]
-fmt-s = "s" => [[ [ ] ]]
-fmt-S = "S" => [[ [ >upper ] ]]
-fmt-d = "d" => [[ [ >fixnum number>string ] ]]
-fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
-fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
-fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
-fmt-x = "x" => [[ [ >hex ] ]]
-fmt-X = "X" => [[ [ >hex >upper ] ]]
-unknown = (.)* => [[ "Unknown directive" throw ]]
-
-strings_ = fmt-c|fmt-C|fmt-s|fmt-S
-strings = pad width strings_ => [[ reverse compose-all ]]
-
-numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
-numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
-
-formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
-
-plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
-
-text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
-
-;EBNF
-
-PRIVATE>
-
-MACRO: printf ( format-string -- )
- parse-format-string [ length ] keep compose-all '[ _ <vector> @ reverse [ write ] each ] ;
-
-: sprintf ( format-string -- result )
- [ printf ] with-string-writer ; inline
-
-
+++ /dev/null
-Format data according to a specified format string, and writes (or returns) the result string.
+++ /dev/null
-
-USING: kernel namespaces combinators
- ui.gestures accessors ui.gadgets.frame-buffer ;
-
-IN: processing.gadget
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
-
-: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: mouse-pressed-value
-SYMBOL: key-pressed-value
-
-SYMBOL: button-value
-SYMBOL: key-value
-
-: key-pressed? ( -- ? ) key-pressed-value get ;
-: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
-
-: key ( -- key ) key-value get ;
-: button ( -- val ) button-value get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: processing-gadget handle-gesture ( gesture gadget -- ? )
- swap
- {
- {
- [ dup key-down? ]
- [
- sym>> key-value set
- key-pressed-value on
- key-down>> dup [ call ] [ drop ] if
- t
- ]
- }
- {
- [ dup key-up? ]
- [
- key-pressed-value off
- drop
- key-up>> dup [ call ] [ drop ] if
- t
- ] }
- {
- [ dup button-down? ]
- [
- #>> button-value set
- mouse-pressed-value on
- button-down>> dup [ call ] [ drop ] if
- t
- ]
- }
- {
- [ dup button-up? ]
- [
- mouse-pressed-value off
- drop
- button-up>> dup [ call ] [ drop ] if
- t
- ]
- }
- { [ t ] [ 2drop t ] }
- }
- cond ;
+++ /dev/null
-
-USING: kernel namespaces threads combinators sequences arrays
- math math.functions math.ranges random
- opengl.gl opengl.glu vars multi-methods generalizations shuffle
- ui
- ui.gestures
- ui.gadgets
- combinators
- combinators.lib
- combinators.cleave
- rewrite-closures bake bake.fry accessors newfx
- processing.gadget math.geometry.rect
- processing.shapes
- colors ;
-
-IN: processing
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
-
-: 1random ( b -- num ) 0 swap 2random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chance ( fraction -- ? ) 0 1 2random > ;
-
-: percent-chance ( percent -- ? ) 100 / chance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
-
-: at-fraction ( seq fraction -- val ) over length 1- * at ;
-
-: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: canonical-color-value ( obj -- color )
-
-METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
-
-METHOD: canonical-color-value { array }
- dup length
- {
- { 2 [ first2 >r dup dup r> rgba boa ] }
- { 3 [ first3 1 rgba boa ] }
- { 4 [ first4 rgba boa ] }
- }
- case ;
-
-! METHOD: canonical-color-value { rgba }
-! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
-
-METHOD: canonical-color-value { color } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fill ( value -- ) canonical-color-value >fill-color ;
-: stroke ( value -- ) canonical-color-value >stroke-color ;
-
-! : no-fill ( -- ) 0 fill-color> set-fourth ;
-! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
-
-: no-fill ( -- ) fill-color> 0 >>alpha drop ;
-: no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: stroke-weight ( w -- ) glLineWidth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
-! GL_POLYGON glBegin
-! glVertex2d
-! glVertex2d
-! glVertex2d
-! glVertex2d
-! glEnd ;
-
-! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
-
-! 8 ndup
-
-! GL_FRONT_AND_BACK GL_FILL glPolygonMode
-! fill-color> set-color
-
-! quad-vertices
-
-! GL_FRONT_AND_BACK GL_LINE glPolygonMode
-! stroke-color> set-color
-
-! quad-vertices ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : ellipse-disk ( x y width height -- )
-! glPushMatrix
-! >r >r
-! 0 glTranslated
-! r> r> 1 glScaled
-! gluNewQuadric
-! dup 0 0.5 20 1 gluDisk
-! gluDeleteQuadric
-! glPopMatrix ;
-
-! : ellipse-center ( x y width height -- )
-
-! 4dup
-
-! GL_FRONT_AND_BACK GL_FILL glPolygonMode
-! stroke-color> set-color
-
-! ellipse-disk
-
-! GL_FRONT_AND_BACK GL_FILL glPolygonMode
-! fill-color> set-color
-
-! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
-
-! ellipse-disk ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! SYMBOL: CENTER
-! SYMBOL: RADIUS
-! SYMBOL: CORNER
-! SYMBOL: CORNERS
-
-! SYMBOL: ellipse-mode-value
-
-! : ellipse-mode ( val -- ) ellipse-mode-value set ;
-
-! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
-
-! : ellipse-corner ( x y width height -- )
-! [ drop nip 2 / + ] 4keep
-! [ nip rot drop 2 / + ] 4keep
-! [ >r >r 2drop r> r> ] 4keep
-! 4drop
-! ellipse-center ;
-
-! : ellipse-corners ( x1 y1 x2 y2 -- )
-! [ drop nip + 2 / ] 4keep
-! [ nip rot drop + 2 / ] 4keep
-! [ drop nip - abs 1+ ] 4keep
-! [ nip rot drop - abs 1+ ] 4keep
-! 4drop
-! ellipse-center ;
-
-! : ellipse ( a b c d -- )
-! ellipse-mode-value get
-! {
-! { CENTER [ ellipse-center ] }
-! { RADIUS [ ellipse-radius ] }
-! { CORNER [ ellipse-corner ] }
-! { CORNERS [ ellipse-corners ] }
-! }
-! case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: background ( value -- )
-
-METHOD: background { number }
- dup dup 1 glClearColor
- GL_COLOR_BUFFER_BIT glClear ;
-
-METHOD: background { array }
- dup length
- {
- { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
- { 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
- { 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: translate ( x y -- ) 0 glTranslated ;
-
-: rotate ( angle -- ) 0 0 1 glRotated ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mouse ( -- point ) hand-loc get ;
-
-: mouse-x ( -- x ) mouse first ;
-: mouse-y ( -- y ) mouse second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: frame-rate-value
-
-: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! VAR: slate
-
-VAR: loop-flag
-
-: defaults ( -- )
- 0.8 background
- ! CENTER ellipse-mode
- 60 frame-rate ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: size-val
-
-: size ( seq -- ) size-val set ;
-
-: size* ( width height -- ) 2array size-val set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: setup-action
-SYMBOL: draw-action
-
-! : setup ( quot -- ) closed-quot setup-action set ;
-! : draw ( quot -- ) closed-quot draw-action set ;
-
-: setup ( quot -- ) setup-action set ;
-: draw ( quot -- ) draw-action set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: key-down-action
-SYMBOL: key-up-action
-
-: key-down ( quot -- ) closed-quot key-down-action set ;
-: key-up ( quot -- ) closed-quot key-up-action set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: button-down-action
-SYMBOL: button-up-action
-
-: button-down ( quot -- ) closed-quot button-down-action set ;
-: button-up ( quot -- ) closed-quot button-up-action set ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start-processing-thread ( -- )
- loop-flag get not
- [
- loop-flag on
- [
- [ loop-flag get ]
- processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
- [ ]
- while
- ]
- in-thread
- ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-size ( -- size ) processing-gadget get rect-dim ;
-
-: width ( -- width ) get-size first ;
-: height ( -- height ) get-size second ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: setup-called
-
-: setup-called? ( -- ? ) setup-called get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run ( -- )
-
- loop-flag off
-
- 500 sleep
-
- <processing-gadget>
- size-val get >>pdim
- dup "Processing" open-window
-
- 500 sleep
-
- defaults
-
- setup-called off
-
- [
- setup-called? not
- [
- setup-action get call
- setup-called on
- ]
- [
- draw-action get call
- ]
- if
- ]
- closed-quot >>action
-
- key-down-action get >>key-down
- key-up-action get >>key-up
-
- button-down-action get >>button-down
- button-up-action get >>button-up
-
- processing-gadget set
-
- start-processing-thread ;
\ No newline at end of file
C: <block> block
C: <end> end
-: <failure> 0 <end> ; inline
-: <success> 1 <end> ; inline
+: <failure> ( -- end ) 0 <end> ; inline
+: <success> ( -- end ) 1 <end> ; inline
: failure? ( t -- ? ) ways>> 0 = ; inline
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: definitions io io.files kernel math math.parser
+USING: definitions io io.files io.pathnames kernel math math.parser
prettyprint project-euler.ave-time sequences vocabs vocabs.loader
project-euler.001 project-euler.002 project-euler.003 project-euler.004
project-euler.005 project-euler.006 project-euler.007 project-euler.008
: (>roman) ( n -- )
roman-values roman-digits [
- >r /mod swap r> <repetition> concat %
+ [ /mod swap ] dip <repetition> concat %
] 2each drop ;
: (roman>) ( seq -- n )
[ roman> ] bi@ ;
: binary-roman-op ( str1 str2 quot -- str3 )
- >r 2roman> r> call >roman ; inline
+ [ 2roman> ] dip call >roman ; inline
PRIVATE>
[ /i ] binary-roman-op ;
: roman/mod ( str1 str2 -- str3 str4 )
- [ /mod ] binary-roman-op >r >roman r> ;
+ [ /mod ] binary-roman-op [ >roman ] dip ;
: ROMAN: scan roman> parsed ; parsing
-
USING: kernel parser words continuations namespaces debugger
- sequences combinators splitting prettyprint
- system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep
- accessors multi-methods newfx shell.parser
- combinators.short-circuit eval environment ;
-
+sequences combinators splitting prettyprint system io io.files
+io.pathnames io.launcher io.directories io.encodings.utf8 io.pipes
+sequences.deep accessors multi-methods newfx shell.parser
+combinators.short-circuit eval environment ;
IN: shell
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-USING: arrays assocs kernel vectors sequences namespaces
- random math.parser math fry ;
-
-IN: assocs.lib
-
-: set-assoc-stack ( value key seq -- )
- dupd [ key? ] with find-last nip set-at ;
-
-: at-default ( key assoc -- value/key )
- dupd at [ nip ] when* ;
-
-: replace-at ( assoc value key -- assoc )
- >r >r dup r> 1vector r> rot set-at ;
-
-: peek-at* ( assoc key -- obj ? )
- swap at* dup [ >r peek r> ] when ;
-
-: peek-at ( assoc key -- obj )
- peek-at* drop ;
-
-: >multi-assoc ( assoc -- new-assoc )
- [ 1vector ] assoc-map ;
-
-: multi-assoc-each ( assoc quot -- )
- [ with each ] curry assoc-each ; inline
-
-: insert ( value variable -- ) namespace push-at ;
-
-: generate-key ( assoc -- str )
- >r 32 random-bits >hex r>
- 2dup key? [ nip generate-key ] [ drop ] if ;
-
-: set-at-unique ( value assoc -- key )
- dup generate-key [ swap set-at ] keep ;
-
-: histogram ( assoc quot -- assoc' )
- H{ } clone [
- swap [ change-at ] 2curry assoc-each
- ] keep ; inline
-
-: inc-at ( key assoc -- )
- [ 0 or 1 + ] change-at ;
-
-: ?at ( obj assoc -- value/obj ? )
- dupd at* [ [ nip ] [ drop ] if ] keep ;
-
-: if-at ( obj assoc quot1 quot2 -- )
- [ ?at ] 2dip if ; inline
-
-: when-at ( obj assoc quot -- ) [ ] if-at ; inline
-
-: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline
! quot is ( state string -- output-string )
[ missing-state ] <array> dup
[
- [ >r dup [ data>> ] [ place>> ] bi r> ] %
+ [ [ dup [ data>> ] [ place>> ] bi ] dip ] %
[ swapd bounds-check dispatch ] curry ,
[ each pick (>>place) swap (>>date) ] %
] [ ] make [ over make ] curry ;
: define-machine ( word state-class -- )
execute make-machine
- >r over r> define
+ [ over ] dip define
"state-table" set-word-prop ;
: MACHINE:
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: unix alien alien.c-types kernel math sequences strings
-io.unix.backend splitting ;
+io.backend.unix splitting ;
IN: system-info.linux
: (uname) ( buf -- int )
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax
byte-arrays kernel namespaces sequences unix
-system-info.backend system io.unix.backend io.encodings.utf8 ;
+system-info.backend system io.encodings.utf8 ;
IN: system-info.macosx
! See /usr/include/sys/sysctl.h for constants
-USING: combinators io io.files io.streams.string kernel math
-math.parser continuations namespaces pack prettyprint sequences
-strings system tools.hexdump io.encodings.binary summary accessors
-io.backend symbols byte-arrays ;
+USING: combinators io io.files io.files.links io.directories
+io.pathnames io.streams.string kernel math math.parser
+continuations namespaces pack prettyprint sequences strings
+system tools.hexdump io.encodings.binary summary accessors
+io.backend byte-arrays ;
IN: tar
: zero-checksum 256 ; inline
] if ;
: net ( salary w4 collector -- x )
- >r dupd r> total-withholding - ;
+ [ dupd ] dip total-withholding - ;
[ <new-tetris> ] change-tetris ;
tetris-gadget H{
+ { T{ button-down f f 1 } [ request-focus ] }
{ T{ key-down f f "UP" } [ tetris>> rotate-right ] }
{ T{ key-down f f "d" } [ tetris>> rotate-left ] }
{ T{ key-down f f "f" } [ tetris>> rotate-right ] }
+++ /dev/null
-John Benediktsson
+++ /dev/null
-
-USING: help.syntax help.markup kernel prettyprint sequences strings ;
-
-IN: time
-
-HELP: strftime
-{ $values { "format-string" string } }
-{ $description "Writes the timestamp (specified on the stack) formatted according to the format string." }
-;
-
-ARTICLE: "strftime" "Formatted timestamps"
-"The " { $vocab-link "time" } " vocabulary is used for formatted timestamps.\n"
-{ $subsection strftime }
-"\n"
-"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n"
-{ $table
- { "%a" "Abbreviated weekday name." }
- { "%A" "Full weekday name." }
- { "%b" "Abbreviated month name." }
- { "%B" "Full month name." }
- { "%c" "Date and time representation." }
- { "%d" "Day of the month as a decimal number [01,31]." }
- { "%H" "Hour (24-hour clock) as a decimal number [00,23]." }
- { "%I" "Hour (12-hour clock) as a decimal number [01,12]." }
- { "%j" "Day of the year as a decimal number [001,366]." }
- { "%m" "Month as a decimal number [01,12]." }
- { "%M" "Minute as a decimal number [00,59]." }
- { "%p" "Either AM or PM." }
- { "%S" "Second as a decimal number [00,59]." }
- { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal number [00,53]." }
- { "%w" "Weekday as a decimal number [0(Sunday),6]." }
- { "%W" "Week number of the year (Monday as the first day of the week) as a decimal number [00,53]." }
- { "%x" "Date representation." }
- { "%X" "Time representation." }
- { "%y" "Year without century as a decimal number [00,99]." }
- { "%Y" "Year with century as a decimal number." }
- { "%Z" "Time zone name (no characters if no time zone exists)." }
- { "%%" "A literal '%' character." }
-} ;
-
-ABOUT: "strftime"
-
-
+++ /dev/null
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: kernel time tools.test calendar ;
-
-IN: time.tests
-
-[ "%H:%M:%S" strftime ] must-infer
-
-: testtime ( -- timestamp )
- 2008 10 9 12 3 15 instant <timestamp> ;
-
-[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
-[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
-
-[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
-[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
-
-[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
-[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
-
-[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
-[ t ] [ "October" testtime "%B" strftime = ] unit-test
-
+++ /dev/null
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: accessors arrays calendar io kernel fry macros math
-math.functions math.parser peg.ebnf sequences strings vectors ;
-
-IN: time
-
-: >timestring ( timestamp -- string )
- [ hour>> ] keep [ minute>> ] keep second>> 3array
- [ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline
-
-: >datestring ( timestamp -- string )
- [ month>> ] keep [ day>> ] keep year>> 3array
- [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline
-
-: (week-of-year) ( timestamp day -- n )
- [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
- [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
-
-: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
-
-: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline
-
-
-<PRIVATE
-
-EBNF: parse-format-string
-
-fmt-% = "%" => [[ [ "%" ] ]]
-fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]]
-fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
-fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
-fmt-B = "B" => [[ [ dup month>> month-name ] ]]
-fmt-c = "c" => [[ [ "Not yet implemented" throw ] ]]
-fmt-d = "d" => [[ [ dup day>> number>string 2 CHAR: 0 pad-left ] ]]
-fmt-H = "H" => [[ [ dup hour>> number>string 2 CHAR: 0 pad-left ] ]]
-fmt-I = "I" => [[ [ dup hour>> 12 > [ 12 - ] when number>string 2 CHAR: 0 pad-left ] ]]
-fmt-j = "j" => [[ [ dup day-of-year number>string ] ]]
-fmt-m = "m" => [[ [ dup month>> number>string 2 CHAR: 0 pad-left ] ]]
-fmt-M = "M" => [[ [ dup minute>> number>string 2 CHAR: 0 pad-left ] ]]
-fmt-p = "p" => [[ [ dup hour>> 12 < [ "AM" ] [ "PM" ] ? ] ]]
-fmt-S = "S" => [[ [ dup second>> round number>string 2 CHAR: 0 pad-left ] ]]
-fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]]
-fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
-fmt-W = "W" => [[ [ dup week-of-year-monday ] ]]
-fmt-x = "x" => [[ [ dup >datestring ] ]]
-fmt-X = "X" => [[ [ dup >timestring ] ]]
-fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]]
-fmt-Y = "Y" => [[ [ dup year>> number>string ] ]]
-fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
-unknown = (.)* => [[ "Unknown directive" throw ]]
-
-formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
- fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|
- fmt-X|fmt-y|fmt-Y|fmt-Z|unknown
-
-formats = "%" (formats_) => [[ second '[ _ dip ] ]]
-
-plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
-
-text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
-
-;EBNF
-
-PRIVATE>
-
-MACRO: strftime ( format-string -- )
- parse-format-string [ length ] keep [ ] join
- '[ _ <vector> @ reverse concat nip ] ;
-
-
+++ /dev/null
-
-USING: kernel alien.c-types combinators sequences splitting grouping
- opengl.gl ui.gadgets ui.render
- math math.vectors accessors math.geometry.rect ;
-
-IN: ui.gadgets.frame-buffer
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
- dup
- rect-dim product "uint[4]" <c-array>
- >>pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new-frame-buffer ( class -- gadget )
- new-gadget
- [ ] >>action
- { 100 100 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-pixels ( fb -- fb )
- dup >r
- dup >r
- rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
- r> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: read-pixels ( fb -- fb )
- dup >r
- dup >r
- >r
- 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
- r> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer pref-dim* pdim>> ;
-M: frame-buffer graft* graft>> call ;
-M: frame-buffer ungraft* ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: copy-row ( old new -- )
- 2dup min-length swap >r head-slice 0 r> copy ;
-
-! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
-! [ group ] 2bi@
-! [ copy-row ] 2each ;
-
-! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
-! [ 16 * group ] 2bi@
-! [ copy-row ] 2each ;
-
-: copy-pixels ( old-pixels old-width new-pixels new-width -- )
- [ 16 * <sliced-groups> ] 2bi@
- [ copy-row ] 2each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer layout* ( fb -- )
- {
- {
- [ dup last-dim>> f = ]
- [
- init-frame-buffer-pixels
- dup
- rect-dim >>last-dim
- drop
- ]
- }
- {
- [ dup [ rect-dim ] [ last-dim>> ] bi = not ]
- [
- dup [ pixels>> ] [ last-dim>> first ] bi
-
- rot init-frame-buffer-pixels
- dup rect-dim >>last-dim
-
- [ pixels>> ] [ rect-dim first ] bi
-
- copy-pixels
- ]
- }
- { [ t ] [ drop ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer draw-gadget* ( fb -- )
-
- dup rect-dim { 0 1 } v* first2 glRasterPos2i
-
- draw-pixels
-
- dup action>> call
-
- glFlush
-
- read-pixels
-
- drop ;
-
: d= ( d d -- ? ) comparison-op number= ;
-: d~ ( d d delta -- ? ) >r comparison-op r> ~ ;
+: d~ ( d d delta -- ? ) [ comparison-op ] dip ~ ;
: d-min ( d d -- d ) [ d< ] most ;
-
-USING: namespaces debugger io.files bootstrap.image update.util ;
-
+USING: namespaces debugger io.files io.directories
+bootstrap.image update.util ;
IN: update.backup
: backup-boot-image ( -- )
-
-USING: kernel namespaces system io.files bootstrap.image http.client
- update update.backup update.util ;
-
+USING: kernel namespaces system io.files io.pathnames io.directories
+bootstrap.image http.client update update.backup update.util ;
IN: update.latest
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: kernel system sequences io.files io.launcher bootstrap.image
- http.client
- update.util ;
-
- ! builder.util builder.release.branch ;
-
+USING: kernel system sequences io.files io.directories
+io.pathnames io.launcher bootstrap.image http.client update.util ;
IN: update
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii sequences generalizations
-math.parser combinators kernel memoize csv symbols summary
+math.parser combinators kernel memoize csv summary
words accessors math.order binary-search ;
IN: usa-cities
{ $slide "Object system"
"New operation, existing types:"
{ $code
- "GENERIC: perimiter ( shape -- n )"
+ "GENERIC: perimeter ( shape -- n )"
""
- "M: rectangle perimiter"
+ "M: rectangle perimeter"
" [ width>> ] [ height>> ] bi + 2 * ;"
""
- "M: circle perimiter"
+ "M: circle perimeter"
" radius>> 2 * pi * ;"
}
}
{ $slide "Object system"
"We can compute perimiters now."
- { $code "100 20 <rectangle> perimiter ." }
- { $code "3 <circle> perimiter ." }
+ { $code "100 20 <rectangle> perimeter ." }
+ { $code "3 <circle> perimeter ." }
}
{ $slide "Object system"
"New type, extending existing operations:"
{ $code
": hypotenuse ( x y -- z ) [ sq ] bi@ + sqrt ;"
""
- "M: triangle perimiter"
+ "M: triangle perimeter"
" [ base>> ] [ height>> ] bi"
" [ + ] [ hypotenuse ] 2bi + ;"
}
"Libraries can define new parsing words"
}
{ $slide "Example: float arrays"
- { $vocab-link "float-arrays" }
+ { $vocab-link "specialized-arrays.float" }
"Avoids boxing and unboxing overhead"
"Implemented with library code"
- { $code "F{ 3.14 7.6 10.3 }" }
+ { $code "float-array{ 3.14 7.6 10.3 }" }
}
{ $slide "Example: memoization"
{ "Memoization with " { $link POSTPONE: MEMO: } }
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors http.server.dispatchers
http.server.static furnace.actions furnace.redirection urls
-validators locals io.files html.forms html.components help.html ;
+validators locals io.files io.directories html.forms
+html.components help.html ;
IN: webapps.help
TUPLE: help-webapp < dispatcher ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar kernel http.server.dispatchers prettyprint
-sequences printf furnace.actions html.forms accessors
+sequences formatting furnace.actions html.forms accessors
furnace.redirection ;
IN: webapps.irc-log
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar random assocs
namespaces make splitting sequences sorting math.order present
-io.files io.encodings.ascii
+io.files io.directories io.encodings.ascii
syndication farkup
html.components html.forms
http.server
USING: tools.deploy.config ;
H{
+ { deploy-io 1 }
+ { deploy-threads? f }
+ { deploy-word-defs? f }
{ deploy-ui? f }
{ deploy-compiler? t }
+ { deploy-word-props? f }
+ { "stop-after-last-window?" t }
+ { deploy-unicode? f }
{ deploy-c-types? f }
+ { deploy-math? f }
{ deploy-reflection 1 }
{ deploy-name "WebKit demo" }
- { deploy-io 1 }
- { deploy-math? f }
- { deploy-word-props? f }
- { "stop-after-last-window?" t }
- { deploy-word-defs? f }
- { deploy-threads? f }
}
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs io.files io.sockets
-io.sockets.secure io.servers.connection
+USING: accessors kernel sequences assocs io.files io.pathnames
+io.sockets io.sockets.secure io.servers.connection
namespaces db db.tuples db.sqlite smtp urls
logging.insomniac
html.templates.chloe
Quick key reference
-------------------
-(Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
-the same as C-cz)).
+(Triple chords ending in a single letter <x> accept also C-<x> (e.g.
+C-cC-eC-r is the same as C-cC-er)).
* In factor source files:
- C-cz : switch to listener
- C-co : cycle between code, tests and docs factor files
- - M-. : edit word at point in Emacs (also in listener)
+ - M-. : edit word at point in Emacs
+ - M-TAB : complete word at point
+ - C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary)
+ - C-cC-ew : edit word (M-x fuel-edit-word)
- C-cr, C-cC-er : eval region
- C-M-r, C-cC-ee : eval region, extending it to definition boundaries
- C-M-x, C-cC-ex : eval definition around point
- - C-ck, C-cC-ek : compile file
+ - C-ck, C-cC-ek : run file
- C-cC-da : toggle autodoc mode
- C-cC-dd : help for word at point
- C-cC-ds : short help word at point
+* In the listener:
+
+ - TAB : complete word at point
+ - M-. : edit word at point in Emacs
+ - C-ca : toggle autodoc mode
+ - C-cv : edit vocabulary
+ - C-ch : help for word at point
+ - C-ck : run file
+
* In the debugger (it pops up upon eval/compilation errors):
- g : go to error
(set (make-local-variable 'beginning-of-defun-function)
'fuel-syntax--beginning-of-defun)
(set (make-local-variable 'end-of-defun-function) 'fuel-syntax--end-of-defun)
- (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
- (fuel-syntax--enable-usings))
+ (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil))
\f
;;; Indentation:
(save-excursion
(beginning-of-line)
(when (> (fuel-syntax--brackets-depth) 0)
- (let ((op (fuel-syntax--brackets-start))
- (cl (fuel-syntax--brackets-end))
- (ln (line-number-at-pos)))
+ (let* ((op (fuel-syntax--brackets-start))
+ (cl (fuel-syntax--brackets-end))
+ (ln (line-number-at-pos))
+ (iop (fuel-syntax--indentation-at op)))
(when (> ln (line-number-at-pos op))
- (if (and (> cl 0) (= ln (line-number-at-pos cl)))
- (fuel-syntax--indentation-at op)
- (fuel-syntax--increased-indentation (fuel-syntax--indentation-at op))))))))
+ (if (and (> cl 0)
+ (= (- cl (point)) (current-indentation))
+ (= ln (line-number-at-pos cl)))
+ iop
+ (fuel-syntax--increased-indentation iop)))))))
(defun factor-mode--indent-definition ()
(save-excursion
(defsubst empty-string-p (str) (equal str ""))
+(defun fuel--respecting-message (format &rest format-args)
+ "Display TEXT as a message, without hiding any minibuffer contents."
+ (let ((text (format " [%s]" (apply #'format format format-args))))
+ (if (minibuffer-window-active-p (minibuffer-window))
+ (minibuffer-message text)
+ (message "%s" text))))
+
(provide 'fuel-base)
;;; fuel-base.el ends here
--- /dev/null
+;;; fuel-completion.el -- completion utilities
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sun Dec 14, 2008 21:17
+
+;;; Comentary:
+
+;; Code completion utilities.
+
+;;; Code:
+
+(require 'fuel-base)
+(require 'fuel-syntax)
+(require 'fuel-eval)
+(require 'fuel-log)
+
+\f
+;;; Vocabs dictionary:
+
+(defvar fuel-completion--vocabs nil)
+
+(defun fuel-completion--vocabs (&optional reload)
+ (when (or reload (not fuel-completion--vocabs))
+ (fuel--respecting-message "Retrieving vocabs list")
+ (let ((fuel-log--inhibit-p t))
+ (setq fuel-completion--vocabs
+ (fuel-eval--retort-result
+ (fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
+ fuel-completion--vocabs)
+
+(defun fuel-completion--words (prefix vocabs)
+ (let ((vs (if vocabs (cons :array vocabs) 'f))
+ (us (or vocabs 't)))
+ (fuel-eval--retort-result
+ (fuel-eval--send/wait `(:fuel* (,prefix ,vs fuel-get-words) t ,us)))))
+
+\f
+;;; Completions window handling, heavily inspired in slime's:
+
+(defvar fuel-completion--comp-buffer "*Completions*")
+
+(make-variable-buffer-local
+ (defvar fuel-completion--window-cfg nil
+ "Window configuration before we show the *Completions* buffer.
+This is buffer local in the buffer where the completion is
+performed."))
+
+(make-variable-buffer-local
+ (defvar fuel-completion--completions-window nil
+ "The window displaying *Completions* after saving window configuration.
+If this window is no longer active or displaying the completions
+buffer then we can ignore `fuel-completion--window-cfg'."))
+
+(defun fuel-completion--maybe-save-window-configuration ()
+ "Maybe save the current window configuration.
+Return true if the configuration was saved."
+ (unless (or fuel-completion--window-cfg
+ (get-buffer-window fuel-completion--comp-buffer))
+ (setq fuel-completion--window-cfg
+ (current-window-configuration))
+ t))
+
+(defun fuel-completion--delay-restoration ()
+ (add-hook 'pre-command-hook
+ 'fuel-completion--maybe-restore-window-configuration
+ nil t))
+
+(defun fuel-completion--forget-window-configuration ()
+ (setq fuel-completion--window-cfg nil)
+ (setq fuel-completion--completions-window nil))
+
+(defun fuel-completion--restore-window-configuration ()
+ "Restore the window config if available."
+ (remove-hook 'pre-command-hook
+ 'fuel-completion--maybe-restore-window-configuration)
+ (when (and fuel-completion--window-cfg
+ (fuel-completion--window-active-p))
+ (save-excursion
+ (set-window-configuration fuel-completion--window-cfg))
+ (setq fuel-completion--window-cfg nil)
+ (when (buffer-live-p fuel-completion--comp-buffer)
+ (kill-buffer fuel-completion--comp-buffer))))
+
+(defun fuel-completion--maybe-restore-window-configuration ()
+ "Restore the window configuration, if the following command
+terminates a current completion."
+ (remove-hook 'pre-command-hook
+ 'fuel-completion--maybe-restore-window-configuration)
+ (condition-case err
+ (cond ((find last-command-char "()\"'`,# \r\n:")
+ (fuel-completion--restore-window-configuration))
+ ((not (fuel-completion--window-active-p))
+ (fuel-completion--forget-window-configuration))
+ (t (fuel-completion--delay-restoration)))
+ (error
+ ;; Because this is called on the pre-command-hook, we mustn't let
+ ;; errors propagate.
+ (message "Error in fuel-completion--restore-window-configuration: %S" err))))
+
+(defun fuel-completion--window-active-p ()
+ "Is the completion window currently active?"
+ (and (window-live-p fuel-completion--completions-window)
+ (equal (buffer-name (window-buffer fuel-completion--completions-window))
+ fuel-completion--comp-buffer)))
+
+(defun fuel-completion--display-comp-list (completions base)
+ (let ((savedp (fuel-completion--maybe-save-window-configuration)))
+ (with-output-to-temp-buffer fuel-completion--comp-buffer
+ (display-completion-list completions base)
+ (let ((offset (- (point) 1 (length base))))
+ (with-current-buffer standard-output
+ (setq completion-base-size offset)
+ (set-syntax-table fuel-syntax--syntax-table))))
+ (when savedp
+ (setq fuel-completion--completions-window
+ (get-buffer-window fuel-completion--comp-buffer)))))
+
+(defun fuel-completion--display-or-scroll (completions base)
+ (cond ((and (eq last-command this-command) (fuel-completion--window-active-p))
+ (fuel-completion--scroll-completions))
+ (t (fuel-completion--display-comp-list completions base)))
+ (fuel-completion--delay-restoration))
+
+(defun fuel-completion--scroll-completions ()
+ (let ((window fuel-completion--completions-window))
+ (with-current-buffer (window-buffer window)
+ (if (pos-visible-in-window-p (point-max) window)
+ (set-window-start window (point-min))
+ (save-selected-window
+ (select-window window)
+ (scroll-up))))))
+
+\f
+;;; Completion functionality:
+
+(defun fuel-completion--word-list (prefix)
+ (let* ((fuel-log--inhibit-p t)
+ (cv (fuel-syntax--current-vocab))
+ (vs (and cv `("syntax" ,cv ,@(fuel-syntax--usings)))))
+ (fuel-completion--words prefix vs)))
+
+(defsubst fuel-completion--all-words-list (prefix)
+ (fuel-completion--words prefix nil))
+
+(defvar fuel-completion--word-list-func
+ (completion-table-dynamic 'fuel-completion--word-list))
+
+(defvar fuel-completion--all-words-list-func
+ (completion-table-dynamic 'fuel-completion--all-words-list))
+
+(defun fuel-completion--complete (prefix)
+ (let* ((words (fuel-completion--word-list prefix))
+ (completions (all-completions prefix words))
+ (partial (try-completion prefix words))
+ (partial (if (eq partial t) prefix partial)))
+ (cons completions partial)))
+
+(defsubst fuel-completion--read-word (prompt &optional default history all)
+ (completing-read prompt
+ (if all fuel-completion--all-words-list-func
+ fuel-completion--word-list-func)
+ nil nil nil
+ history
+ (or default (fuel-syntax-symbol-at-point))))
+
+(defun fuel-completion--complete-symbol ()
+ "Complete the symbol at point.
+Perform completion similar to Emacs' complete-symbol."
+ (interactive)
+ (let* ((end (point))
+ (beg (fuel-syntax--symbol-start))
+ (prefix (buffer-substring-no-properties beg end))
+ (result (fuel-completion--complete prefix))
+ (completions (car result))
+ (partial (cdr result)))
+ (cond ((null completions)
+ (fuel--respecting-message "Can't find completion for %S" prefix)
+ (fuel-completion--restore-window-configuration))
+ (t (insert-and-inherit (substring partial (length prefix)))
+ (cond ((= (length completions) 1)
+ (fuel--respecting-message "Sole completion")
+ (fuel-completion--restore-window-configuration))
+ (t (fuel--respecting-message "Complete but not unique")
+ (fuel-completion--display-or-scroll completions
+ partial)))))))
+
+\f
+(provide 'fuel-completion)
+;;; fuel-completion.el ends here
;;; Code:
+(require 'fuel-log)
+(require 'fuel-base)
+
+(require 'comint)
+(require 'advice)
+
\f
;;; Default connection:
(cons :id (random))
(cons :string str)
(cons :continuation cont)
- (cons :buffer (or sender-buffer (current-buffer)))))
+ (cons :buffer (or sender-buffer (current-buffer)))
+ (cons :output "")))
(defsubst fuel-con--request-p (req)
(and (listp req) (eq (car req) :fuel-connection-request)))
(defsubst fuel-con--request-buffer (req)
(cdr (assoc :buffer req)))
+(defun fuel-con--request-output (req &optional suffix)
+ (let ((cell (assoc :output req)))
+ (when suffix (setcdr cell (concat (cdr cell) suffix)))
+ (cdr cell)))
+
(defsubst fuel-con--request-deactivate (req)
(setcdr (assoc :continuation req) nil))
(defsubst fuel-con--make-connection (buffer)
(list :fuel-connection
- (list :requests)
- (list :current)
+ (cons :requests (list))
+ (cons :current nil)
(cons :completed (make-hash-table :weakness 'value))
- (cons :buffer buffer)))
+ (cons :buffer buffer)
+ (cons :timer nil)))
(defsubst fuel-con--connection-p (c)
(and (listp c) (eq (car c) :fuel-connection)))
(let ((reqs (assoc :requests c))
(current (assoc :current c)))
(setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
- (if (and current (fuel-con--request-deactivated-p current))
+ (if (and (cdr current)
+ (fuel-con--request-deactivated-p (cdr current)))
(fuel-con--connection-pop-request c)
- current)))
+ (cdr current))))
+
+(defun fuel-con--connection-start-timer (c)
+ (let ((cell (assoc :timer c)))
+ (when (cdr cell) (cancel-timer (cdr cell)))
+ (setcdr cell (run-at-time t 0.5 'fuel-con--process-next c))))
+
+(defun fuel-con--connection-cancel-timer (c)
+ (let ((cell (assoc :timer c)))
+ (when (cdr cell) (cancel-timer (cdr cell)))))
\f
;;; Connection setup:
+(defun fuel-con--cleanup-connection (c)
+ (fuel-con--connection-cancel-timer c))
+
(defun fuel-con--setup-connection (buffer)
(set-buffer buffer)
+ (fuel-con--cleanup-connection fuel-con--connection)
(let ((conn (fuel-con--make-connection buffer)))
(fuel-con--setup-comint)
- (setq fuel-con--connection conn)))
+ (prog1
+ (setq fuel-con--connection conn)
+ (fuel-con--connection-start-timer conn))))
+
+(defconst fuel-con--prompt-regex "( .+ ) ")
+(defconst fuel-con--eot-marker "EOT:")
+(defconst fuel-con--init-stanza (format "USE: fuel %S write" fuel-con--eot-marker))
+
+(defconst fuel-con--comint-finished-regex
+ (format "%s%s" fuel-con--eot-marker fuel-con--prompt-regex))
(defun fuel-con--setup-comint ()
+ (comint-redirect-cleanup)
(add-hook 'comint-redirect-filter-functions
- 'fuel-con--comint-redirect-filter t t))
+ 'fuel-con--comint-redirect-filter t t)
+ (add-hook 'comint-redirect-hook
+ 'fuel-con--comint-redirect-hook nil t))
+
+(defadvice comint-redirect-setup (after fuel-con--advice activate)
+ (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))
\f
;;; Requests handling:
(let* ((buffer (fuel-con--connection-buffer con))
(req (fuel-con--connection-pop-request con))
(str (and req (fuel-con--request-string req))))
- (when (and buffer req str)
- (set-buffer buffer)
- (comint-redirect-send-command str
- (get-buffer-create "*factor messages*")
- nil
- t)))))
+ (if (not (buffer-live-p buffer))
+ (fuel-con--connection-cancel-timer con)
+ (when (and buffer req str)
+ (set-buffer buffer)
+ (fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)
+ (comint-redirect-send-command (format "%s" str)
+ (fuel-log--buffer) nil t))))))
+
+(defun fuel-con--process-completed-request (req)
+ (let ((str (fuel-con--request-output req))
+ (cont (fuel-con--request-continuation req))
+ (id (fuel-con--request-id req))
+ (rstr (fuel-con--request-string req))
+ (buffer (fuel-con--request-buffer req)))
+ (if (not cont)
+ (fuel-log--warn "<%s> Droping result for request %S (%s)"
+ id rstr str)
+ (condition-case cerr
+ (with-current-buffer (or buffer (current-buffer))
+ (funcall cont str)
+ (fuel-log--info "<%s>: processed\n\t%s" id str))
+ (error (fuel-log--error "<%s>: continuation failed %S \n\t%s"
+ id rstr cerr))))))
+
+(defvar fuel-con--debug-comint-p nil)
(defun fuel-con--comint-redirect-filter (str)
(if (not fuel-con--connection)
- (format "\nERROR: No connection in buffer (%s)\n" str)
+ (fuel-log--error "No connection in buffer (%s)" str)
+ (let ((req (fuel-con--connection-current-request fuel-con--connection)))
+ (if (not req) (fuel-log--error "No current request (%s)" str)
+ (fuel-con--request-output req str)
+ (fuel-log--info "<%s>: in progress" (fuel-con--request-id req)))))
+ (if fuel-con--debug-comint-p (fuel--shorten-str str 256) ""))
+
+(defun fuel-con--comint-redirect-hook ()
+ (if (not fuel-con--connection)
+ (fuel-log--error "No connection in buffer")
(let ((req (fuel-con--connection-current-request fuel-con--connection)))
- (if (not req) (format "\nERROR: No current request (%s)\n" str)
- (let ((cont (fuel-con--request-continuation req))
- (id (fuel-con--request-id req))
- (rstr (fuel-con--request-string req))
- (buffer (fuel-con--request-buffer req)))
- (prog1
- (if (not cont)
- (format "\nWARNING: Droping result for request %s:%S (%s)\n"
- id rstr str)
- (condition-case cerr
- (with-current-buffer (or buffer (current-buffer))
- (funcall cont str)
- (format "\nINFO: %s:%S processed\nINFO: %s\n" id rstr str))
- (error (format "\nERROR: continuation failed %s:%S \nERROR: %s\n"
- id rstr cerr))))
- (fuel-con--connection-clean-current-request fuel-con--connection)))))))
+ (if (not req) (fuel-log--error "No current request")
+ (fuel-con--process-completed-request req)
+ (fuel-con--connection-clean-current-request fuel-con--connection)))))
\f
;;; Message sending interface:
(defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
(save-current-buffer
(let* ((con (fuel-con--get-connection buffer/proc))
- (req (fuel-con--send-string buffer/proc str cont sbuf))
- (id (and req (fuel-con--request-id req)))
- (time (or timeout fuel-connection-timeout))
- (step 2))
+ (req (fuel-con--send-string buffer/proc str cont sbuf))
+ (id (and req (fuel-con--request-id req)))
+ (time (or timeout fuel-connection-timeout))
+ (step 100)
+ (waitsecs (/ step 1000.0)))
(when id
- (while (and (> time 0)
- (not (fuel-con--connection-completed-p con id)))
- (sleep-for 0 step)
- (setq time (- time step)))
+ (condition-case nil
+ (while (and (> time 0)
+ (not (fuel-con--connection-completed-p con id)))
+ (accept-process-output nil waitsecs)
+ (setq time (- time step)))
+ (error (setq time 1)))
(or (> time 0)
(fuel-con--request-deactivate req)
nil)))))
(setq fuel-debug--last-ret ret)
(setq fuel-debug--file file)
(goto-char (point-max))
+ (font-lock-fontify-buffer)
(when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))
(not err))))
(trail (and last (substring-no-properties last (/ llen 2))))
(err (fuel-eval--retort-error ret))
(p (point)))
- (save-excursion (insert current))
+ (when current (save-excursion (insert current)))
(when (and (> clen llen) (> llen 0) (search-forward trail nil t))
(delete-region p (point)))
(goto-char (point-max))
(buffer (if file (find-file-noselect file) (current-buffer))))
(with-current-buffer buffer
(fuel-debug--display-retort
- (fuel-eval--send/wait (fuel-eval--cmd/string (format ":%s" n)))
+ (fuel-eval--send/wait `(:fuel ((:factor ,(format ":%s" n)))))
(format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
(defun fuel-debug-show--compiler-info (info)
(error "%s information not available" info))
(message "Retrieving %s info ..." info)
(unless (fuel-debug--display-retort
- (fuel-eval--send/wait (fuel-eval--cmd/string info))
+ (fuel-eval--send/wait `(:fuel ((:factor ,info))))
"" (fuel-debug--buffer-file))
(error "Sorry, no %s info available" info))))
\\{fuel-debug-mode-map}"
(interactive)
(kill-all-local-variables)
+ (buffer-disable-undo)
(setq major-mode 'factor-mode)
(setq mode-name "Fuel Debug")
(use-local-map fuel-debug-mode-map)
(fuel-debug--font-lock-setup)
(setq fuel-debug--file nil)
(setq fuel-debug--last-ret nil)
- (toggle-read-only 1)
+ (setq buffer-read-only t)
(run-hooks 'fuel-debug-mode-hook))
\f
(require 'fuel-syntax)
(require 'fuel-connection)
+(eval-when-compile (require 'cl))
+
+\f
+;;; Simple sexp-based representation of factor code
+
+(defun factor (sexp)
+ (cond ((null sexp) "f")
+ ((eq sexp t) "t")
+ ((or (stringp sexp) (numberp sexp)) (format "%S" sexp))
+ ((vectorp sexp) (cons :quotation (append sexp nil)))
+ ((listp sexp)
+ (case (car sexp)
+ (:array (factor--seq 'V{ '} (cdr sexp)))
+ (:quote (format "\\ %s" (factor `(:factor ,(cadr sexp)))))
+ (:quotation (factor--seq '\[ '\] (cdr sexp)))
+ (:factor (format "%s" (mapconcat 'identity (cdr sexp) " ")))
+ (:fuel (factor--fuel-factor (cons :rs (cdr sexp))))
+ (:fuel* (factor--fuel-factor (cons :nrs (cdr sexp))))
+ (t (mapconcat 'factor sexp " "))))
+ ((keywordp sexp)
+ (factor (case sexp
+ (:rs 'fuel-eval-restartable)
+ (:nrs 'fuel-eval-non-restartable)
+ (:in (fuel-syntax--current-vocab))
+ (:usings `(:array ,@(fuel-syntax--usings)))
+ (:get 'fuel-eval-set-result)
+ (t `(:factor ,(symbol-name sexp))))))
+ ((symbolp sexp) (symbol-name sexp))))
+
+(defsubst factor--seq (begin end forms)
+ (format "%s %s %s" begin (if forms (factor forms) "") end))
+
+(defsubst factor--fuel-factor (sexp)
+ (factor `(,(factor--fuel-restart (nth 0 sexp))
+ ,(factor--fuel-lines (nth 1 sexp))
+ ,(factor--fuel-in (nth 2 sexp))
+ ,(factor--fuel-usings (nth 3 sexp))
+ fuel-eval-in-context)))
+
+(defsubst factor--fuel-restart (rs)
+ (unless (member rs '(:rs :nrs))
+ (error "Invalid restart spec (%s)" rs))
+ rs)
+
+(defsubst factor--fuel-lines (lst)
+ (cons :array (mapcar 'factor lst)))
+
+(defsubst factor--fuel-in (in)
+ (cond ((null in) :in)
+ ((eq in t) "fuel-scratchpad")
+ ((stringp in) in)
+ (t (error "Invalid 'in' (%s)" in))))
+
+(defsubst factor--fuel-usings (usings)
+ (cond ((null usings) :usings)
+ ((eq usings t) nil)
+ ((listp usings) `(:array ,@usings))
+ (t (error "Invalid 'usings' (%s)" usings))))
+
+\f
+;;; Code sending:
+
+(defvar fuel-eval--default-proc-function nil)
+(defsubst fuel-eval--default-proc ()
+ (and fuel-eval--default-proc-function
+ (funcall fuel-eval--default-proc-function)))
+
+(defvar fuel-eval--proc nil)
+
+(defvar fuel-eval--sync-retort nil)
+
+(defun fuel-eval--send/wait (code &optional timeout buffer)
+ (setq fuel-eval--sync-retort nil)
+ (fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc))
+ (if (stringp code) code (factor code))
+ '(lambda (s)
+ (setq fuel-eval--sync-retort
+ (fuel-eval--parse-retort s)))
+ timeout
+ buffer)
+ fuel-eval--sync-retort)
+
+(defun fuel-eval--send (code cont &optional buffer)
+ (fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc))
+ (if (stringp code) code (factor code))
+ `(lambda (s) (,cont (fuel-eval--parse-retort s)))
+ buffer))
+
\f
;;; Retort and retort-error datatypes:
(defsubst fuel-eval--error-line-text (err)
(nth 3 (fuel-eval--error-lexer-p err)))
-\f
-;;; String sending::
-
-(defvar fuel-eval-log-max-length 16000)
-
-(defvar fuel-eval--default-proc-function nil)
-(defsubst fuel-eval--default-proc ()
- (and fuel-eval--default-proc-function
- (funcall fuel-eval--default-proc-function)))
-
-(defvar fuel-eval--proc nil)
-
-(defvar fuel-eval--log t)
-
-(defvar fuel-eval--sync-retort nil)
-
-(defun fuel-eval--send/wait (str &optional timeout buffer)
- (setq fuel-eval--sync-retort nil)
- (fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc))
- str
- '(lambda (s)
- (setq fuel-eval--sync-retort
- (fuel-eval--parse-retort s)))
- timeout
- buffer)
- fuel-eval--sync-retort)
-
-(defun fuel-eval--send (str cont &optional buffer)
- (fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc))
- str
- `(lambda (s) (,cont (fuel-eval--parse-retort s)))
- buffer))
-
-\f
-;;; Evaluation protocol
-
-(defsubst fuel-eval--factor-array (strs)
- (format "V{ %S }" (mapconcat 'identity strs " ")))
-
-(defun fuel-eval--cmd/lines (strs &optional no-rs in usings)
- (unless (and in usings) (fuel-syntax--usings-update))
- (let* ((in (cond ((not in) (or fuel-syntax--current-vocab "f"))
- ((eq in t) "fuel-scratchpad")
- (in in)))
- (usings (cond ((not usings) fuel-syntax--usings)
- ((eq usings t) nil)
- (usings usings))))
- (format "fuel-eval-%srestartable %s %S %s fuel-eval-in-context"
- (if no-rs "non-" "")
- (fuel-eval--factor-array strs)
- in
- (fuel-eval--factor-array usings))))
-
-(defsubst fuel-eval--cmd/string (str &optional no-rs in usings)
- (fuel-eval--cmd/lines (list str) no-rs in usings))
-
-(defun fuel-eval--cmd/region (begin end &optional no-rs in usings)
- (let ((lines (split-string (buffer-substring-no-properties begin end)
- "[\f\n\r\v]+" t)))
- (when (> (length lines) 0)
- (fuel-eval--cmd/lines lines no-rs in usings))))
-
-
\f
(provide 'fuel-eval)
;;; fuel-eval.el ends here
;;; Code:
-(require 'fuel-base)
-(require 'fuel-font-lock)
(require 'fuel-eval)
+(require 'fuel-completion)
+(require 'fuel-font-lock)
+(require 'fuel-base)
\f
;;; Customization:
(defun fuel-help--word-synopsis (&optional word)
(let ((word (or word (fuel-syntax-symbol-at-point)))
- (fuel-eval--log t))
+ (fuel-log--inhibit-p t))
(when word
- (let* ((str (format "\\ %s synopsis fuel-eval-set-result" word))
- (cmd (fuel-eval--cmd/string str t t))
+ (let* ((cmd `(:fuel* (((:quote ,word) synopsis :get)) t))
(ret (fuel-eval--send/wait cmd 20)))
(when (and ret (not (fuel-eval--retort-error ret)))
(if fuel-help-minibuffer-font-lock
;;; Help browser history:
(defvar fuel-help--history
- (list nil
- (make-ring fuel-help-history-cache-size)
- (make-ring fuel-help-history-cache-size)))
+ (list nil ; current
+ (make-ring fuel-help-history-cache-size) ; previous
+ (make-ring fuel-help-history-cache-size))) ; next
(defvar fuel-help--history-idx 0)
(defun fuel-help--history-push (term)
- (when (car fuel-help--history)
+ (when (and (car fuel-help--history)
+ (not (string= (caar fuel-help--history) (car term))))
(ring-insert (nth 1 fuel-help--history) (car fuel-help--history)))
(setcar fuel-help--history term))
;;; Fuel help buffer and internals:
(defun fuel-help--help-buffer ()
- (with-current-buffer (get-buffer-create "*fuel-help*")
+ (with-current-buffer (get-buffer-create "*fuel help*")
(fuel-help-mode)
(current-buffer)))
(ask (or (not (memq major-mode '(factor-mode fuel-help-mode)))
(not def)
fuel-help-always-ask))
- (def (if ask (read-string prompt nil 'fuel-help--prompt-history def)
+ (def (if ask (fuel-completion--read-word prompt
+ def
+ 'fuel-help--prompt-history)
def))
- (cmd (format "\\ %s %s" def (if see "see" "help"))))
+ (cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t)))
(message "Looking up '%s' ..." def)
- (fuel-eval--send (fuel-eval--cmd/string cmd t t)
- `(lambda (r) (fuel-help--show-help-cont ,def r)))))
+ (fuel-eval--send cmd `(lambda (r) (fuel-help--show-help-cont ,def r)))))
(defun fuel-help--show-help-cont (def ret)
(let ((out (fuel-eval--retort-output ret)))
(set-buffer hb)
(erase-buffer)
(insert str)
- (goto-char (point-min))
- (when (re-search-forward (format "^%s" def) nil t)
- (beginning-of-line)
- (kill-region (point-min) (point))
- (next-line)
- (open-line 1))
+ (unless nopush
+ (goto-char (point-min))
+ (when (re-search-forward (format "^%s" def) nil t)
+ (beginning-of-line)
+ (kill-region (point-min) (point))
+ (next-line)
+ (open-line 1)
+ (fuel-help--history-push (cons def (buffer-string)))))
(set-buffer-modified-p nil)
- (unless nopush (fuel-help--history-push (cons def str)))
(pop-to-buffer hb)
(goto-char (point-min))
(message "%s" def)))
(define-key map "q" 'bury-buffer)
(define-key map "b" 'fuel-help-previous)
(define-key map "f" 'fuel-help-next)
+ (define-key map "l" 'fuel-help-previous)
+ (define-key map "n" 'fuel-help-next)
(define-key map (kbd "SPC") 'scroll-up)
(define-key map (kbd "S-SPC") 'scroll-down)
map))
\\{fuel-help-mode-map}"
(interactive)
(kill-all-local-variables)
+ (buffer-disable-undo)
(use-local-map fuel-help-mode-map)
(setq mode-name "Factor Help")
(setq major-mode 'fuel-help-mode)
(fuel-autodoc-mode)
(run-mode-hooks 'fuel-help-mode-hook)
- (toggle-read-only 1))
+ (setq buffer-read-only t))
\f
(provide 'fuel-help)
;;; Code:
(require 'fuel-eval)
+(require 'fuel-completion)
+(require 'fuel-connection)
+(require 'fuel-syntax)
(require 'fuel-base)
+
(require 'comint)
\f
\f
;;; Fuel listener buffer/process:
-(defvar fuel-listener-buffer nil
+(defvar fuel-listener--buffer nil
"The buffer in which the Factor listener is running.")
+(defun fuel-listener--buffer ()
+ (if (buffer-live-p fuel-listener--buffer)
+ fuel-listener--buffer
+ (with-current-buffer (get-buffer-create "*fuel listener*")
+ (fuel-listener-mode)
+ (setq fuel-listener--buffer (current-buffer)))))
+
(defun fuel-listener--start-process ()
(let ((factor (expand-file-name fuel-listener-factor-binary))
- (image (expand-file-name fuel-listener-factor-image)))
+ (image (expand-file-name fuel-listener-factor-image))
+ (comint-redirect-perform-sanity-check nil))
(unless (file-executable-p factor)
(error "Could not run factor: %s is not executable" factor))
(unless (file-readable-p image)
(error "Could not run factor: image file %s not readable" image))
- (setq fuel-listener-buffer (get-buffer-create "*fuel listener*"))
- (with-current-buffer fuel-listener-buffer
- (fuel-listener-mode)
- (message "Starting FUEL listener ...")
- (comint-exec fuel-listener-buffer "factor"
- factor nil `("-run=fuel" ,(format "-i=%s" image)))
- (fuel-listener--wait-for-prompt 20)
- (fuel-eval--send/wait "USE: fuel")
- (message "FUEL listener up and running!"))))
+ (message "Starting FUEL listener ...")
+ (pop-to-buffer (fuel-listener--buffer))
+ (make-comint-in-buffer "fuel listener" (current-buffer) factor nil
+ "-run=listener" (format "-i=%s" image))
+ (fuel-listener--wait-for-prompt 10000)
+ (fuel-con--send-string/wait (current-buffer)
+ fuel-con--init-stanza
+ '(lambda (s) (message "FUEL listener up and running!"))
+ 20000)))
(defun fuel-listener--process (&optional start)
- (or (and (buffer-live-p fuel-listener-buffer)
- (get-buffer-process fuel-listener-buffer))
+ (or (and (buffer-live-p (fuel-listener--buffer))
+ (get-buffer-process (fuel-listener--buffer)))
(if (not start)
(error "No running factor listener (try M-x run-factor)")
(fuel-listener--start-process)
(setq fuel-eval--default-proc-function 'fuel-listener--process)
+(defun fuel-listener--wait-for-prompt (timeout)
+ (let ((p (point)) (seen))
+ (while (and (not seen) (> timeout 0))
+ (sleep-for 0.1)
+ (setq timeout (- timeout 100))
+ (goto-char p)
+ (setq seen (re-search-forward comint-prompt-regexp nil t)))
+ (goto-char (point-max))
+ (unless seen (error "No prompt found!"))))
+
\f
-;;; Prompt chasing
-
-(defun fuel-listener--wait-for-prompt (&optional timeout)
- (let ((proc (get-buffer-process fuel-listener-buffer)))
- (with-current-buffer fuel-listener-buffer
- (goto-char (or comint-last-input-end (point-min)))
- (let ((seen (re-search-forward comint-prompt-regexp nil t)))
- (while (and (not seen)
- (accept-process-output proc (or timeout 10) nil t))
- (sleep-for 0 1)
- (goto-char comint-last-input-end)
- (setq seen (re-search-forward comint-prompt-regexp nil t)))
- (pop-to-buffer fuel-listener-buffer)
- (goto-char (point-max))
- (unless seen (error "No prompt found!"))))))
+;;; Completion support
+
+(defsubst fuel-listener--current-vocab () nil)
+(defsubst fuel-listener--usings () nil)
+
+(defun fuel-listener--setup-completion ()
+ (setq fuel-syntax--current-vocab-function 'fuel-listener--current-vocab)
+ (setq fuel-syntax--usings-function 'fuel-listener--usings)
+ (set-syntax-table fuel-syntax--syntax-table))
\f
;;; Interface: starting fuel listener
\f
;;; Fuel listener mode:
-(defconst fuel-listener--prompt-regex "( [^)]* ) ")
-
(define-derived-mode fuel-listener-mode comint-mode "Fuel Listener"
"Major mode for interacting with an inferior Factor listener process.
\\{fuel-listener-mode-map}"
- (set (make-local-variable 'comint-prompt-regexp)
- fuel-listener--prompt-regex)
+ (set (make-local-variable 'comint-prompt-regexp) fuel-con--prompt-regex)
(set (make-local-variable 'comint-prompt-read-only) t)
- (setq fuel-listener--compilation-begin nil))
+ (fuel-listener--setup-completion))
(define-key fuel-listener-mode-map "\C-cz" 'run-factor)
(define-key fuel-listener-mode-map "\C-c\C-z" 'run-factor)
+(define-key fuel-listener-mode-map "\C-ca" 'fuel-autodoc-mode)
(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
+(define-key fuel-listener-mode-map "\C-cv" 'fuel-edit-vocabulary)
+(define-key fuel-listener-mode-map "\C-c\C-v" 'fuel-edit-vocabulary)
(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file)
+(define-key fuel-listener-mode-map (kbd "TAB") 'fuel-completion--complete-symbol)
\f
(provide 'fuel-listener)
--- /dev/null
+;;; fuel-log.el -- logging utilities
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sun Dec 14, 2008 01:00
+
+;;; Comentary:
+
+;; Some utilities for maintaining a simple log buffer, mainly for
+;; debugging purposes.
+
+;;; Code:
+
+(require 'fuel-base)
+
+\f
+;;; Customization:
+
+(defvar fuel-log--buffer-name "*fuel messages*"
+ "Name of the log buffer")
+
+(defvar fuel-log--max-buffer-size 32000
+ "Maximum size of the Factor messages log")
+
+(defvar fuel-log--max-message-size 512
+ "Maximum size of individual log messages")
+
+(defvar fuel-log--verbose-p t
+ "Log level for Factor messages")
+
+(defvar fuel-log--inhibit-p nil
+ "Set this to t to inhibit all log messages")
+
+(define-derived-mode factor-messages-mode fundamental-mode "FUEL Messages"
+ "Simple mode to log interactions with the factor listener"
+ (kill-all-local-variables)
+ (buffer-disable-undo)
+ (set (make-local-variable 'comint-redirect-subvert-readonly) t)
+ (add-hook 'after-change-functions
+ '(lambda (b e len)
+ (let ((inhibit-read-only t))
+ (when (> b fuel-log--max-buffer-size)
+ (delete-region (point-min) b))))
+ nil t)
+ (setq buffer-read-only t))
+
+(defun fuel-log--buffer ()
+ (or (get-buffer fuel-log--buffer-name)
+ (save-current-buffer
+ (set-buffer (get-buffer-create fuel-log--buffer-name))
+ (factor-messages-mode)
+ (current-buffer))))
+
+(defun fuel-log--msg (type &rest args)
+ (unless fuel-log--inhibit-p
+ (with-current-buffer (fuel-log--buffer)
+ (let ((inhibit-read-only t))
+ (insert
+ (fuel--shorten-str (format "\n%s: %s\n" type (apply 'format args))
+ fuel-log--max-message-size))))))
+
+(defsubst fuel-log--warn (&rest args)
+ (apply 'fuel-log--msg 'WARNING args))
+
+(defsubst fuel-log--error (&rest args)
+ (apply 'fuel-log--msg 'ERROR args))
+
+(defsubst fuel-log--info (&rest args)
+ (when fuel-log--verbose-p
+ (apply 'fuel-log--msg 'INFO args) ""))
+
+\f
+(provide 'fuel-log)
+;;; fuel-log.el ends here
(require 'fuel-debug)
(require 'fuel-help)
(require 'fuel-eval)
+(require 'fuel-completion)
(require 'fuel-listener)
\f
(when buffer
(with-current-buffer buffer
(message "Compiling %s ..." file)
- (fuel-eval--send (fuel-eval--cmd/string (format "%S fuel-run-file" file))
+ (fuel-eval--send `(:fuel (,file fuel-run-file))
`(lambda (r) (fuel--run-file-cont r ,file)))))))
(defun fuel--run-file-cont (ret file)
Unless called with a prefix, switchs to the compilation results
buffer in case of errors."
(interactive "r\nP")
- (fuel-debug--display-retort
- (fuel-eval--send/wait (fuel-eval--cmd/region begin end) 10000)
- (format "%s%s"
- (if fuel-syntax--current-vocab
- (format "IN: %s " fuel-syntax--current-vocab)
- "")
- (fuel--shorten-region begin end 70))
- arg
- (buffer-file-name)))
+ (let* ((lines (split-string (buffer-substring-no-properties begin end)
+ "[\f\n\r\v]+" t))
+ (cmd `(:fuel (,(mapcar (lambda (l) `(:factor ,l)) lines))))
+ (cv (fuel-syntax--current-vocab)))
+ (fuel-debug--display-retort
+ (fuel-eval--send/wait cmd 10000)
+ (format "%s%s"
+ (if cv (format "IN: %s " cv) "")
+ (fuel--shorten-region begin end 70))
+ arg
+ (buffer-file-name))))
(defun fuel-eval-extended-region (begin end &optional arg)
"Sends region extended outwards to nearest definitions,
(unless (< begin end) (error "No evaluable definition around point"))
(fuel-eval-region begin end arg))))
+(defun fuel--try-edit (ret)
+ (let* ((err (fuel-eval--retort-error ret))
+ (loc (fuel-eval--retort-result ret)))
+ (when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
+ (error "Couldn't find edit location for '%s'" word))
+ (unless (file-readable-p (car loc))
+ (error "Couldn't open '%s' for read" (car loc)))
+ (find-file-other-window (car loc))
+ (goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
+
(defun fuel-edit-word-at-point (&optional arg)
"Opens a new window visiting the definition of the word at point.
With prefix, asks for the word to edit."
(interactive "P")
- (let* ((word (fuel-syntax-symbol-at-point))
- (ask (or arg (not word)))
- (word (if ask
- (read-string nil
- (format "Edit word%s: "
- (if word (format " (%s)" word) ""))
- word)
- word)))
- (let* ((str (fuel-eval--cmd/string
- (format "\\ %s fuel-get-edit-location" word)))
- (ret (fuel-eval--send/wait str))
- (err (fuel-eval--retort-error ret))
- (loc (fuel-eval--retort-result ret)))
- (when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
- (error "Couldn't find edit location for '%s'" word))
- (unless (file-readable-p (car loc))
- (error "Couldn't open '%s' for read" (car loc)))
- (find-file-other-window (car loc))
- (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))))
+ (let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
+ (fuel-completion--read-word "Edit word: ")))
+ (cmd `(:fuel ((:quote ,word) fuel-get-edit-location))))
+ (condition-case nil
+ (fuel--try-edit (fuel-eval--send/wait cmd))
+ (error (fuel-edit-vocabulary nil word)))))
+
+(defvar fuel-mode--word-history nil)
+
+(defun fuel-edit-word (&optional arg)
+ "Asks for a word to edit, with completion.
+With prefix, only words visible in the current vocabulary are
+offered."
+ (interactive "P")
+ (let* ((word (fuel-completion--read-word "Edit word: "
+ nil
+ fuel-mode--word-history
+ arg))
+ (cmd `(:fuel ((:quote ,word) fuel-get-edit-location))))
+ (fuel--try-edit (fuel-eval--send/wait cmd))))
+
+(defvar fuel--vocabs-prompt-history nil)
+
+(defun fuel--read-vocabulary-name (refresh)
+ (let* ((vocabs (fuel-completion--vocabs refresh))
+ (prompt "Vocabulary name: "))
+ (if vocabs
+ (completing-read prompt vocabs nil t nil fuel--vocabs-prompt-history)
+ (read-string prompt nil fuel--vocabs-prompt-history))))
+
+(defun fuel-edit-vocabulary (&optional refresh vocab)
+ "Visits vocabulary file in Emacs.
+When called interactively, asks for vocabulary with completion.
+With prefix argument, refreshes cached vocabulary list."
+ (interactive "P")
+ (let* ((vocab (or vocab (fuel--read-vocabulary-name refresh)))
+ (cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t)))
+ (fuel--try-edit (fuel-eval--send/wait cmd))))
\f
;;; Minor mode definition:
(define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c))
(fuel-mode--key-1 ?z 'run-factor)
-
(fuel-mode--key-1 ?k 'fuel-run-file)
-(fuel-mode--key ?e ?k 'fuel-run-file)
-
-(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
-(fuel-mode--key ?e ?x 'fuel-eval-definition)
-
(fuel-mode--key-1 ?r 'fuel-eval-region)
-(fuel-mode--key ?e ?r 'fuel-eval-region)
+(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
-(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
-
(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
+(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol)
+
+(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
+(fuel-mode--key ?e ?r 'fuel-eval-region)
+(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
+(fuel-mode--key ?e ?w 'fuel-edit-word)
+(fuel-mode--key ?e ?x 'fuel-eval-definition)
(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
(fuel-mode--key ?d ?d 'fuel-help)
(while (eq (char-before) ?:) (backward-char))
(skip-syntax-backward "w_"))
+(defsubst fuel-syntax--symbol-start ()
+ (save-excursion (fuel-syntax--beginning-of-symbol) (point)))
+
(defun fuel-syntax--end-of-symbol ()
"Move point to the end of the current symbol."
(skip-syntax-forward "w_")
(while (looking-at ":") (forward-char)))
+(defsubst fuel-syntax--symbol-end ()
+ (save-excursion (fuel-syntax--end-of-symbol) (point)))
+
(put 'factor-symbol 'end-op 'fuel-syntax--end-of-symbol)
(put 'factor-symbol 'beginning-op 'fuel-syntax--beginning-of-symbol)
(let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
(and (> (length s) 0) s)))
+
\f
;;; Regexps galore:
"DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
"GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
"IN:" "INSTANCE:" "INTERSECTION:"
- "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
+ "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "METHOD:" "MIXIN:"
"OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
"TUPLE:" "T{" "t\\??" "TYPEDEF:"
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
(defconst fuel-syntax--definition-starters-regex
- (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" "")))
+ (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "METHOD" ":" "")))
(defconst fuel-syntax--definition-start-regex
(format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
fuel-syntax--declaration-words-regex))
(defconst fuel-syntax--single-liner-regex
- (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
+ (format "^%s" (regexp-opt '("C:" "DEFER:" "GENERIC:" "IN:"
"PRIVATE>" "<PRIVATE"
"SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
;;; USING/IN:
(make-variable-buffer-local
- (defvar fuel-syntax--current-vocab nil))
-
-(make-variable-buffer-local
- (defvar fuel-syntax--usings nil))
-
-(defun fuel-syntax--current-vocab ()
- (let ((ip
- (save-excursion
- (when (re-search-backward fuel-syntax--current-vocab-regex nil t)
- (setq fuel-syntax--current-vocab (match-string-no-properties 1))
- (point)))))
+ (defvar fuel-syntax--current-vocab-function 'fuel-syntax--find-in))
+
+(defsubst fuel-syntax--current-vocab ()
+ (funcall fuel-syntax--current-vocab-function))
+
+(defun fuel-syntax--find-in ()
+ (let* ((vocab)
+ (ip
+ (save-excursion
+ (when (re-search-backward fuel-syntax--current-vocab-regex nil t)
+ (setq vocab (match-string-no-properties 1))
+ (point)))))
(when ip
(let ((pp (save-excursion
(when (re-search-backward fuel-syntax--sub-vocab-regex ip t)
(when (and pp (> pp ip))
(let ((sub (match-string-no-properties 1)))
(unless (save-excursion (search-backward (format "%s>" sub) pp t))
- (setq fuel-syntax--current-vocab
- (format "%s.%s" fuel-syntax--current-vocab (downcase sub)))))))))
- fuel-syntax--current-vocab)
+ (setq vocab (format "%s.%s" vocab (downcase sub))))))))
+ vocab))
-(defun fuel-syntax--usings-update ()
- (save-excursion
- (setq fuel-syntax--usings (list (fuel-syntax--current-vocab)))
- (while (re-search-backward fuel-syntax--using-lines-regex nil t)
- (dolist (u (split-string (match-string-no-properties 1) nil t))
- (push u fuel-syntax--usings)))
- fuel-syntax--usings))
-
-(defsubst fuel-syntax--usings-update-hook ()
- (fuel-syntax--usings-update)
- nil)
-
-(defun fuel-syntax--enable-usings ()
- (add-hook 'before-save-hook 'fuel-syntax--usings-update-hook nil t)
- (fuel-syntax--usings-update))
+(make-variable-buffer-local
+ (defvar fuel-syntax--usings-function 'fuel-syntax--find-usings))
(defsubst fuel-syntax--usings ()
- (or fuel-syntax--usings (fuel-syntax--usings-update)))
+ (funcall fuel-syntax--usings-function))
+
+(defun fuel-syntax--find-usings ()
+ (save-excursion
+ (let ((usings)
+ (in (fuel-syntax--current-vocab)))
+ (when in (setq usings (list in)))
+ (goto-char (point-max))
+ (while (re-search-backward fuel-syntax--using-lines-regex nil t)
+ (dolist (u (split-string (match-string-no-properties 1) nil t))
+ (push u usings)))
+ usings)))
\f
(provide 'fuel-syntax)
: HOLDBIT 4 ; inline
: S_RUN 0 ; inline
-: S_RUNPKT { PKTBIT } flags ; inline
-: S_WAIT { WAITBIT } flags ; inline
-: S_WAITPKT { WAITBIT PKTBIT } flags ; inline
-: S_HOLD { HOLDBIT } flags ; inline
-: S_HOLDPKT { HOLDBIT PKTBIT } flags ; inline
-: S_HOLDWAIT { HOLDBIT WAITBIT } flags ; inline
-: S_HOLDWAITPKT { HOLDBIT WAITBIT PKTBIT } flags ; inline
+: S_RUNPKT ( -- n ) { PKTBIT } flags ; inline
+: S_WAIT ( -- n ) { WAITBIT } flags ; inline
+: S_WAITPKT ( -- n ) { WAITBIT PKTBIT } flags ; inline
+: S_HOLD ( -- n ) { HOLDBIT } flags ; inline
+: S_HOLDPKT ( -- n ) { HOLDBIT PKTBIT } flags ; inline
+: S_HOLDWAIT ( -- n ) { HOLDBIT WAITBIT } flags ; inline
+: S_HOLDWAITPKT ( -- n ) { HOLDBIT WAITBIT PKTBIT } flags ; inline
: task-tab-size 10 ; inline
#define DS_REG r29
DEF(void,primitive_fixnum_add,(void)):
- lwz r3,0(DS_REG)
- lwz r4,-4(DS_REG)
- subi DS_REG,DS_REG,4
- li r0,0
- mtxer r0
- addo. r5,r3,r4
- bso add_overflow
- stw r5,0(DS_REG)
- blr
+ lwz r3,0(DS_REG)
+ lwz r4,-4(DS_REG)
+ subi DS_REG,DS_REG,4
+ li r0,0
+ mtxer r0
+ addo. r5,r3,r4
+ bso add_overflow
+ stw r5,0(DS_REG)
+ blr
add_overflow:
b MANGLE(overflow_fixnum_add)
DEF(void,primitive_fixnum_subtract,(void)):
- lwz r3,-4(DS_REG)
- lwz r4,0(DS_REG)
- subi DS_REG,DS_REG,4
- li r0,0
- mtxer r0
- subfo. r5,r4,r3
+ lwz r3,-4(DS_REG)
+ lwz r4,0(DS_REG)
+ subi DS_REG,DS_REG,4
+ li r0,0
+ mtxer r0
+ subfo. r5,r4,r3
bso sub_overflow
- stw r5,0(DS_REG)
- blr
+ stw r5,0(DS_REG)
+ blr
sub_overflow:
- b MANGLE(overflow_fixnum_subtract)
+ b MANGLE(overflow_fixnum_subtract)
DEF(void,primitive_fixnum_multiply,(void)):
- lwz r3,0(DS_REG)
- lwz r4,-4(DS_REG)
- subi DS_REG,DS_REG,4
- srawi r3,r3,3
- mullwo. r5,r3,r4
- bso multiply_overflow
- stw r5,0(DS_REG)
- blr
+ lwz r3,0(DS_REG)
+ lwz r4,-4(DS_REG)
+ subi DS_REG,DS_REG,4
+ srawi r3,r3,3
+ mullwo. r5,r3,r4
+ bso multiply_overflow
+ stw r5,0(DS_REG)
+ blr
multiply_overflow:
- srawi r4,r4,3
- b MANGLE(overflow_fixnum_multiply)
-
+ srawi r4,r4,3
+ b MANGLE(overflow_fixnum_multiply)
+
/* Note that the XT is passed to the quotation in r11 */
#define CALL_OR_JUMP_QUOT \
lwz r11,9(r3) /* load quotation-xt slot */ XX \
SAVE_INT(r26,13)
SAVE_INT(r27,14)
SAVE_INT(r28,15)
+ SAVE_INT(r31,16)
- SAVE_FP(f14,20) /* save FPRs */
+ SAVE_FP(f14,20) /* save FPRs */
SAVE_FP(f15,22)
SAVE_FP(f16,24)
SAVE_FP(f17,26)
mr r3,r1 /* pass call stack pointer as an argument */
bl MANGLE(save_callstack_bottom)
- RESTORE_INT(r3,19) /* restore quotation */
+ RESTORE_INT(r3,19) /* restore quotation */
CALL_QUOT
RESTORE_FP(f31,54)
RESTORE_FP(f17,26)
RESTORE_FP(f16,24)
RESTORE_FP(f15,22)
- RESTORE_FP(f14,20) /* save FPRs */
+ RESTORE_FP(f14,20) /* save FPRs */
- RESTORE_INT(r28,15) /* restore GPRs */
+ RESTORE_INT(r31,16) /* restore GPRs */
+ RESTORE_INT(r28,15)
RESTORE_INT(r27,14)
RESTORE_INT(r26,13)
RESTORE_INT(r25,12)
return g_pagesize;
}
-void sleep_micros(DWORD usec)
+void sleep_micros(u64 usec)
{
- Sleep(usec);
+ Sleep((DWORD)(usec / 1000));
}
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
-#define FIXNUM_FORMAT "%Id"
-#define CELL_FORMAT "%lu"
-#define CELL_HEX_FORMAT "%Ix"
#ifdef WIN64
+ #define CELL_FORMAT "%Iu"
+ #define CELL_HEX_FORMAT "%Ix"
#define CELL_HEX_PAD_FORMAT "%016Ix"
+ #define FIXNUM_FORMAT "%Id"
#else
+ #define CELL_FORMAT "%lu"
+ #define CELL_HEX_FORMAT "%lx"
#define CELL_HEX_PAD_FORMAT "%08lx"
+ #define FIXNUM_FORMAT "%ld"
#endif
-#define FIXNUM_FORMAT "%Id"
#define OPEN_READ(path) _wfopen(path,L"rb")
#define OPEN_WRITE(path) _wfopen(path,L"wb")
void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
void ffi_dlclose(F_DLL *dll);
-void sleep_micros(DWORD msec);
+void sleep_micros(u64 msec);
INLINE void init_signals(void) {}
INLINE void early_init(void) {}
projects / factor.git / commitdiff
