{ $values { "timestamp" timestamp } { "duration" duration } }
{ $description "Calculates a " { $snippet "duration" } " that represents the elapsed time since midnight of the input " { $snippet "timestamp" } "." } ;
+HELP: since-1970
+{ $values
+ { "duration" duration }
+ { "timestamp" timestamp } }
+{ $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ;
+
ARTICLE: "calendar" "Calendar"
"The two data types used throughout the calendar library:"
{ $subsection timestamp }
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary structs
-combinators.short-circuit ;
+locals classes.tuple math.order summary combinators.short-circuit ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
: time-since-midnight ( timestamp -- duration )
dup midnight time- ;
-: timeval>unix-time ( timeval -- timestamp )
- [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
- time+ unix-1970 time+ >local-time ;
+: since-1970 ( duration -- timestamp )
+ unix-1970 time+ >local-time ;
M: timestamp sleep-until timestamp>millis sleep-until ;
-USING: alien alien.c-types arrays calendar kernel structs
-math unix.time namespaces system ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax arrays calendar
+kernel math unix unix.time namespaces system ;
IN: calendar.unix
+: timeval>seconds ( timeval -- seconds )
+ [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
+ time+ ;
+
+: timeval>unix-time ( timeval -- timestamp )
+ timeval>seconds since-1970 ;
+
+: timespec>seconds ( timespec -- seconds )
+ [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
+ time+ ;
+
+: timespec>unix-time ( timespec -- timestamp )
+ timespec>seconds since-1970 ;
+
: get-time ( -- alien )
f time <uint> localtime ;
USING: accessors alien alien.c-types alien.strings arrays assocs
combinators compiler kernel math namespaces make parser
prettyprint prettyprint.sections quotations sequences strings
-words cocoa.runtime io macros memoize debugger
-io.encodings.ascii effects compiler.generator libc libc.private
-parser lexer init core-foundation ;
+words cocoa.runtime io macros memoize debugger fry
+io.encodings.ascii effects compiler.generator libc libc.private ;
IN: cocoa.messages
: make-sender ( method function -- quot )
{ "c" "char" }
{ "i" "int" }
{ "s" "short" }
- { "l" "long" }
- { "q" "longlong" }
{ "C" "uchar" }
{ "I" "uint" }
{ "S" "ushort" }
- { "L" "ulong" }
- { "Q" "ulonglong" }
{ "f" "float" }
{ "d" "double" }
{ "B" "bool" }
{ "v" "void" }
{ "*" "char*" }
+ { "?" "unknown_type" }
{ "@" "id" }
- { "#" "id" }
+ { "#" "Class" }
{ ":" "SEL" }
-} objc>alien-types set-global
+}
+"ptrdiff_t" heap-size {
+ { 4 [ H{
+ { "l" "long" }
+ { "q" "longlong" }
+ { "L" "ulong" }
+ { "Q" "ulonglong" }
+ } ] }
+ { 8 [ H{
+ { "l" "long32" }
+ { "q" "long" }
+ { "L" "ulong32" }
+ { "Q" "ulong" }
+ } ] }
+} case
+assoc-union objc>alien-types set-global
! The transpose of the above map
SYMBOL: alien>objc-types
! A hack...
"ptrdiff_t" heap-size {
{ 4 [ H{
- { "NSPoint" "{_NSPoint=ff}" }
- { "NSRect" "{_NSRect=ffff}" }
- { "NSSize" "{_NSSize=ff}" }
- { "NSRange" "{_NSRange=II}" }
+ { "NSPoint" "{_NSPoint=ff}" }
+ { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
+ { "NSSize" "{_NSSize=ff}" }
+ { "NSRange" "{_NSRange=II}" }
+ { "NSInteger" "i" }
+ { "NSUInteger" "I" }
+ { "CGFloat" "f" }
} ] }
{ 8 [ H{
- { "NSPoint" "{_NSPoint=dd}" }
- { "NSRect" "{_NSRect=dddd}" }
- { "NSSize" "{_NSSize=dd}" }
- { "NSRange" "{_NSRange=QQ}" }
+ { "NSPoint" "{CGPoint=dd}" }
+ { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
+ { "NSSize" "{CGSize=dd}" }
+ { "NSRange" "{_NSRange=QQ}" }
+ { "NSInteger" "q" }
+ { "NSUInteger" "Q" }
+ { "CGFloat" "d" }
} ] }
} case
assoc-union alien>objc-types set-global
swap method_getName sel_getName
objc-methods get set-at ;
-: (register-objc-methods) ( methods count -- methods )
- over [ void*-nth register-objc-method ] curry each ;
+: each-method-in-class ( class quot -- )
+ [ 0 <uint> [ class_copyMethodList ] keep *uint over ] dip
+ '[ _ void*-nth @ ] each (free) ; inline
: register-objc-methods ( class -- )
- 0 <uint> [ class_copyMethodList ] keep *uint
- (register-objc-methods) (free) ;
+ [ register-objc-method ] each-method-in-class ;
+
+: method. ( method -- )
+ {
+ [ method_getName sel_getName ]
+ [ method-return-type ]
+ [ method-arg-types ]
+ [ method_getImplementation ]
+ } cleave 4array . ;
+
+: methods. ( class -- )
+ [ method. ] each-method-in-class ;
: class-exists? ( string -- class ) objc_getClass >boolean ;
FUNCTION: char* sel_getName ( SEL aSelector ) ;
-FUNCTION: bool sel_isMapped ( SEL aSelector ) ;
+FUNCTION: char sel_isMapped ( SEL aSelector ) ;
FUNCTION: SEL sel_registerName ( char* str ) ;
FUNCTION: Class class_getSuperclass ( Class cls ) ;
+FUNCTION: char* class_getName ( Class cls ) ;
+
FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ;
FUNCTION: SEL method_getName ( Method method ) ;
FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
+FUNCTION: void* method_getImplementation ( Method method ) ;
FUNCTION: Class object_getClass ( id object ) ;
[ sel_registerName ] [ execute ] [ ascii string>alien ]
tri* ;
+: throw-if-false ( YES/NO -- )
+ zero? [ "Failed to add method or protocol to class" throw ]
+ when ;
+
: add-methods ( methods class -- )
swap
- [ init-method class_addMethod drop ] with each ;
+ [ init-method class_addMethod throw-if-false ] with each ;
: add-protocols ( protocols class -- )
- swap [ objc-protocol class_addProtocol drop ] with each ;
+ swap [ objc-protocol class_addProtocol throw-if-false ]
+ with each ;
: (define-objc-class) ( protocols superclass name imeth -- )
-rot
{ 8 [ "double" ] }
} case "CGFloat" typedef >>
-C-STRUCT: NSRect
- { "CGFloat" "x" }
- { "CGFloat" "y" }
- { "CGFloat" "w" }
- { "CGFloat" "h" } ;
-
-TYPEDEF: NSRect _NSRect
-TYPEDEF: NSRect CGRect
-
-: <NSRect> ( x y w h -- rect )
- "NSRect" <c-object>
- [ set-NSRect-h ] keep
- [ set-NSRect-w ] keep
- [ set-NSRect-y ] keep
- [ set-NSRect-x ] keep ;
-
-: NSRect-x-y ( alien -- origin-x origin-y )
- [ NSRect-x ] keep NSRect-y ;
-
C-STRUCT: NSPoint
{ "CGFloat" "x" }
{ "CGFloat" "y" } ;
TYPEDEF: NSSize _NSSize
TYPEDEF: NSSize CGSize
-TYPEDEF: NSPoint CGPoint
: <NSSize> ( w h -- size )
"NSSize" <c-object>
[ set-NSSize-h ] keep
[ set-NSSize-w ] keep ;
+C-STRUCT: NSRect
+ { "NSPoint" "origin" }
+ { "NSSize" "size" } ;
+
+TYPEDEF: NSRect _NSRect
+TYPEDEF: NSRect CGRect
+
+: NSRect-x ( NSRect -- x )
+ NSRect-origin NSPoint-x ; inline
+: NSRect-y ( NSRect -- y )
+ NSRect-origin NSPoint-y ; inline
+: NSRect-w ( NSRect -- w )
+ NSRect-size NSSize-w ; inline
+: NSRect-h ( NSRect -- h )
+ NSRect-size NSSize-h ; inline
+
+: set-NSRect-x ( x NSRect -- )
+ NSRect-origin set-NSPoint-x ; inline
+: set-NSRect-y ( y NSRect -- )
+ NSRect-origin set-NSPoint-y ; inline
+: set-NSRect-w ( w NSRect -- )
+ NSRect-size set-NSSize-w ; inline
+: set-NSRect-h ( h NSRect -- )
+ NSRect-size set-NSSize-h ; inline
+
+: <NSRect> ( x y w h -- rect )
+ "NSRect" <c-object>
+ [ set-NSRect-h ] keep
+ [ set-NSRect-w ] keep
+ [ set-NSRect-y ] keep
+ [ set-NSRect-x ] keep ;
+
+: NSRect-x-y ( alien -- origin-x origin-y )
+ [ NSRect-x ] keep NSRect-y ;
+
C-STRUCT: NSRange
{ "NSUInteger" "location" }
{ "NSUInteger" "length" } ;
TYPEDEF: NSRange _NSRange
+! The "lL" type encodings refer to 32-bit values even in 64-bit mode
+TYPEDEF: int long32
+TYPEDEF: uint ulong32
+TYPEDEF: void* unknown_type
+
: <NSRange> ( length location -- size )
"NSRange" <c-object>
[ set-NSRange-length ] keep
: frame-required ( n -- ) \ frame-required boa , ;
-: stack-frame-size ( code -- n )
+: compute-stack-frame-size ( code -- n )
no-stack-frame [
dup frame-required? [ n>> max ] [ drop ] if
] reduce ;
: if-stack-frame ( frame-size quot -- )
swap dup no-stack-frame =
- [ 2drop ] [ stack-frame swap call ] if ; inline
+ [ 2drop ] [ stack-frame-size swap call ] if ; inline
M: word fixup*
{
: fixup ( code -- literals relocation labels code )
[
init-fixup
- dup stack-frame-size swap [ fixup* ] each drop
+ dup compute-stack-frame-size swap [ fixup* ] each drop
literal-table get >array
relocation-table get >byte-array
: return-size ( ctype -- n )
#! Amount of space we reserve for a return value.
- dup large-struct? [ heap-size ] [ drop 0 ] if ;
+ dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
: alien-stack-frame ( params -- n )
- alien-parameters parameter-sizes drop ;
-
-: alien-invoke-frame ( params -- n )
- #! Two cells for temporary storage, temp@ and on x86.64,
- #! small struct return value unpacking
- [ return>> return-size ] [ alien-stack-frame ] bi
- + 2 cells + ;
-
-: set-stack-frame ( n -- )
- dup [ frame-required ] when* \ stack-frame set ;
-
-: with-stack-frame ( n quot -- )
- swap set-stack-frame
+ stack-frame new
+ swap
+ [ return>> return-size >>return ]
+ [ alien-parameters parameter-sizes drop >>params ] bi
+ dup [ params>> ] [ return>> ] bi + >>size
+ dup size>> stack-frame-size >>total-size ;
+
+: with-stack-frame ( params quot -- )
+ swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
call
- f set-stack-frame ; inline
+ stack-frame off ; inline
GENERIC: reg-size ( register-class -- n )
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
- return>> dup large-struct?
- [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+ return>> large-struct?
+ [ %prepare-box-struct cell ] [ 0 ] if ;
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
M: #alien-invoke generate-node
params>>
- dup alien-invoke-frame [
+ dup [
end-basic-block
%prepare-alien-invoke
dup objects>registers
! #alien-indirect
M: #alien-indirect generate-node
params>>
- dup alien-invoke-frame [
+ dup [
! Flush registers
end-basic-block
! Save registers for GC
: callback-unwind ( params -- n )
{
- { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
dup xt>> dup [
init-templates
%prologue-later
- dup alien-stack-frame [
+ dup [
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
--- /dev/null
+Slava Pestov
--- /dev/null
+CoreFoundation run loop integration
--- /dev/null
+Slava Pestov
--- /dev/null
+Vocabulary with init hook for running CoreFoundation event loop
--- /dev/null
+unportable
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic kernel kernel.private math memory
-namespaces make sequences layouts system hashtables classes
-alien byte-arrays combinators words sets ;
+USING: accessors arrays generic kernel kernel.private math
+memory namespaces make sequences layouts system hashtables
+classes alien byte-arrays combinators words sets ;
IN: cpu.architecture
! Register classes
HOOK: load-indirect cpu ( obj reg -- )
-HOOK: stack-frame cpu ( frame-size -- n )
+HOOK: stack-frame-size cpu ( frame-size -- n )
-: stack-frame* ( -- n )
- \ stack-frame get stack-frame ;
+TUPLE: stack-frame total-size size params return ;
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
HOOK: %box-long-long cpu ( n func -- )
-HOOK: %prepare-box-struct cpu ( size -- )
+HOOK: %prepare-box-struct cpu ( -- )
HOOK: %box-small-struct cpu ( c-type -- )
: xt-save ( n -- i ) 2 cells - ;
-M: ppc stack-frame ( n -- i )
+M: ppc stack-frame-size ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
1 1 rot ADDI
0 MTLR ;
-: (%call) ( -- ) 11 MTLR BLRL ;
+: (%call) ( reg -- ) MTLR BLRL ;
-: (%jump) ( -- ) 11 MTCTR BCTR ;
+: (%jump) ( reg -- ) MTCTR BCTR ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup 6 cells LWZ
- (%jump)
+ 11 (%jump)
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
M: stack-params %load-param-reg ( stack reg reg-class -- )
drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
+: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
+
M: stack-params %save-param-reg ( stack reg reg-class -- )
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
- 0 1 rot param@ stack-frame* + LWZ
+ 0 1 rot next-param@ LWZ
0 1 rot local@ STW ;
M: ppc %prepare-unbox ( -- )
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
- ! Compute destination address
- 4 1 roll local@ ADDI
- ! Load struct size
- heap-size 5 LI
+ ! Compute destination address and load struct size
+ [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
! Call the function
"to_value_struct" f %alien-invoke ;
4 1 rot cell + local@ LWZ
] when* r> f %alien-invoke ;
-: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ;
-
-: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
+: struct-return@ ( n -- n )
+ [ stack-frame get params>> ] unless* local@ ;
-M: ppc %prepare-box-struct ( size -- )
+M: ppc %prepare-box-struct ( -- )
#! Compute target address for value struct return
- 3 1 rot f struct-return@ ADDI
+ 3 1 f struct-return@ ADDI
3 1 0 local@ STW ;
M: ppc %box-large-struct ( n c-type -- )
- #! If n = f, then we're boxing a returned struct
- heap-size
- [ swap struct-return@ ] keep
- ! Compute destination address
- 3 1 roll ADDI
- ! Load struct size
- 4 LI
+ ! 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*
! Call the function
"box_value_struct" f %alien-invoke ;
rs-reg 11 12 STW ;
M: ppc %alien-invoke ( symbol dll -- )
- 11 %load-dlsym (%call) ;
+ 11 %load-dlsym 11 (%call) ;
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- 3 1 cell temp@ STW ;
+ 13 3 MR ;
M: ppc %alien-indirect ( -- )
- 11 1 cell temp@ LWZ (%call) ;
+ 13 (%call) ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays cpu.x86.assembler
+USING: locals alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
-stack-checker.known-words
-compiler.generator.registers compiler.generator.fixup
-compiler.generator system layouts combinators
-command-line compiler compiler.units io vocabs.loader accessors
-init ;
+stack-checker.known-words compiler.generator.registers
+compiler.generator.fixup compiler.generator system layouts
+combinators command-line compiler compiler.units io
+vocabs.loader accessors init ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
-M: x86.32 stack-save-reg EDX ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
heap-size { 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
+: struct-return@ ( n -- operand )
+ [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
+
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
M: int-regs vregs drop { EAX ECX EDX EBP } ;
M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return ( n reg-class -- src dst )
- return-reg stack-reg rot [+] ;
-M: int-regs load-return-reg load/store-int-return MOV ;
-M: int-regs store-return-reg load/store-int-return swap MOV ;
+
+M: int-regs load-return-reg
+ return-reg swap next-stack@ MOV ;
+
+M: int-regs store-return-reg
+ [ stack@ ] [ return-reg ] bi* MOV ;
M: float-regs param-regs drop { } ;
M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
M: float-regs push-return-reg
- stack-reg swap reg-size [ SUB stack-reg [] ] keep FSTP ;
+ stack-reg swap reg-size
+ [ SUB ] [ [ [] ] dip FSTP ] 2bi ;
: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
-: load/store-float-return ( n reg-class -- op size )
- [ stack@ ] [ reg-size ] bi* ;
-M: float-regs load-return-reg load/store-float-return FLD ;
-M: float-regs store-return-reg load/store-float-return FSTP ;
+M: float-regs load-return-reg
+ [ next-stack@ ] [ reg-size ] bi* FLD ;
+
+M: float-regs store-return-reg
+ [ stack@ ] [ reg-size ] bi* FSTP ;
: align-sub ( n -- )
- dup 16 align swap - ESP swap SUB ;
+ [ align-stack ] keep - decr-stack-reg ;
: align-add ( n -- )
- 16 align ESP swap ADD ;
+ align-stack incr-stack-reg ;
: with-aligned-stack ( n quot -- )
- swap dup align-sub slip align-add ; inline
+ [ [ align-sub ] [ call ] bi* ]
+ [ [ align-add ] [ drop ] bi* ] 2bi ; inline
M: x86.32 fixnum>slot@ 1 SHR ;
M: object %save-param-reg 3drop ;
-: box@ ( n reg-class -- stack@ )
- #! Used for callbacks; we want to box the values given to
- #! us by the C function caller. Computes stack location of
- #! nth parameter; note that we must go back one more stack
- #! frame, since %box sets one up to call the one-arg boxer
- #! function. The size of this stack frame so far depends on
- #! the reg-class of the boxer's arg.
- reg-size neg + stack-frame* + 20 + ;
-
: (%box) ( n reg-class -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
- over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
- push-return-reg ;
+ over [ load-return-reg ] [ 2drop ] if ;
-M: x86.32 %box ( n reg-class func -- )
- over reg-size [
- >r (%box) r> f %alien-invoke
+M:: x86.32 %box ( n reg-class func -- )
+ n reg-class (%box)
+ reg-class reg-size [
+ reg-class push-return-reg
+ func f %alien-invoke
] with-aligned-stack ;
: (%box-long-long) ( n -- )
- #! If n is f, push the return registers onto the stack; we
- #! are boxing a return value of a C function. If n is an
- #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
- #! boxing a parameter being passed to a callback from C.
[
- int-regs box@
- EDX over stack@ MOV
- EAX swap cell - stack@ MOV
- ] when*
- EDX PUSH
- EAX PUSH ;
+ EDX over next-stack@ MOV
+ EAX swap cell - next-stack@ MOV
+ ] when* ;
M: x86.32 %box-long-long ( n func -- )
+ [ (%box-long-long) ] dip
8 [
- [ (%box-long-long) ] [ f %alien-invoke ] bi*
+ EDX PUSH
+ EAX PUSH
+ f %alien-invoke
] with-aligned-stack ;
-: struct-return@ ( size n -- n )
- [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.32 %box-large-struct ( n c-type -- )
+M:: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
- heap-size
- [ swap struct-return@ ] keep
- ECX ESP roll [+] LEA
+ ECX n struct-return@ LEA
8 [
! Push struct size
- PUSH
+ c-type heap-size PUSH
! Push destination address
ECX PUSH
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
-M: x86.32 %prepare-box-struct ( size -- )
+M: x86.32 %prepare-box-struct ( -- )
! Compute target address for value struct return
- EAX ESP rot f struct-return@ [+] LEA
+ EAX f struct-return@ LEA
! Store it as the first parameter
- ESP [] EAX MOV ;
+ 0 stack@ EAX MOV ;
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
} case ;
M: x86.32 %unbox-large-struct ( n c-type -- )
- #! Alien must be in EAX.
- heap-size
+ ! Alien must be in EAX.
! Compute destination address
- ECX ESP roll [+] LEA
+ ECX rot stack@ LEA
12 [
! Push struct size
- PUSH
+ heap-size PUSH
! Push destination address
ECX PUSH
! Push source address
M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- cell temp@ EAX MOV ;
+ EBP EAX MOV ;
M: x86.32 %alien-indirect ( -- )
- cell temp@ CALL ;
+ EBP CALL ;
M: x86.32 %alien-callback ( quot -- )
4 [
M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
- ! Save top of data stack
+ ! Save top of data stack in non-volatile register
%prepare-unbox
EAX PUSH
! Restore data/call/retain stacks
{
{
[ dup abi>> "stdcall" = ]
- [ alien-stack-frame ESP swap SUB ]
+ [ drop ESP stack-frame get params>> SUB ]
} {
[ dup return>> large-struct? ]
[ drop EAX PUSH ]
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
-M: x86.64 stack-save-reg RSI ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
r> stack@ R11 MOV ;
M: stack-params %save-param-reg
- >r stack-frame* + cell + swap r> %load-param-reg ;
+ drop
+ R11 swap next-stack@ MOV
+ stack@ R11 MOV ;
: with-return-regs ( quot -- )
[
! Source is in RDI
heap-size
! Load destination address
- RSI RSP roll [+] LEA
+ RSI rot stack@ LEA
! Load structure size
RDX swap MOV
! Copy the struct to the C stack
M: x86.64 struct-small-enough? ( size -- ? )
heap-size 2 cells <= ;
-: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
+: box-struct-field@ ( i -- operand ) 1+ cells stack@ ;
: %box-struct-field ( c-type i -- )
box-struct-field@ swap reg-class>> {
"box_small_struct" f %alien-invoke
] with-return-regs ;
-: struct-return@ ( size n -- n )
- [ ] [ \ stack-frame get swap - ] ?if ;
+: struct-return@ ( n -- operand )
+ [ stack-frame get params>> ] unless* stack@ ;
M: x86.64 %box-large-struct ( n c-type -- )
! Struct size is parameter 2
- heap-size
- RSI over MOV
+ RSI swap heap-size MOV
! Compute destination address
- swap struct-return@ RDI RSP rot [+] LEA
+ RDI swap struct-return@ LEA
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
-M: x86.64 %prepare-box-struct ( size -- )
+M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
- RAX RSP rot f struct-return@ [+] LEA
- RSP 0 [+] RAX MOV ;
+ RAX f struct-return@ LEA
+ ! Store it as the first parameter
+ 0 stack@ RAX MOV ;
M: x86.64 %prepare-var-args RAX RAX XOR ;
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- cell temp@ RAX MOV ;
+ RBP RAX MOV ;
M: x86.64 %alien-indirect ( -- )
- cell temp@ CALL ;
+ RBP CALL ;
M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
- ! Put former top of data stack in RDI
- cell temp@ RDI MOV
+ ! Save top of data stack
+ RSP 8 SUB
+ RDI PUSH
! Restore data/call/retain stacks
"unnest_stacks" f %alien-invoke
! Put former top of data stack in RDI
- RDI cell temp@ MOV
+ RDI POP
+ RSP 8 ADD
! Unbox former top of data stack to return registers
unbox-return ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
HOOK: stack-reg cpu ( -- reg )
-HOOK: stack-save-reg cpu ( -- reg )
: stack@ ( n -- op ) stack-reg swap [+] ;
+: next-stack@ ( n -- operand )
+ #! nth parameter from the next stack frame. Used to box
+ #! input values to callbacks; the callback has its own
+ #! stack frame set up, and we want to read the frame
+ #! set up by the caller.
+ stack-frame get total-size>> + stack@ ;
+
: reg-stack ( n reg -- op ) swap cells neg [+] ;
M: ds-loc v>operand n>> ds-reg reg-stack ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( stack@ reg-class -- )
-GENERIC: store-return-reg ( stack@ reg-class -- )
+GENERIC: load-return-reg ( n reg-class -- )
+GENERIC: store-return-reg ( n reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu ( -- reg )
M: immediate load-literal v>operand swap v>operand MOV ;
-M: x86 stack-frame ( n -- i )
- 3 cells + 16 align cell - ;
+: align-stack ( n -- n' )
+ os macosx? cpu x86.64? or [ 16 align ] when ;
+
+M: x86 stack-frame-size ( n -- i )
+ 3 cells + align-stack ;
M: x86 %save-word-xt ( -- )
temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
-: factor-area-size ( -- n ) 4 cells ;
+: decr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
M: x86 %prologue ( n -- )
- dup cell + PUSH
+ dup PUSH
temp-reg v>operand PUSH
- stack-reg swap 2 cells - SUB ;
+ 3 cells - decr-stack-reg ;
-M: x86 %epilogue ( n -- )
- stack-reg swap ADD ;
+: incr-stack-reg ( n -- )
+ dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
HOOK: %alien-global cpu ( symbol dll register -- )
: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
-
M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test
-! [ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test
-! [ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
-! [ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test
+[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
+[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 2c HEX: c0 } ] [ [ EAX XMM0 CVTTSD2SI ] { } make ] unit-test
[ { HEX: f2 HEX: 48 HEX: 0f HEX: 2c HEX: c0 } ] [ [ RAX XMM0 CVTTSD2SI ] { } make ] unit-test
[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
+[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
- dup base>> { EBP RBP R13 } member? [
- dup displacement>> [ 0 >>displacement ] unless
- ] when ;
+ dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
+ [ 0 >>displacement ] when ;
-: canonicalize-ESP ( indirect -- indirect )
- #! { ESP } ==> { ESP ESP }
- dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
+ERROR: bad-index indirect ;
+
+: check-ESP ( indirect -- indirect )
+ dup index>> { ESP RSP } memq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
- canonicalize-EBP canonicalize-ESP ;
+ canonicalize-EBP check-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa canonicalize ;
GENERIC: sib-present? ( op -- ? )
M: indirect sib-present?
- [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
+ [ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ;
M: register sib-present? drop f ;
reg-code swap addressing ;
: direction-bit ( dst src op -- dst' src' op' )
- pick register? [ BIN: 10 opcode-or swapd ] when ;
+ pick register? pick register? not and
+ [ BIN: 10 opcode-or swapd ] when ;
: operand-size-bit ( dst src op -- dst' src' op' )
over register-8? [ BIN: 1 opcode-or ] unless ;
{ $values { "assoc" assoc } }
{ $description "Disposes an associative list of statements." } ;
-HELP: db-dispose
-{ $values { "db" db } }
-{ $description "Disposes of all the statements stored in the " { $link db } " object." } ;
-
HELP: statement
{ $description "A " { $snippet "statement" } " stores the information about a statemen, such as the SQL statement text, the in/out parameters, and type information." } ;
HELP: with-db
{ $values
{ "db" db } { "quot" quotation } }
-{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ;
+{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. See " { $link "db-custom-database-combinators" } " for help setting up database access." } ;
HELP: with-transaction
{ $values
{ $code <"
USING: db.sqlite db io.files ;
: with-sqlite-db ( quot -- )
- "my-database.db" temp-file <sqlite-db> swap with-db ;"> }
+ "my-database.db" temp-file <sqlite-db> swap with-db ; inline"> }
"PostgreSQL example combinator:"
{ $code <" USING: db.postgresql db ;
"erg" >>username
"secrets?" >>password
"factor-test" >>database
- swap with-db ;">
+ swap with-db ; inline">
} ;
ABOUT: "db"
: dispose-statements ( assoc -- ) values dispose-each ;
-: db-dispose ( db -- )
+M: db dispose ( db -- )
dup db [
- {
- [ insert-statements>> dispose-statements ]
- [ update-statements>> dispose-statements ]
- [ delete-statements>> dispose-statements ]
- [ handle>> db-close ]
- } cleave
+ [ dispose-statements H{ } clone ] change-insert-statements
+ [ dispose-statements H{ } clone ] change-update-statements
+ [ dispose-statements H{ } clone ] change-delete-statements
+ [ db-close f ] change-handle
+ drop
] with-variable ;
TUPLE: result-set sql in-params out-params handle n max ;
[ password>> ]
} cleave connect-postgres >>handle ;
-M: postgresql-db dispose ( db -- )
- handle>> PQfinish ;
+M: postgresql-db db-close ( handle -- )
+ PQfinish ;
M: postgresql-statement bind-statement* ( statement -- ) drop ;
{ +foreign-id+ { f f "references" } }
+ { +on-update+ { f f "on update" } }
{ +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } }
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
+M: NULL where ( spec obj -- )
+ drop column-name>> 0% " is NULL" 0% ;
+
: object-where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ;
swap 3append ;
: do-group ( tuple groups -- )
+ dup string? [ 1array ] when
[ ", " join " group by " splice ] curry change-sql drop ;
: do-order ( tuple order -- )
+ dup string? [ 1array ] when
[ ", " join " order by " splice ] curry change-sql drop ;
: do-offset ( tuple n -- )
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
io.backend db.errors present urls io.encodings.utf8
-io.encodings.string accessors ;
+io.encodings.string accessors shuffle ;
IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
: sqlite-bind-uint64-by-name ( handle name int64 -- )
parameter-index sqlite-bind-uint64 ;
+: sqlite-bind-boolean-by-name ( handle name obj -- )
+ >boolean 1 0 ? parameter-index sqlite-bind-int ;
+
: sqlite-bind-double-by-name ( handle name double -- )
parameter-index sqlite-bind-double ;
: sqlite-bind-null-by-name ( handle name obj -- )
parameter-index drop sqlite-bind-null ;
-: sqlite-bind-type ( handle key value type -- )
- over [ drop NULL ] unless
+: (sqlite-bind-type) ( handle key value type -- )
dup array? [ first ] when
{
{ INTEGER [ sqlite-bind-int-by-name ] }
{ BIG-INTEGER [ sqlite-bind-int64-by-name ] }
{ SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
{ UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
+ { BOOLEAN [ sqlite-bind-boolean-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
{ DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] }
{ TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] }
{ BLOB [ sqlite-bind-blob-by-name ] }
- { FACTOR-BLOB [
- object>bytes
- sqlite-bind-blob-by-name
- ] }
+ { FACTOR-BLOB [ object>bytes sqlite-bind-blob-by-name ] }
{ URL [ present sqlite-bind-text-by-name ] }
{ +db-assigned-id+ [ sqlite-bind-int-by-name ] }
{ +random-id+ [ sqlite-bind-int64-by-name ] }
[ no-sql-type ]
} case ;
+: sqlite-bind-type ( handle key value type -- )
+ #! null and empty values need to be set by sqlite-bind-null-by-name
+ over [
+ NULL = [ 2drop NULL NULL ] when
+ ] [
+ drop NULL
+ ] if* (sqlite-bind-type) ;
+
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
: sqlite-clear-bindings ( handle -- )
{ BIG-INTEGER [ sqlite3_column_int64 ] }
{ SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
{ UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
+ { BOOLEAN [ sqlite3_column_int 1 = ] }
{ DOUBLE [ sqlite3_column_double ] }
{ TEXT [ sqlite3_column_text ] }
{ VARCHAR [ sqlite3_column_text ] }
{ DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
{ BLOB [ sqlite-column-blob ] }
{ URL [ sqlite3_column_text dup [ >url ] when ] }
- { FACTOR-BLOB [
- sqlite-column-blob
- dup [ bytes>object ] when
- ] }
- ! { NULL [ 2drop f ] }
+ { FACTOR-BLOB [ sqlite-column-blob dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
dup path>> sqlite-open >>handle ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
-M: sqlite-db dispose ( db -- ) db-dispose ;
TUPLE: sqlite-statement < statement ;
in-params>> [ sqlite-bind-conversion ] with map
] keep bind-statement ;
+ERROR: sqlite-last-id-fail ;
+
: last-insert-id ( -- id )
db get handle>> sqlite3_last_insert_rowid
- dup zero? [ "last-id failed" throw ] when ;
+ dup zero? [ sqlite-last-id-fail ] when ;
M: sqlite-db insert-tuple-set-key ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
{ +random-id+ { "integer" "integer" f } }
{ +foreign-id+ { "integer" "integer" "references" } }
+ { +on-update+ { f f "on update" } }
{ +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } }
{ +set-null+ { f f "set null" } }
{ +set-default+ { f f "set default" } }
+ { BOOLEAN { "boolean" "boolean" f } }
{ INTEGER { "integer" "integer" f } }
{ BIG-INTEGER { "bigint" "bigint" f } }
{ SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
"Now we've created a book. Let's save it to the database."
{ $code <" USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- )
- '[ "book-tutorial.db" temp-file sqlite-db _ with-db ] call ;
+ '[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ;
[
book recreate-table
T{ exam } select-tuples
] unit-test
- [ 4 ] [ T{ exam } count-tuples ] unit-test ;
+ [ 4 ] [ T{ exam } count-tuples ] unit-test
+
+ [ ] [ T{ exam { score 10 } } insert-tuple ] unit-test
+
+ [ 10 ]
+ [ T{ exam { name NULL } } select-tuples first score>> ] unit-test ;
TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )
UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
-+foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
-+set-default+ ;
++foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
++set-null+ +set-default+ ;
SYMBOL: IGNORE
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
-SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL URL ;
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system io.files.private
-listener ;
+help generic.standard continuations io.files.private listener ;
IN: debugger
ARTICLE: "debugger" "The debugger"
{ $notes "This can be a result of incorrect usage of C library interface words, a bug in the compiler, or a bug in the VM." } ;
HELP: primitive-error.
-{ $error-description "Thrown by the Factor VM if an unsupported primitive word is called." }
-{ $notes "This word is only ever thrown on Windows CE, where the " { $link cwd } ", " { $link cd } ", and " { $link os-env } " primitives are unsupported." } ;
+{ $error-description "Thrown by the Factor VM if an unsupported primitive word is called." } ;
: edit-location ( file line -- )
>r (normalize-path) r>
- edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
+ edit-hook get-global
+ [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
where [ first2 edit-location ] when* ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax io.streams.string sequences strings ;
+IN: environment
+
+HELP: (os-envs)
+{ $values
+
+ { "seq" sequence } }
+{ $description "" } ;
+
+HELP: (set-os-envs)
+{ $values
+ { "seq" sequence } }
+{ $description "" } ;
+
+
+HELP: os-env ( key -- value )
+{ $values { "key" string } { "value" string } }
+{ $description "Looks up the value of a shell environment variable." }
+{ $examples
+ "This is an operating system-specific feature. On Unix, you can do:"
+ { $unchecked-example "\"USER\" os-env print" "jane" }
+} ;
+
+HELP: os-envs
+{ $values { "assoc" "an association mapping strings to strings" } }
+{ $description "Outputs the current set of environment variables." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+} ;
+
+HELP: set-os-envs
+{ $values { "assoc" "an association mapping strings to strings" } }
+{ $description "Replaces the current set of environment variables." }
+{ $notes
+ "Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
+} ;
+
+HELP: set-os-env ( value key -- )
+{ $values { "value" string } { "key" string } }
+{ $description "Set an environment variable." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+} ;
+
+HELP: unset-os-env ( key -- )
+{ $values { "key" string } }
+{ $description "Unset an environment variable." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+} ;
+
+{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
+
+
+ARTICLE: "environment" "Environment variables"
+"The " { $vocab-link "environment" } " vocabulary interfaces to the platform-dependent mechanism for setting environment variables." $nl
+"Windows CE has no concept of environment variables, so these words are undefined on that platform." $nl
+"Reading environment variables:"
+{ $subsection os-env }
+{ $subsection os-envs }
+"Writing environment variables:"
+{ $subsection set-os-env }
+{ $subsection unset-os-env }
+{ $subsection set-os-envs } ;
+
+ABOUT: "environment"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces prettyprint system tools.test
+environment strings sequences ;
+IN: environment.tests
+
+os wince? [
+ [ ] [ os-envs . ] unit-test
+
+ os unix? [
+ [ ] [ os-envs "envs" set ] unit-test
+ [ ] [ { { "A" "B" } } set-os-envs ] unit-test
+ [ "B" ] [ "A" os-env ] unit-test
+ [ ] [ "envs" get set-os-envs ] unit-test
+ [ t ] [ os-envs "envs" get = ] unit-test
+ ] when
+
+ [ ] [ "factor-test-key-1" unset-os-env ] unit-test
+ [ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
+ [ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
+ [ ] [ "factor-test-key-1" unset-os-env ] unit-test
+ [ f ] [ "factor-test-key-1" os-env ] unit-test
+
+ [ ] [
+ 32766 CHAR: a <string> "factor-test-key-long" set-os-env
+ ] unit-test
+ [ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
+ [ ] [ "factor-test-key-long" unset-os-env ] unit-test
+] unless
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs combinators kernel sequences splitting system
+vocabs.loader ;
+IN: environment
+
+HOOK: os-env os ( key -- value )
+
+HOOK: set-os-env os ( value key -- )
+
+HOOK: unset-os-env os ( key -- )
+
+HOOK: (os-envs) os ( -- seq )
+
+HOOK: (set-os-envs) os ( seq -- )
+
+: os-envs ( -- assoc )
+ (os-envs) [ "=" split1 ] H{ } map>assoc ;
+
+: set-os-envs ( assoc -- )
+ [ "=" swap 3append ] { } assoc>map (set-os-envs) ;
+
+{
+ { [ os unix? ] [ "environment.unix" require ] }
+ { [ os winnt? ] [ "environment.winnt" require ] }
+ { [ os wince? ] [ ] }
+} cond
--- /dev/null
+Environment variables
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax system environment.unix ;
+IN: environment.unix.macosx
+
+FUNCTION: void* _NSGetEnviron ( ) ;
+
+M: macosx environ _NSGetEnviron ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings alien.syntax kernel
+layouts sequences system unix environment io.encodings.utf8
+unix.utilities vocabs.loader combinators alien.accessors ;
+IN: environment.unix
+
+HOOK: environ os ( -- void* )
+
+M: unix environ ( -- void* ) "environ" f dlsym ;
+
+M: unix os-env ( key -- value ) getenv ;
+
+M: unix set-os-env ( value key -- ) swap 1 setenv io-error ;
+
+M: unix unset-os-env ( key -- ) unsetenv io-error ;
+
+M: unix (os-envs) ( -- seq )
+ environ *void* utf8 alien>strings ;
+
+: set-void* ( value alien -- ) 0 set-alien-cell ;
+
+M: unix (set-os-envs) ( seq -- )
+ utf8 strings>alien malloc-byte-array environ set-void* ;
+
+os {
+ { macosx [ "environment.unix.macosx" require ] }
+ [ drop ]
+} case
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.strings fry io.encodings.utf16 kernel
+splitting windows windows.kernel32 system environment
+alien.c-types sequences windows.errors io.streams.memory
+io.encodings io ;
+IN: environment.winnt
+
+M: winnt os-env ( key -- value )
+ MAX_UNICODE_PATH "TCHAR" <c-array>
+ [ dup length GetEnvironmentVariable ] keep over 0 = [
+ 2drop f
+ ] [
+ nip utf16n alien>string
+ ] if ;
+
+M: winnt set-os-env ( value key -- )
+ swap SetEnvironmentVariable win32-error=0/f ;
+
+M: winnt unset-os-env ( key -- )
+ f SetEnvironmentVariable 0 = [
+ GetLastError ERROR_ENVVAR_NOT_FOUND =
+ [ win32-error ] unless
+ ] when ;
+
+M: winnt (os-envs) ( -- seq )
+ GetEnvironmentStrings [
+ <memory-stream> [
+ utf16n decode-input
+ [ "\0" read-until drop dup empty? not ]
+ [ ] [ drop ] produce
+ ] with-input-stream*
+ ] [ FreeEnvironmentStrings win32-error=0/f ] bi ;
init-furnace-tables
] with-db
-: test-httpd ( -- )
- #! Return as soon as server is running.
- <http-server>
- 1237 >>insecure
- f >>secure
- start-server* ;
+: test-httpd ( responder -- )
+ [
+ main-responder set
+ <http-server>
+ 0 >>insecure
+ f >>secure
+ dup start-server*
+ sockets>> first addr>> port>>
+ ] with-scope "port" set ;
[ ] [
- [
+ <dispatcher>
+ add-quit-action
<dispatcher>
- add-quit-action
- <dispatcher>
- "resource:basis/http/test" <static> >>default
- "nested" add-responder
- <action>
- [ URL" redirect-loop" <temporary-redirect> ] >>display
- "redirect-loop" add-responder
- main-responder set
+ "resource:basis/http/test" <static> >>default
+ "nested" add-responder
+ <action>
+ [ URL" redirect-loop" <temporary-redirect> ] >>display
+ "redirect-loop" add-responder
- test-httpd
- ] with-scope
+ test-httpd
] unit-test
+: add-port ( url -- url' )
+ >url clone "port" get >>port ;
+
[ t ] [
"resource:basis/http/test/foo.html" ascii file-contents
- "http://localhost:1237/nested/foo.html" http-get nip =
+ "http://localhost/nested/foo.html" add-port http-get nip =
] unit-test
-[ "http://localhost:1237/redirect-loop" http-get nip ]
+[ "http://localhost/redirect-loop" add-port http-get nip ]
[ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [
- "http://localhost:1237/quit" http-get nip
+ "http://localhost/quit" add-port http-get nip
] unit-test
! HTTP client redirect bug
[ ] [
- [
- <dispatcher>
- add-quit-action
- <action> [ "quit" <temporary-redirect> ] >>display
- "redirect" add-responder
- main-responder set
+ <dispatcher>
+ add-quit-action
+ <action> [ "quit" <temporary-redirect> ] >>display
+ "redirect" add-responder
- test-httpd
- ] with-scope
+ test-httpd
] unit-test
[ "Goodbye" ] [
- "http://localhost:1237/redirect" http-get nip
+ "http://localhost/redirect" add-port http-get nip
] unit-test
[ ] [
- [ "http://localhost:1237/quit" http-get 2drop ] ignore-errors
+ [ "http://localhost/quit" add-port http-get 2drop ] ignore-errors
] unit-test
! Dispatcher bugs
[ ] [
- [
+ <dispatcher>
+ <action> <protected>
+ "Test" <login-realm>
+ <sessions>
+ "" add-responder
+ add-quit-action
<dispatcher>
- <action> <protected>
- "Test" <login-realm>
- <sessions>
- "" add-responder
- add-quit-action
- <dispatcher>
- <action> "" add-responder
- "d" add-responder
- test-db <db-persistence>
- main-responder set
+ <action> "" add-responder
+ "d" add-responder
+ test-db <db-persistence>
- test-httpd
- ] with-scope
+ test-httpd
] unit-test
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop
-[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with
+[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
! This should give a 404 not an infinite redirect loop
-[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with
+[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with
-[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
[ ] [
- [
- <dispatcher>
- <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
- "Test" <login-realm>
- <sessions>
- "" add-responder
- add-quit-action
- test-db <db-persistence>
- main-responder set
-
- test-httpd
- ] with-scope
+ <dispatcher>
+ <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
+ "Test" <login-realm>
+ <sessions>
+ "" add-responder
+ add-quit-action
+ test-db <db-persistence>
+
+ test-httpd
] unit-test
-[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
+[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test
-[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
USING: html.components html.elements html.forms
xml xml.utilities validators
SYMBOL: a
[ ] [
- [
- <dispatcher>
- <action>
- [ a get-global "a" set-value ] >>init
- [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
- [ { { "a" [ v-integer ] } } validate-params ] >>validate
- [ "a" value a set-global URL" " <redirect> ] >>submit
- <conversations>
- <sessions>
- >>default
- add-quit-action
- test-db <db-persistence>
- main-responder set
-
- test-httpd
- ] with-scope
+ <dispatcher>
+ <action>
+ [ a get-global "a" set-value ] >>init
+ [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
+ [ { { "a" [ v-integer ] } } validate-params ] >>validate
+ [ "a" value a set-global URL" " <redirect> ] >>submit
+ <conversations>
+ <sessions>
+ >>default
+ add-quit-action
+ test-db <db-persistence>
+
+ test-httpd
] unit-test
3 a set-global
: test-a string>xml "input" tag-named "value" swap at ;
[ "3" ] [
- "http://localhost:1237/" http-get
+ "http://localhost/" add-port http-get
swap dup cookies>> "cookies" set session-id-key get-cookie
value>> "session-id" set test-a
] unit-test
[ "4" ] [
- H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
- "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+ [
+ "4" "a" set
+ "http://localhost" add-port "__u" set
+ "session-id" get session-id-key set
+ ] H{ } make-assoc
+ "http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
! Test flash scope
[ "xyz" ] [
- H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
- "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+ [
+ "xyz" "a" set
+ "http://localhost" add-port "__u" set
+ "session-id" get session-id-key set
+ ] H{ } make-assoc
+ "http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
-[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
\r
\ serve-file NOTICE add-input-logging\r
\r
-: file. ( name dirp -- )\r
- [ "/" append ] when\r
+: file. ( name -- )\r
+ dup link-info directory? [ "/" append ] when\r
dup <a =href a> escape-string write </a> ;\r
\r
: directory. ( path -- )\r
[ <h1> file-name escape-string write </h1> ]\r
[\r
<ul>\r
- directory sort-keys\r
- [ <li> file. </li> ] assoc-each\r
+ directory-files [ <li> file. </li> ] each\r
</ul>\r
] bi\r
] simple-page ;\r
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
-math accessors concurrency.flags destructors
+math accessors concurrency.flags destructors environment
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.streams.duplex io.ports debugger prettyprint summary ;
IN: io.launcher
! Non-blocking process exit notification facility
SYMBOL: processes
-[ H{ } clone processes set-global ] "io.launcher" add-init-hook
-
HOOK: wait-for-processes io-backend ( -- ? )
SYMBOL: wait-flag
<flag> wait-flag set-global
[ wait-loop t ] "Process wait" spawn-server drop ;
-[ start-wait-thread ] "io.launcher" add-init-hook
+[
+ H{ } clone processes set-global
+ start-wait-thread
+] "io.launcher" add-init-hook
: process-started ( process handle -- )
>>handle
: add-child-monitors ( path -- )
#! We yield since this directory scan might take a while.
- directory* [ first add-child-monitor ] each yield ;
+ dup [
+ [ append-path ] with map
+ [ add-child-monitor ] each yield
+ ] with-directory-files ;
: add-child-monitor ( path -- )
notify? [ dup { +add-file+ } monitor tget queue-change ] when
- qualify-path dup link-info type>> +directory+ eq? [
+ qualify-path dup link-info directory? [
[ add-child-monitors ]
[
[
init-server semaphore>> count>>
] unit-test
-[ ] [ <promise> "p" set ] unit-test
-
[ ] [
<threaded-server>
5 >>max-connections
- 1237 >>insecure
+ 0 >>insecure
[ "Hello world." write stop-this-server ] >>handler
- "server" set
-] unit-test
-
-[ ] [
- [
- "server" get start-server
- t "p" get fulfill
- ] in-thread
+ dup start-server* sockets>> first addr>> port>> "port" set
] unit-test
-[ ] [ "server" get wait-for-server ] unit-test
-
-[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
-
-[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test
+[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types generic assocs kernel kernel.private
-math io.ports sequences strings structs sbufs threads unix
+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 ;
+locals unix.time ;
QUALIFIED: io
IN: io.unix.backend
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.ports io.unix.backend
bit-arrays sequences assocs unix unix.linux.epoll math
-namespaces structs ;
+namespaces unix.time ;
IN: io.unix.epoll
TUPLE: epoll-mx < mx events ;
--- /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"
-USING: tools.test io.files ;
+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
[ "/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
-! Copyright (C) 2005, 2008 Slava Pestov.
+! 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 ;
-
+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 unix.statfs ;
IN: io.unix.files
M: unix cwd ( -- path )
[ swap file-info permissions>> chmod io-error ]
2bi ;
-: stat>type ( stat -- type )
+HOOK: stat>file-info os ( stat -- file-info )
+
+HOOK: stat>type os ( stat -- file-info )
+
+HOOK: new-file-info os ( -- class )
+
+TUPLE: unix-file-info < file-info uid gid dev ino
+nlink rdev blocks blocksize ;
+
+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 ;
+
+M: unix stat>type ( stat -- type )
stat-st_mode S_IFMT bitand {
{ S_IFREG [ +regular-file+ ] }
{ S_IFDIR [ +directory+ ] }
[ drop +unknown+ ]
} case ;
-: stat>file-info ( stat -- info )
- {
- [ stat>type ]
- [ stat-st_size ]
- [ stat-st_mode ]
- [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
- } cleave
- \ file-info boa ;
+! 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
-M: unix file-info ( path -- info )
- normalize-path file-status stat>file-info ;
+: with-unix-directory ( path quot -- )
+ [ opendir dup [ (io-error) ] unless ] dip
+ dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
-M: unix link-info ( path -- info )
- normalize-path link-status stat>file-info ;
+: find-next-file ( DIR* -- byte-array )
+ "dirent" <c-object>
+ f <void*>
+ [ readdir_r 0 = [ (io-error) ] unless ] 2keep
+ *void* [ drop f ] unless ;
-M: unix make-link ( path1 path2 -- )
- normalize-path symlink io-error ;
+M: unix >directory-entry ( byte-array -- directory-entry )
+ [ dirent-d_name utf8 alien>string ]
+ [ dirent-d_type ] bi directory-entry boa ;
-M: unix read-link ( path -- path' )
- normalize-path read-symbolic-link ;
\ No newline at end of file
+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 ;
+
+: file-mode? ( path mask -- ? ) [ stat-mode ] dip mask? ;
+
+PRIVATE>
+
+: 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
+
+GENERIC: uid? ( obj -- ? )
+GENERIC: gid? ( obj -- ? )
+GENERIC: sticky? ( obj -- ? )
+GENERIC: user-read? ( obj -- ? )
+GENERIC: user-write? ( obj -- ? )
+GENERIC: user-execute? ( obj -- ? )
+GENERIC: group-read? ( obj -- ? )
+GENERIC: group-write? ( obj -- ? )
+GENERIC: group-execute? ( obj -- ? )
+GENERIC: other-read? ( obj -- ? )
+GENERIC: other-write? ( obj -- ? )
+GENERIC: other-execute? ( obj -- ? )
+
+M: integer uid? ( integer -- ? ) UID mask? ;
+M: integer gid? ( integer -- ? ) GID mask? ;
+M: integer sticky? ( integer -- ? ) STICKY mask? ;
+M: integer user-read? ( integer -- ? ) USER-READ mask? ;
+M: integer user-write? ( integer -- ? ) USER-WRITE mask? ;
+M: integer user-execute? ( integer -- ? ) USER-EXECUTE mask? ;
+M: integer group-read? ( integer -- ? ) GROUP-READ mask? ;
+M: integer group-write? ( integer -- ? ) GROUP-WRITE mask? ;
+M: integer group-execute? ( integer -- ? ) GROUP-EXECUTE mask? ;
+M: integer other-read? ( integer -- ? ) OTHER-READ mask? ;
+M: integer other-write? ( integer -- ? ) OTHER-WRITE mask? ;
+M: integer other-execute? ( integer -- ? ) OTHER-EXECUTE mask? ;
+
+M: file-info uid? ( file-info -- ? ) permissions>> uid? ;
+M: file-info gid? ( file-info -- ? ) permissions>> gid? ;
+M: file-info sticky? ( file-info -- ? ) permissions>> sticky? ;
+M: file-info user-read? ( file-info -- ? ) permissions>> user-read? ;
+M: file-info user-write? ( file-info -- ? ) permissions>> user-write? ;
+M: file-info user-execute? ( file-info -- ? ) permissions>> user-execute? ;
+M: file-info group-read? ( file-info -- ? ) permissions>> group-read? ;
+M: file-info group-write? ( file-info -- ? ) permissions>> group-write? ;
+M: file-info group-execute? ( file-info -- ? ) permissions>> group-execute? ;
+M: file-info other-read? ( file-info -- ? ) permissions>> other-read? ;
+M: file-info other-write? ( file-info -- ? ) permissions>> other-write? ;
+M: file-info other-execute? ( file-info -- ? ) permissions>> other-execute? ;
+
+M: string uid? ( path -- ? ) UID file-mode? ;
+M: string gid? ( path -- ? ) GID file-mode? ;
+M: string sticky? ( path -- ? ) STICKY file-mode? ;
+M: string user-read? ( path -- ? ) USER-READ file-mode? ;
+M: string user-write? ( path -- ? ) USER-WRITE file-mode? ;
+M: string user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
+M: string group-read? ( path -- ? ) GROUP-READ file-mode? ;
+M: string group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
+M: string group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
+M: string other-read? ( path -- ? ) OTHER-READ file-mode? ;
+M: string other-write? ( path -- ? ) OTHER-WRITE file-mode? ;
+M: string other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
+
+: 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 )
+ [ length "timeval" <c-array> ] keep
+ dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
+
+: timestamp>timeval ( timestamp -- timeval )
+ unix-1970 time- duration>milliseconds 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 ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.unix.backend math.bitwise
unix io.files.unique.backend system ;
IN: io.unix.files.unique
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces math system sequences debugger
continuations arrays assocs combinators alien.c-types strings
-threads accessors
+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
! 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 structs
-accessors math.order locals ;
+bit-arrays sequences assocs unix math namespaces
+accessors math.order locals unix.time ;
IN: io.unix.select
TUPLE: select-mx < mx read-fdset write-fdset ;
! 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.windows kernel math splitting
+io.windows kernel math splitting fry alien.strings
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces make words symbols system
-io.ports destructors accessors math.bitwise ;
+io.ports destructors accessors math.bitwise continuations
+windows.errors arrays byte-arrays ;
IN: io.windows.files
: open-file ( path access-mode create-mode flags -- handle )
normalize-path
RemoveDirectory win32-error=0/f ;
-M: windows normalize-directory ( string -- string )
- normalize-path "\\" ?tail drop "\\*" append ;
+M: windows >directory-entry ( byte-array -- directory-entry )
+ [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
+ [ WIN32_FIND_DATA-dwFileAttributes ]
+ bi directory-entry boa ;
+
+: find-first-file ( path -- WIN32_FIND_DATA handle )
+ "WIN32_FIND_DATA" <c-object> tuck
+ FindFirstFile
+ [ INVALID_HANDLE_VALUE = [ win32-error ] 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+
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
+ [ \ file-info new ] dip
{
- [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
+ [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
[
[ WIN32_FIND_DATA-nFileSizeLow ]
- [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
+ [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
]
- [ WIN32_FIND_DATA-dwFileAttributes ]
- ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ]
- [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
- ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
- } cleave
- \ file-info boa ;
+ [ 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> [
] keep ;
: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
+ [ \ file-info new ] dip
{
- [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ]
+ [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
[
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
- [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
+ [ 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-dwFileAttributes ]
- ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
- [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
- ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
! [
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
! ]
- } cleave
- \ file-info boa ;
+ } cleave ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
M: winnt link-info ( path -- info )
file-info ;
+HOOK: root-directory os ( string -- string' )
+
+TUPLE: winnt-file-system-info < file-system-info
+total-bytes total-free-bytes ;
+
+: file-system-type ( normalized-path -- str )
+ MAX_PATH 1+ <byte-array>
+ MAX_PATH 1+
+ "DWORD" <c-object> "DWORD" <c-object> "DWORD" <c-object>
+ MAX_PATH 1+ <byte-array>
+ MAX_PATH 1+
+ [ GetVolumeInformation win32-error=0/f ] 2keep drop
+ utf16n alien>string ;
+
+: file-system-space ( normalized-path -- free-space total-bytes total-free-bytes )
+ "ULARGE_INTEGER" <c-object>
+ "ULARGE_INTEGER" <c-object>
+ "ULARGE_INTEGER" <c-object>
+ [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
+
+M: winnt file-system-info ( path -- file-system-info )
+ normalize-path root-directory
+ dup [ file-system-type ] [ file-system-space ] bi
+ \ winnt-file-system-info new
+ swap *ulonglong >>total-free-bytes
+ swap *ulonglong >>total-bytes
+ swap *ulonglong >>free-space
+ swap >>type
+ swap >>mount-point ;
+
+: find-first-volume ( word -- string handle )
+ MAX_PATH 1+ <byte-array> dup length
+ dupd
+ FindFirstVolume dup win32-error=0/f
+ [ utf16n alien>string ] dip ;
+
+: find-next-volume ( handle -- string )
+ MAX_PATH 1+ <byte-array> dup length
+ [ FindNextVolume win32-error=0/f ] 2keep drop
+ utf16n alien>string ;
+
+: mounted ( -- array )
+ find-first-volume
+ [
+ '[
+ [ _ find-next-volume dup ]
+ [ ]
+ [ drop ] produce
+ swap prefix
+ ]
+ ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
+
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-path open-existing &dispose handle>>
USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.windows.files io.ports windows
-destructors ;
+destructors environment ;
IN: io.windows.files.unique
M: windows (make-unique-file) ( path -- )
USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.ports io.windows io.windows.files
io.windows.nt.backend windows windows.kernel32
-kernel libc math threads system
+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 io.files.private accessors tr ;
ERROR: not-absolute-path ;
-: root-directory ( string -- string' )
+M: winnt root-directory ( string -- string' )
+ unicode-prefix ?head drop
dup {
[ length 2 >= ]
[ second CHAR: : = ]
[ first Letter? ]
- } 1&& [ 2 head ] [ not-absolute-path ] if ;
+ } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
: prepend-prefix ( string -- string' )
dup unicode-prefix head? [
M: winnt open-append
[ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> >>ptr ;
+
+M: winnt home "USERPROFILE" os-env ;
-IN: io.windows.launcher.nt.tests\r
-USING: io.launcher tools.test calendar accessors\r
+USING: io.launcher tools.test calendar accessors environment\r
namespaces kernel system arrays io io.files io.encodings.ascii\r
sequences parser assocs hashtables math continuations eval ;\r
+IN: io.windows.launcher.nt.tests\r
\r
[ ] [\r
<process>\r
-USE: system\r
-USE: prettyprint\r
-os-envs .\r
+USE: system
+USE: prettyprint
+USE: environment
+os-envs .
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
-combinators.short-circuit.smart math.order ;
+combinators.short-circuit.smart math.order math.functions ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
[ f ] [ 8 &&-test ] unit-test
[ t ] [ 12 &&-test ] unit-test
-:: wlet-&&-test ( a -- ? )
- [wlet | is-integer? [ a integer? ]
- is-even? [ a even? ]
- >10? [ a 10 > ] |
- { [ is-integer? ] [ is-even? ] [ >10? ] } &&
+:: let-and-cond-test-1 ( -- a )
+ [let | a [ 10 ] |
+ [let | a [ 20 ] |
+ {
+ { [ t ] [ [let | c [ 30 ] | a ] ] }
+ } cond
+ ]
] ;
-! [ f ] [ 1.5 wlet-&&-test ] unit-test
-! [ f ] [ 3 wlet-&&-test ] unit-test
-! [ f ] [ 8 wlet-&&-test ] unit-test
-! [ t ] [ 12 wlet-&&-test ] unit-test
+\ let-and-cond-test-1 must-infer
+
+[ 20 ] [ let-and-cond-test-1 ] unit-test
+
+:: let-and-cond-test-2 ( -- pair )
+ [let | A [ 10 ] |
+ [let | B [ 20 ] |
+ { { [ t ] [ { A B } ] } } cond
+ ]
+ ] ;
+
+\ let-and-cond-test-2 must-infer
+
+[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
[ { 10 } ] [ 10 [| a | { a } ] call ] unit-test
[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
+
+:: literal-identity-test ( -- a b )
+ { } V{ } ;
+
+[ t f ] [
+ literal-identity-test
+ literal-identity-test
+ swapd [ eq? ] [ eq? ] 2bi*
+] unit-test
+
:: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
obj1 obj2 <=> {
{ +lt+ [ lt-quot call ] }
{ +gt+ [ gt-quot call ] }
} case ; inline
-[ [ ] [ ] [ ] compare-case ] must-infer
\ No newline at end of file
+[ [ ] [ ] [ ] compare-case ] must-infer
+
+:: big-case-test ( a -- b )
+ a {
+ { 0 [ a 1 + ] }
+ { 1 [ a 1 - ] }
+ { 2 [ a 1 swap / ] }
+ { 3 [ a dup * ] }
+ { 4 [ a sqrt ] }
+ { 5 [ a a ^ ] }
+ } case ;
+
+\ big-case-test must-infer
+
+[ 9 ] [ 3 big-case-test ] unit-test
+
+! :: wlet-&&-test ( a -- ? )
+! [wlet | is-integer? [ a integer? ]
+! is-even? [ a even? ]
+! >10? [ a 10 > ] |
+! { [ is-integer? ] [ is-even? ] [ >10? ] } &&
+! ] ;
+
+! [ f ] [ 1.5 wlet-&&-test ] unit-test
+! [ f ] [ 3 wlet-&&-test ] unit-test
+! [ f ] [ 8 wlet-&&-test ] unit-test
+! [ t ] [ 12 wlet-&&-test ] unit-test
\ No newline at end of file
M: lambda expand-macros clone [ expand-macros ] change-body ;
+M: lambda expand-macros* expand-macros literal ;
+
M: binding-form expand-macros
clone
[ [ expand-macros ] assoc-map ] change-bindings
[ expand-macros ] change-body ;
+M: binding-form expand-macros* expand-macros literal ;
+
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
[ free-vars* ] { } make prune ;
: add-if-free ( object -- )
- {
- { [ dup local-writer? ] [ "local-reader" word-prop , ] }
- { [ dup lexical? ] [ , ] }
- { [ dup quote? ] [ local>> , ] }
- { [ t ] [ free-vars* ] }
- } cond ;
+ {
+ { [ dup local-writer? ] [ "local-reader" word-prop , ] }
+ { [ dup lexical? ] [ , ] }
+ { [ dup quote? ] [ local>> , ] }
+ { [ t ] [ free-vars* ] }
+ } cond ;
M: object free-vars* drop ;
swap point-free ,
] keep length \ curry <repetition> % ;
+GENERIC: rewrite-literal? ( obj -- ? )
+
+M: special rewrite-literal? drop t ;
+
+M: array rewrite-literal? [ rewrite-literal? ] contains? ;
+
+M: hashtable rewrite-literal? drop t ;
+
+M: vector rewrite-literal? drop t ;
+
+M: tuple rewrite-literal? drop t ;
+
+M: object rewrite-literal? drop f ;
+
GENERIC: rewrite-element ( obj -- )
: rewrite-elements ( seq -- )
: rewrite-sequence ( seq -- )
[ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
-M: array rewrite-element rewrite-sequence ;
+M: array rewrite-element
+ dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: vector rewrite-element rewrite-sequence ;
"lambda" word-prop body>> ;
M: lambda-macro reset-word
- [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-method method-body lambda-word ;
"lambda" word-prop body>> ;
M: lambda-memoized reset-word
- [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>
\r
: (rotate-logs) ( -- )\r
(close-logs)\r
- log-root directory [ drop rotate-log ] assoc-each ;\r
+ log-root directory-files [ rotate-log ] each ;\r
\r
: log-server-loop ( -- )\r
receive unclip {\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces make quotations accessors
-words continuations vectors effects math
-stack-checker.transforms ;
+USING: kernel sequences sequences.private namespaces make
+quotations accessors words continuations vectors effects math
+generalizations stack-checker.transforms fry ;
IN: macros.expander
GENERIC: expand-macros ( quot -- quot' )
-<PRIVATE
-
SYMBOL: stack
: begin ( -- ) V{ } clone stack set ;
M: wrapper expand-macros* wrapped>> literal ;
+: expand-dispatch? ( word -- ? )
+ \ dispatch eq? stack get length 1 >= and ;
+
+: expand-dispatch ( -- )
+ stack get pop end
+ [ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
+ [
+ length [ <reversed> ] keep
+ [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
+ ] bi ;
+
: expand-macro ( quot -- )
stack [ swap with-datastack >vector ] change
stack get pop >quotation end (expand-macros) ;
stack get length <=
] [ 2drop f f ] if ;
+: word, ( word -- ) end , ;
+
M: word expand-macros*
- dup expand-macro? [ nip expand-macro ] [ drop end , ] if ;
+ dup expand-dispatch? [ drop expand-dispatch ] [
+ dup expand-macro? [ nip expand-macro ] [
+ drop word,
+ ] if
+ ] if ;
M: object expand-macros* literal ;
M: callable expand-macros ( quot -- quot' )
[ begin (expand-macros) end ] [ ] make ;
-
-PRIVATE>
{ $description "Generates a byte-array of random bytes." } ;
HELP: random
-{ $values { "obj" object } { "elt" "a random element" } }
-{ $description "Outputs a random element of the input object. If the object is an integer, an input of zero always returns a zero, while any other integer integers yield a random integer in the interval between itself and zero, inclusive of zero. On a sequence, an empty sequence always outputs " { $link f } "." }
+{ $values { "seq" sequence } { "elt" "a random element" } }
+{ $description "Outputs a random element of the input sequence. Outputs " { $link f } " if the sequence is empty." }
+{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " outputs an integer in the interval " { $snippet "[0,n)" } "." }
{ $examples
{ $unchecked-example "USING: random prettyprint ;"
"10 random ."
"3" }
- { $example "USING: random prettyprint ;"
- "0 random ."
- "0" }
{ $unchecked-example "USING: random prettyprint ;"
- "-10 random ."
- "-8" }
- { $unchecked-example "USING: random prettyprint ;"
- "{ \"a\" \"b\" \"c\" } random ."
- "\"a\"" }
+ "SYMBOL: heads"
+ "SYMBOL: tails"
+ "{ heads tails } random ."
+ "heads" }
} ;
HELP: random-bytes
{ $subsection seed-random } ;
ARTICLE: "random" "Generating random integers"
-"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers. The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
+"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers."
+$nl
+"The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
+$nl
"Generate a random object:"
{ $subsection random }
"Combinators to change the random number generator:"
[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
-[ 0 ] [ 0 random ] unit-test
+[ f ] [ 0 random ] unit-test
random-generator get random-bytes*
] keep head ;
-GENERIC: random ( obj -- elt )
-
-: random-bits ( n -- r ) 2^ random ;
-
<PRIVATE
: random-integer ( n -- n' )
PRIVATE>
-M: sequence random ( seq -- elt )
+: random-bits ( n -- r ) 2^ random-integer ;
+
+: random ( seq -- elt )
[ f ] [
[ length random-integer ] keep nth
] if-empty ;
-ERROR: negative-random n ;
-M: integer random ( integer -- integer' )
- {
- { [ dup 0 = ] [ ] }
- { [ dup 0 < ] [ neg random-integer neg ] }
- [ random-integer ]
- } cond ;
-
: delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ;
\ (exists?) { string } { object } define-primitive
-\ (directory) { string } { array } define-primitive
-
\ gc { } { } define-primitive
\ gc-stats { } { array } define-primitive
\ code-room { } { integer integer integer integer } define-primitive
\ code-room make-flushable
-\ os-env { string } { object } define-primitive
-
\ millis { } { integer } define-primitive
\ millis make-flushable
\ set-innermost-frame-quot { quotation callstack } { } define-primitive
-\ (os-envs) { } { array } define-primitive
-
-\ set-os-env { string string } { } define-primitive
-
-\ unset-os-env { string } { } define-primitive
-
-\ (set-os-envs) { array } { } define-primitive
-
\ dll-valid? { object } { object } define-primitive
\ modify-code-heap { array object } { } define-primitive
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: alien.c-types alien.syntax kernel math ;
-IN: structs
-
-C-STRUCT: timeval
- { "long" "sec" }
- { "long" "usec" } ;
-
-: make-timeval ( ms -- timeval )
- 1000 /mod 1000 *
- "timeval" <c-object>
- [ set-timeval-usec ] keep
- [ set-timeval-sec ] keep ;
+++ /dev/null
-Cross-platform C structs
IN: tools.deploy.tests\r
USING: tools.test system io.files kernel tools.deploy.config\r
tools.deploy.backend math sequences io.launcher arrays\r
-namespaces continuations layouts accessors ;\r
+namespaces continuations layouts accessors io.encodings.ascii\r
+urls math.parser ;\r
\r
: shake-and-bake ( vocab -- )\r
[ "test.image" temp-file delete-file ] ignore-errors\r
! [ ] [ "tetris" shake-and-bake ] unit-test\r
! \r
! [ t ] [ 1500000 small-enough? ] unit-test\r
-! \r
+\r
[ ] [ "bunny" shake-and-bake ] unit-test\r
\r
[ t ] [ 2500000 small-enough? ] unit-test\r
: add-quot-responder ( responder -- responder )\r
quit-responder "quit" add-responder ;\r
\r
-: test-httpd ( -- )\r
- #! Return as soon as server is running.\r
- <http-server>\r
- 1237 >>insecure\r
- f >>secure\r
- start-server* ;\r
-\r
-[ ] [\r
+: test-httpd ( responder -- )\r
[\r
- <dispatcher>\r
- add-quot-responder\r
- "resource:basis/http/test" <static> >>default\r
main-responder set\r
-\r
- test-httpd\r
+ <http-server>\r
+ 0 >>insecure\r
+ f >>secure\r
+ dup start-server*\r
+ sockets>> first addr>> port>>\r
+ dup number>string "resource:temp/port-number" ascii set-file-contents\r
] with-scope\r
+ "port" set ;\r
+\r
+[ ] [\r
+ <dispatcher>\r
+ add-quot-responder\r
+ "resource:basis/http/test" <static> >>default\r
+\r
+ test-httpd\r
] unit-test\r
\r
[ ] [\r
run-temp-image\r
] unit-test\r
\r
-[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test\r
+: add-port ( url -- url' )\r
+ >url clone "port" get >>port ;\r
+\r
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test\r
\r
[ ] [\r
"tools.deploy.test.6" shake-and-bake\r
] [ drop ] if ;
: strip-c-io ( -- )
- deploy-io get 2 = [
+ deploy-io get 2 = os windows? or [
[
c-io-backend forget
"io.streams.c" forget-vocab
IN: tools.deploy.test.5
-USING: http.client kernel ;
+USING: accessors urls io.encodings.ascii io.files math.parser
+http.client kernel ;
: deploy-test-5 ( -- )
- "http://localhost:1237/foo.html" http-get 2drop ;
+ URL" http://localhost/foo.html" clone
+ "resource:port-number" ascii file-contents string>number >>port
+ http-get 2drop ;
MAIN: deploy-test-5
USING: tools.deploy.config ;
H{
- { deploy-threads? f }
- { deploy-ui? f }
+ { deploy-reflection 1 }
+ { deploy-word-props? f }
{ deploy-io 1 }
- { deploy-c-types? f }
{ deploy-name "tools.deploy.test.6" }
+ { deploy-math? t }
+ { deploy-random? f }
{ deploy-compiler? t }
- { deploy-reflection 1 }
- { deploy-word-props? f }
+ { deploy-ui? f }
+ { deploy-c-types? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
- { deploy-random? f }
- { deploy-math? f }
+ { deploy-threads? f }
}
"resource:freetype6.dll"
"resource:zlib1.dll"
} swap copy-files-into
- ] when ;
+ ] [ drop ] if ;
: create-exe-dir ( vocab bundle-name -- vm )
deploy-ui? get [
ERROR: no-vocab vocab ;
<PRIVATE
-: root? ( string -- ? )
- vocab-roots get member? ;
+
+: root? ( string -- ? ) vocab-roots get member? ;
+
+: length-changes? ( seq quot -- ? )
+ dupd call [ length ] bi@ = not ; inline
: check-vocab-name ( string -- string )
- dup dup [ CHAR: . = ] trim [ length ] bi@ =
- [ vocab-name-contains-dot ] unless
+ dup [ [ CHAR: . = ] trim ] length-changes?
+ [ vocab-name-contains-dot ] when
+
".." over subseq? [ vocab-name-contains-dot ] when
+
dup [ path-separator? ] contains?
[ vocab-name-contains-separator ] when ;
: scaffolding ( path -- )
"Creating scaffolding for " write <pathname> . ;
+: (scaffold-path) ( path string -- path )
+ dupd [ file-name ] dip append append-path ;
+
: scaffold-path ( path string -- path ? )
- dupd [ file-name ] dip append append-path
+ (scaffold-path)
dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
: scaffold-copyright ( -- )
: check-vocab ( vocab -- vocab )
dup find-vocab-root [ no-vocab ] unless ;
+
PRIVATE>
: link-vocab ( vocab -- )
check-vocab
"Edit documentation: " write
- [ find-vocab-root ] keep
- [ append-path ] keep "-docs.factor" append append-path
- <pathname> . ;
+ [ find-vocab-root ]
+ [ vocab>scaffold-path ] bi
+
"-docs.factor" (scaffold-path) <pathname> . ;
: help. ( word -- )
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
error-continuation get 3array ;
: failure ( error what -- )
+ "--> test failed!" print
<failure> failures get push ;
SYMBOL: this-test
: vocab-tests-dir ( vocab -- paths )\r
dup vocab-dir "tests" append-path vocab-append-path dup [\r
dup exists? [\r
- dup directory keys\r
- [ ".factor" tail? ] filter\r
+ dup directory-files [ ".factor" tail? ] filter\r
[ append-path ] with map\r
] [ drop f ] if\r
] [ drop f ] if ;\r
dup vocab-authors-path set-vocab-file-contents ;\r
\r
: subdirs ( dir -- dirs )\r
- directory [ second ] filter keys natural-sort ;\r
+ [\r
+ [ link-info directory? ] filter\r
+ ] with-directory-files natural-sort ;\r
\r
: (all-child-vocabs) ( root name -- vocabs )\r
- [ vocab-dir append-path subdirs ] keep\r
[\r
+ vocab-dir append-path dup exists?\r
+ [ subdirs ] [ drop { } ] if\r
+ ] keep [\r
swap [ "." swap 3append ] with map\r
] unless-empty ;\r
\r
}
! Rendering
-{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
- [ 3drop window relayout-1 ]
+{ "drawRect:" "void" { "id" "SEL" "NSRect" }
+ [ 2drop window relayout-1 ]
}
! Events
-{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
+{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
[ 3drop 1 ]
}
! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
-{ "acceptsFirstResponder" "bool" { "id" "SEL" }
+{ "acceptsFirstResponder" "char" { "id" "SEL" }
[ 2drop 1 ]
}
]
}
-{ "writeSelectionToPasteboard:types:" "bool" { "id" "SEL" "id" "id" }
+{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
[
CF>string-array NSStringPboardType swap member? [
>r drop window-focus gadget-selection dup [
- r> set-pasteboard-string t
+ r> set-pasteboard-string 1
] [
- r> 2drop f
+ r> 2drop 0
] if
] [
- 3drop f
+ 3drop 0
] if
]
}
-{ "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" }
+{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
[
pasteboard-string dup [
- >r drop window-focus r> swap user-input t
+ >r drop window-focus r> swap user-input 1
] [
- 3drop f
+ 3drop 0
] if
]
}
[ [ nip send-user-input ] ui-try ]
}
-{ "hasMarkedText" "bool" { "id" "SEL" }
+{ "hasMarkedText" "char" { "id" "SEL" }
[ 2drop 0 ]
}
[ 3drop f ]
}
-{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" }
+{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
[ 3drop 0 ]
}
[ 3drop 0 0 0 0 <NSRect> ]
}
-{ "conversationIdentifier" "long" { "id" "SEL" }
+{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
[ drop alien-address ]
}
]
}
-{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
+{ "windowShouldClose:" "char" { "id" "SEL" "id" }
[
- 3drop t
+ 3drop 1
]
}
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads arrays generic threads accessors listener ;
+threads arrays generic threads accessors listener math ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
+
+[ ] [ \ + <pane> <interactor> interactor-use use-if-necessary ] unit-test
"engine-generic" word-prop word-completion-string ;
: use-if-necessary ( word seq -- )
- over vocabulary>> [
- 2dup assoc-stack pick = [ 2drop ] [
+ over vocabulary>> over and [
+ 2dup [ assoc-stack ] keep = [ 2drop ] [
>r vocabulary>> vocab-words r> push
] if
] [ 2drop ] if ;
2bi ;
: quot-action ( interactor -- lines )
- dup control-value
- dup "\n" join pick add-interactor-history
- swap select-all ;
+ [ control-value ] keep
+ [ [ "\n" join ] dip add-interactor-history ]
+ [ select-all ]
+ 2bi ;
TUPLE: stack-display < track ;
: resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [
- 1/5 1 pick set-nth
- 4/5 2 rot set-nth
+ 1/5 over set-second
+ 4/5 swap set-third
] [
- 2/3 1 pick set-nth
- 1/3 2 rot set-nth
+ 2/3 over set-second
+ 1/3 swap set-third
] if relayout ;
M: workspace model-changed
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
- dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
+ dup window-loc>> dup rot rect-dim v+
"RECT" <c-object>
over first over set-RECT-right
swap second over set-RECT-bottom
over first over set-RECT-left
swap second over set-RECT-top ;
+: default-position-RECT ( RECT -- )
+ dup get-RECT-dimensions [ 2drop ] 2dip
+ CW_USEDEFAULT + pick set-RECT-bottom
+ CW_USEDEFAULT + over set-RECT-right
+ CW_USEDEFAULT over set-RECT-left
+ CW_USEDEFAULT swap set-RECT-top ;
+
: make-adjusted-RECT ( rect -- RECT )
- make-RECT dup adjust-RECT ;
+ make-RECT
+ dup get-RECT-top-left [ zero? ] both? swap
+ dup adjust-RECT
+ swap [ dup default-position-RECT ] when ;
: create-window ( rect -- hwnd )
make-adjusted-RECT
x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified
-math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
-QUALIFIED: system
+math.vectors classes.tuple opengl.gl threads math.geometry.rect
+environment ;
IN: ui.x11
SINGLETON: x11-ui-backend
x11-ui-backend ui-backend set-global
-[ "DISPLAY" system:os-env "ui" "listener" ? ]
+[ "DISPLAY" os-env "ui" "listener" ? ]
main-vocab-hook set-global
USING: alien.syntax combinators system vocabs.loader ;
IN: unix
-! FreeBSD
-
: MAXPATHLEN 1024 ; inline
: O_RDONLY HEX: 0000 ; inline
{ "uchar" "family" }
{ { "char" 104 } "path" } ;
+C-STRUCT: passwd
+ { "char*" "pw_name" }
+ { "char*" "pw_passwd" }
+ { "uid_t" "pw_uid" }
+ { "gid_t" "pw_gid" }
+ { "time_t" "pw_change" }
+ { "char*" "pw_class" }
+ { "char*" "pw_gecos" }
+ { "char*" "pw_dir" }
+ { "char*" "pw_shell" }
+ { "time_t" "pw_expire" }
+ { "int" "pw_fields" } ;
+
: max-un-path 104 ; inline
: SOCK_STREAM 1 ; inline
: SEEK_CUR 1 ; inline
: SEEK_END 2 ; 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
+
os {
{ macosx [ "unix.bsd.macosx" require ] }
{ freebsd [ "unix.bsd.freebsd" require ] }
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
+C-STRUCT: dirent
+ { "u_int32_t" "d_fileno" }
+ { "u_int16_t" "d_reclen" }
+ { "u_int8_t" "d_type" }
+ { "u_int8_t" "d_namlen" }
+ { { "char" 256 } "d_name" } ;
+
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline
-USING: alien.syntax ;
+USING: alien.syntax unix.time ;
IN: unix
: FD_SETSIZE 1024 ; inline
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
-C-STRUCT: passwd
- { "char*" "pw_name" }
- { "char*" "pw_passwd" }
- { "uid_t" "pw_uid" }
- { "gid_t" "pw_gid" }
- { "time_t" "pw_change" }
- { "char*" "pw_class" }
- { "char*" "pw_gecos" }
- { "char*" "pw_dir" }
- { "char*" "pw_shell" }
- { "time_t" "pw_expire" }
- { "int" "pw_fields" } ;
+: _UTX_USERSIZE 256 ; inline
+: _UTX_LINESIZE 32 ; inline
+: _UTX_IDSIZE 4 ; inline
+: _UTX_HOSTSIZE 256 ; inline
+
+C-STRUCT: utmpx
+ { { "char" _UTX_USERSIZE } "ut_user" }
+ { { "char" _UTX_IDSIZE } "ut_id" }
+ { { "char" _UTX_LINESIZE } "ut_line" }
+ { "pid_t" "ut_pid" }
+ { "short" "ut_type" }
+ { "timeval" "ut_tv" }
+ { { "char" _UTX_HOSTSIZE } "ut_host" }
+ { { "uint" 16 } "ut_pad" } ;
+
+: __DARWIN_MAXPATHLEN 1024 ; inline
+: __DARWIN_MAXNAMELEN 255 ; inline
+: __DARWIN_MAXNAMELEN+1 255 ; inline
+
+C-STRUCT: dirent
+ { "ino_t" "d_ino" }
+ { "__uint16_t" "d_reclen" }
+ { "__uint8_t" "d_type" }
+ { "__uint8_t" "d_namlen" }
+ { { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ;
: EPERM 1 ; inline
: ENOENT 2 ; inline
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types math vocabs.loader ;
IN: unix
: FD_SETSIZE 256 ; inline
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
+C-STRUCT: dirent
+ { "__uint32_t" "d_fileno" }
+ { "__uint16_t" "d_reclen" }
+ { "__uint8_t" "d_type" }
+ { "__uint8_t" "d_namlen" }
+ { { "char" 256 } "d_name" } ;
+
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline
: ENOLINK 95 ; inline
: EPROTO 96 ; inline
: ELAST 96 ; inline
+
+TYPEDEF: __uint8_t sa_family_t
+
+: _UTX_USERSIZE 32 ; inline
+: _UTX_LINESIZE 32 ; inline
+: _UTX_IDSIZE 4 ; inline
+: _UTX_HOSTSIZE 256 ; inline
+
+: _SS_MAXSIZE ( -- n )
+ 128 ; inline
+
+: _SS_ALIGNSIZE ( -- n )
+ "__int64_t" heap-size ; inline
+
+: _SS_PAD1SIZE ( -- n )
+ _SS_ALIGNSIZE 2 - ; inline
+
+: _SS_PAD2SIZE ( -- n )
+ _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline
+
+"unix.bsd.netbsd.structs" require
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax unix.time ;
+IN: unix
+
+C-STRUCT: sockaddr_storage
+ { "__uint8_t" "ss_len" }
+ { "sa_family_t" "ss_family" }
+ { { "char" _SS_PAD1SIZE } "__ss_pad1" }
+ { "__int64_t" "__ss_align" }
+ { { "char" _SS_PAD2SIZE } "__ss_pad2" } ;
+
+C-STRUCT: exit_struct
+ { "uint16_t" "e_termination" }
+ { "uint16_t" "e_exit" } ;
+
+C-STRUCT: utmpx
+ { { "char" _UTX_USERSIZE } "ut_user" }
+ { { "char" _UTX_IDSIZE } "ut_id" }
+ { { "char" _UTX_LINESIZE } "ut_line" }
+ { { "char" _UTX_HOSTSIZE } "ut_host" }
+ { "uint16_t" "ut_session" }
+ { "uint16_t" "ut_type" }
+ { "pid_t" "ut_pid" }
+ { "exit_struct" "ut_exit" }
+ { "sockaddr_storage" "ut_ss" }
+ { "timeval" "ut_tv" }
+ { { "uint32_t" 10 } "ut_pad" } ;
+
--- /dev/null
+unportable
{ "char*" "canonname" }
{ "addrinfo*" "next" } ;
+C-STRUCT: dirent
+ { "__uint32_t" "d_fileno" }
+ { "__uint16_t" "d_reclen" }
+ { "__uint8_t" "d_type" }
+ { "__uint8_t" "d_namlen" }
+ { { "char" 256 } "d_name" } ;
+
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string kernel quotations sequences strings math ;
+IN: unix.groups
+
+HELP: all-groups
+{ $values
+
+ { "seq" sequence } }
+{ $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ;
+
+HELP: effective-group-id
+{ $values
+
+ { "string" string } }
+{ $description "Returns the effective group id for the current user." } ;
+
+HELP: effective-group-name
+{ $values
+
+ { "string" string } }
+{ $description "Returns the effective group name for the current user." } ;
+
+HELP: group
+{ $description "A platform-specific tuple corresponding to every field from the Unix group struct including the group name, the group id, the group passwd, and a list of users in each group." } ;
+
+HELP: group-cache
+{ $description "A symbol containing a cache of groups returned from " { $link all-groups } " and indexed by group id. Can be more efficient than using the system call words for many group lookups." } ;
+
+HELP: group-id
+{ $values
+ { "string" string }
+ { "id" integer } }
+{ $description "Returns the group id given a group name." } ;
+
+HELP: group-name
+{ $values
+ { "id" integer }
+ { "string" string } }
+{ $description "Returns the group name given a group id." } ;
+
+HELP: group-struct
+{ $values
+ { "obj" object }
+ { "group" "a group struct" } }
+{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
+
+HELP: real-group-id
+{ $values
+
+ { "id" integer } }
+{ $description "Returns the real group id for the current user." } ;
+
+HELP: real-group-name
+{ $values
+
+ { "string" string } }
+{ $description "Returns the real group name for the current user." } ;
+
+HELP: set-effective-group
+{ $values
+ { "obj" object } }
+{ $description "Sets the effective group id for the current user." } ;
+
+HELP: set-real-group
+{ $values
+ { "obj" object } }
+{ $description "Sets the real group id for the current user." } ;
+
+HELP: user-groups
+{ $values
+ { "string/id" "a string or a group id" }
+ { "seq" sequence } }
+{ $description "Returns the sequence of groups to which the user belongs." } ;
+
+HELP: with-effective-group
+{ $values
+ { "string/id" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call." } ;
+
+HELP: with-group-cache
+{ $values
+ { "quot" quotation } }
+{ $description "Iterates over the group file using library calls and creates a cache in the " { $link group-cache } " symbol. The cache is a hashtable indexed by group id. When looking up many groups, this approach is much faster than calling system calls." } ;
+
+HELP: with-real-group
+{ $values
+ { "string/id" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
+
+ARTICLE: "unix.groups" "unix.groups"
+"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
+"Listing all groups:"
+{ $subsection all-groups }
+"Returning a passwd tuple:"
+"Real groups:"
+{ $subsection real-group-name }
+{ $subsection real-group-id }
+{ $subsection set-real-group }
+"Effective groups:"
+{ $subsection effective-group-name }
+{ $subsection effective-group-id }
+{ $subsection set-effective-group }
+"Combinators to change groups:"
+{ $subsection with-real-group }
+{ $subsection with-effective-group } ;
+
+ABOUT: "unix.groups"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test unix.groups kernel strings math ;
+IN: unix.groups.tests
+
+
+[ ] [ all-groups drop ] unit-test
+
+\ all-groups must-infer
+
+[ t ] [ real-group-name string? ] unit-test
+[ t ] [ effective-group-name string? ] unit-test
+
+[ t ] [ real-group-id integer? ] unit-test
+[ t ] [ effective-group-id integer? ] unit-test
+
+[ ] [ real-group-id set-real-group ] unit-test
+[ ] [ effective-group-id set-effective-group ] unit-test
+
+[ ] [ real-group-name [ ] with-real-group ] unit-test
+[ ] [ real-group-id [ ] with-real-group ] unit-test
+
+[ ] [ effective-group-name [ ] with-effective-group ] unit-test
+[ ] [ effective-group-id [ ] with-effective-group ] unit-test
--- /dev/null
+! 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
+accessors math.parser fry assocs namespaces continuations
+unix.users unix.utilities ;
+IN: unix.groups
+
+QUALIFIED: grouping
+
+TUPLE: group id name passwd members ;
+
+SYMBOL: group-cache
+
+GENERIC: group-struct ( obj -- group )
+
+<PRIVATE
+
+: group-members ( group-struct -- seq )
+ group-gr_mem utf8 alien>strings ;
+
+: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
+ "group" <c-object> tuck 4096
+ [ <byte-array> ] keep f <void*> ;
+
+M: integer group-struct ( id -- group )
+ (group-struct) getgrgid_r io-error ;
+
+M: string group-struct ( string -- group )
+ (group-struct) getgrnam_r 0 = [ (io-error) ] unless ;
+
+: group-struct>group ( group-struct -- group )
+ [ \ group new ] dip
+ {
+ [ group-gr_name >>name ]
+ [ group-gr_passwd >>passwd ]
+ [ group-gr_gid >>id ]
+ [ group-members >>members ]
+ } cleave ;
+
+PRIVATE>
+
+: group-name ( id -- string )
+ dup group-cache get [
+ at
+ ] [
+ group-struct group-gr_name
+ ] if*
+ [ nip ] [ number>string ] if* ;
+
+: group-id ( string -- id )
+ group-struct group-gr_gid ;
+
+<PRIVATE
+
+: >groups ( byte-array n -- groups )
+ [ 4 grouping:group ] dip head-slice [ *uint group-name ] map ;
+
+: (user-groups) ( string -- seq )
+ #! first group is -1337, legacy unix code
+ -1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
+ <int> [ getgrouplist io-error ] 2keep
+ [ 4 tail-slice ] [ *int 1- ] bi* >groups ;
+
+PRIVATE>
+
+GENERIC: user-groups ( string/id -- seq )
+
+M: string user-groups ( string -- seq )
+ (user-groups) ;
+
+M: integer user-groups ( id -- seq )
+ username (user-groups) ;
+
+: all-groups ( -- seq )
+ [ getgrent dup ] [ group-struct>group ] [ drop ] produce ;
+
+: with-group-cache ( quot -- )
+ all-groups [ [ id>> ] keep ] H{ } map>assoc
+ group-cache rot with-variable ; inline
+
+: real-group-id ( -- id )
+ getgid ; inline
+
+: real-group-name ( -- string )
+ real-group-id group-name ; inline
+
+: effective-group-id ( -- string )
+ getegid ; inline
+
+: effective-group-name ( -- string )
+ effective-group-id group-name ; inline
+
+GENERIC: set-real-group ( obj -- )
+
+GENERIC: set-effective-group ( obj -- )
+
+: with-real-group ( string/id quot -- )
+ '[ _ set-real-group @ ]
+ real-group-id '[ _ set-real-group ] [ ] cleanup ; inline
+
+: with-effective-group ( string/id quot -- )
+ '[ _ set-effective-group @ ]
+ effective-group-id '[ _ set-effective-group ] [ ] cleanup ; inline
+
+<PRIVATE
+
+: (set-real-group) ( id -- )
+ setgid io-error ; inline
+
+: (set-effective-group) ( id -- )
+ setegid io-error ; inline
+
+PRIVATE>
+
+M: string set-real-group ( string -- )
+ group-id (set-real-group) ;
+
+M: integer set-real-group ( id -- )
+ (set-real-group) ;
+
+M: integer set-effective-group ( id -- )
+ (set-effective-group) ;
+
+M: string set-effective-group ( string -- )
+ group-id (set-effective-group) ;
--- /dev/null
+unportable
-
USING: alien.syntax ;
-
IN: unix.linux.fs
: MS_RDONLY 1 ; ! Mount read-only.
! FUNCTION: int umount2 ( char* file, int flags ) ;
-FUNCTION: int umount ( char* file ) ;
\ No newline at end of file
+FUNCTION: int umount ( char* file ) ;
{ "char*" "pw_dir" }
{ "char*" "pw_shell" } ;
+C-STRUCT: dirent
+ { "__ino_t" "d_ino" }
+ { "__off_t" "d_off" }
+ { "ushort" "d_reclen" }
+ { "uchar" "d_type" }
+ { { "char" 256 } "d_name" } ;
+
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline
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 ;
+vectors kernel namespaces continuations threads assocs vectors
+io.unix.backend io.encodings.utf8 unix.utilities ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
-: >argv ( seq -- alien )
- [ utf8 malloc-string ] map f suffix >c-void*-array ;
-
: exec ( pathname argv -- int )
- [ utf8 malloc-string ] [ >argv ] bi* execv ;
+ [ utf8 malloc-string ] [ utf8 strings>alien ] bi* execv ;
: exec-with-path ( filename argv -- int )
- [ utf8 malloc-string ] [ >argv ] bi* execvp ;
+ [ utf8 malloc-string ] [ utf8 strings>alien ] bi* execvp ;
: exec-with-env ( filename argv envp -- int )
- [ utf8 malloc-string ] [ >argv ] [ >argv ] tri* execve ;
+ [ utf8 malloc-string ]
+ [ utf8 strings>alien ]
+ [ utf8 strings>alien ] tri* execve ;
: exec-args ( seq -- int )
[ first ] [ ] bi exec ;
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
: wait-for-pid ( pid -- status )
- 0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
\ No newline at end of file
+ 0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "__uint32_t" "pad1" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
\ No newline at end of file
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
-
USING: kernel alien.syntax math ;
-
IN: unix.stat
! Ubuntu 8.04 32-bit
{ "off_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt_t" "st_blocks" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "ulong" "unused4" }
{ "ulong" "unused5" } ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
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 ;
\ No newline at end of file
+: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
-
-USING: kernel alien.syntax math ;
-
+USING: kernel alien.syntax math sequences unix
+alien.c-types arrays accessors combinators ;
IN: unix.stat
! Ubuntu 7.10 64-bit
{ "off_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt_t" "st_blocks" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "long" "__unused0" }
{ "long" "__unused1" }
{ "long" "__unused2" } ;
-
-USING: layouts combinators vocabs.loader ;
-
+USING: alien.syntax layouts combinators vocabs.loader ;
IN: unix.stat
cell-bits
- {
+{
{ 32 [ "unix.stat.linux.32" require ] }
{ 64 [ "unix.stat.linux.64" require ] }
- }
-case
+} case
-
-USING: kernel alien.syntax math ;
-
+USING: kernel alien.syntax math unix math.bitwise
+alien.c-types alien sequences grouping accessors combinators ;
IN: unix.stat
! Mac OS X ppc
+! stat64 structure
C-STRUCT: stat
{ "dev_t" "st_dev" }
- { "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
+ { "ino64_t" "st_ino" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
+ { "timespec" "st_birthtimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "__int64_t" "st_qspare0" }
{ "__int64_t" "st_qspare1" } ;
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
+FUNCTION: int stat64 ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat64 ( char* pathname, stat* buf ) ;
-: stat-st_atim ( stat -- timespec ) stat-st_atimespec ;
-: stat-st_mtim ( stat -- timespec ) stat-st_mtimespec ;
-: stat-st_ctim ( stat -- timespec ) stat-st_ctimespec ;
+: stat ( path buf -- n ) stat64 ;
+: lstat ( path buf -- n ) lstat64 ;
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
- { "timespec" "st_birthtim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
+ { "timespec" "st_birthtimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "uint32_t" "st_flags" }
{ "uint32_t" "st_gen" }
{ "uint32_t" "st_spare0" }
- { "timespec" "st_birthtim" } ;
+ { "timespec" "st_birthtimespec" } ;
FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ;
-USING: layouts combinators vocabs.loader ;
+USING: layouts combinators vocabs.loader alien.syntax ;
IN: unix.stat
cell-bits {
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "int32_t" "st_lspare0" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "int64_t" "st_blocks" }
{ "u_int32_t" "st_blksize" }
{ "u_int32_t" "st_flags" }
{ "u_int32_t" "st_gen" }
{ "int32_t" "st_lspare1" }
- { "timespec" "st_birthtim" }
+ { "timespec" "st_birthtimespec" }
{ { "int64_t" 2 } "st_qspare" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
-
USING: kernel system combinators alien.syntax alien.c-types
- math io.unix.backend vocabs.loader unix ;
-
+math io.unix.backend vocabs.loader unix ;
IN: unix.stat
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! File Types
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: S_IFMT OCT: 170000 ; ! These bits determine file type.
: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
: S_IFSOCK OCT: 140000 ; inline ! Socket.
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! File Access Permissions
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Read, write, execute/search by owner
-: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
-: S_IRUSR OCT: 0000400 ; inline ! r owner
-: S_IWUSR OCT: 0000200 ; inline ! w owner
-: S_IXUSR OCT: 0000100 ; inline ! x owner
-! Read, write, execute/search by group
-: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
-: S_IRGRP OCT: 0000040 ; inline ! r group
-: S_IWGRP OCT: 0000020 ; inline ! w group
-: S_IXGRP OCT: 0000010 ; inline ! x group
-! Read, write, execute/search by others
-: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
-: S_IROTH OCT: 0000004 ; inline ! r other
-: S_IWOTH OCT: 0000002 ; inline ! w other
-: S_IXOTH OCT: 0000001 ; inline ! x other
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
FUNCTION: int chmod ( char* path, mode_t mode ) ;
-
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
-
FUNCTION: int mkdir ( char* path, mode_t mode ) ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-<<
- os
- {
+C-STRUCT: fsid
+ { { "int" 2 } "__val" } ;
+
+ TYPEDEF: fsid __fsid_t
+ TYPEDEF: fsid fsid_t
+
+<< os {
{ linux [ "unix.stat.linux" require ] }
{ macosx [ "unix.stat.macosx" require ] }
{ freebsd [ "unix.stat.freebsd" require ] }
{ netbsd [ "unix.stat.netbsd" require ] }
{ openbsd [ "unix.stat.openbsd" require ] }
- }
- case
->>
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+} case >>
: file-status ( pathname -- stat )
- "stat" <c-object> dup >r
- [ stat ] unix-system-call drop
- r> ;
+ "stat" <c-object> [ [ stat ] unix-system-call drop ] keep ;
: link-status ( pathname -- stat )
- "stat" <c-object> dup >r
- [ lstat ] unix-system-call drop
- r> ;
+ "stat" <c-object> [ [ lstat ] unix-system-call drop ] keep ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel unix math accessors
+combinators system io.backend alien.c-types unix.statfs
+io.files ;
+IN: unix.statfs.freebsd
+
+: ST_RDONLY 1 ; inline
+: ST_NOSUID 2 ; inline
+
+C-STRUCT: statvfs
+ { "fsblkcnt_t" "f_bavail" }
+ { "fsblkcnt_t" "f_bfree" }
+ { "fsblkcnt_t" "f_blocks" }
+ { "fsfilcnt_t" "f_favail" }
+ { "fsfilcnt_t" "f_ffree" }
+ { "fsfilcnt_t" "f_files" }
+ { "ulong" "f_bsize" }
+ { "ulong" "f_flag" }
+ { "ulong" "f_frsize" }
+ { "ulong" "f_fsid" }
+ { "ulong" "f_namemax" } ;
+
+FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
+
+TUPLE: freebsd-file-system-info < file-system-info
+bavail bfree blocks favail ffree files
+bsize flag frsize fsid namemax ;
+
+M: freebsd >file-system-info ( struct -- statfs )
+ [ \ freebsd-file-system-info new ] dip
+ {
+ [
+ [ statvfs-f_bsize ]
+ [ statvfs-f_bavail ] bi * >>free-space
+ ]
+ [ statvfs-f_bavail >>bavail ]
+ [ statvfs-f_bfree >>bfree ]
+ [ statvfs-f_blocks >>blocks ]
+ [ statvfs-f_favail >>favail ]
+ [ statvfs-f_ffree >>ffree ]
+ [ statvfs-f_files >>files ]
+ [ statvfs-f_bsize >>bsize ]
+ [ statvfs-f_flag >>flag ]
+ [ statvfs-f_frsize >>frsize ]
+ [ statvfs-f_fsid >>fsid ]
+ [ statvfs-f_namemax >>namemax ]
+ } cleave ;
+
+M: freebsd file-system-info ( path -- byte-array )
+ normalize-path
+ "statvfs" <c-object> tuck statvfs io-error
+ >file-system-info ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types combinators kernel unix.stat
+math accessors system unix io.backend layouts vocabs.loader
+alien.syntax unix.statfs io.files ;
+IN: unix.statfs.linux
+
+C-STRUCT: statfs
+ { "long" "f_type" }
+ { "long" "f_bsize" }
+ { "long" "f_blocks" }
+ { "long" "f_bfree" }
+ { "long" "f_bavail" }
+ { "long" "f_files" }
+ { "long" "f_ffree" }
+ { "fsid_t" "f_fsid" }
+ { "long" "f_namelen" } ;
+
+FUNCTION: int statfs ( char* path, statfs* buf ) ;
+
+TUPLE: linux32-file-system-info < file-system-info
+type bsize blocks bfree bavail files ffree fsid
+namelen frsize spare ;
+
+M: linux >file-system-info ( struct -- statfs )
+ [ \ linux32-file-system-info new ] dip
+ {
+ [
+ [ statfs-f_bsize ]
+ [ statfs-f_bavail ] bi * >>free-space
+ ]
+ [ statfs-f_type >>type ]
+ [ statfs-f_bsize >>bsize ]
+ [ statfs-f_blocks >>blocks ]
+ [ statfs-f_bfree >>bfree ]
+ [ statfs-f_bavail >>bavail ]
+ [ statfs-f_files >>files ]
+ [ statfs-f_ffree >>ffree ]
+ [ statfs-f_fsid >>fsid ]
+ [ statfs-f_namelen >>namelen ]
+ } cleave ;
+
+M: linux file-system-info ( path -- byte-array )
+ normalize-path
+ "statfs" <c-object> tuck statfs io-error
+ >file-system-info ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types combinators kernel unix.stat
+math accessors system unix io.backend layouts vocabs.loader
+alien.syntax unix.statfs io.files ;
+IN: unix.statfs.linux
+
+C-STRUCT: statfs64
+ { "__SWORD_TYPE" "f_type" }
+ { "__SWORD_TYPE" "f_bsize" }
+ { "__fsblkcnt64_t" "f_blocks" }
+ { "__fsblkcnt64_t" "f_bfree" }
+ { "__fsblkcnt64_t" "f_bavail" }
+ { "__fsfilcnt64_t" "f_files" }
+ { "__fsfilcnt64_t" "f_ffree" }
+ { "__fsid_t" "f_fsid" }
+ { "__SWORD_TYPE" "f_namelen" }
+ { "__SWORD_TYPE" "f_frsize" }
+ { { "__SWORD_TYPE" 5 } "f_spare" } ;
+
+FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
+
+TUPLE: linux64-file-system-info < file-system-info
+type bsize blocks bfree bavail files ffree fsid
+namelen frsize spare ;
+
+M: linux >file-system-info ( struct -- statfs )
+ [ \ linux64-file-system-info new ] dip
+ {
+ [
+ [ statfs64-f_bsize ]
+ [ statfs64-f_bavail ] bi * >>free-space
+ ]
+ [ statfs64-f_type >>type ]
+ [ statfs64-f_bsize >>bsize ]
+ [ statfs64-f_blocks >>blocks ]
+ [ statfs64-f_bfree >>bfree ]
+ [ statfs64-f_bavail >>bavail ]
+ [ statfs64-f_files >>files ]
+ [ statfs64-f_ffree >>ffree ]
+ [ statfs64-f_fsid >>fsid ]
+ [ statfs64-f_namelen >>namelen ]
+ [ statfs64-f_frsize >>frsize ]
+ [ statfs64-f_spare >>spare ]
+ } cleave ;
+
+M: linux file-system-info ( path -- byte-array )
+ normalize-path
+ "statfs64" <c-object> tuck statfs64 io-error
+ >file-system-info ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types combinators kernel io.files unix.stat
+math accessors system unix io.backend layouts vocabs.loader
+sequences csv io.streams.string io.encodings.utf8 namespaces
+unix.statfs io.files ;
+IN: unix.statfs.linux
+
+cell-bits {
+ { 32 [ "unix.statfs.linux.32" require ] }
+ { 64 [ "unix.statfs.linux.64" require ] }
+} case
+
+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 mounted
+ parse-mtab [
+ [ mount-point>> file-system-info ] keep
+ {
+ [ file-system-name>> >>device-name ]
+ [ mount-point>> >>mount-point ]
+ [ type>> >>type ]
+ } cleave
+ ] map ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types io.encodings.utf8 io.encodings.string
+kernel sequences unix.stat accessors unix combinators math
+grouping system unix.statfs io.files io.backend 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
+
+: MNT_VISFLAGMASK ( -- n )
+ {
+ MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
+ MNT_NOSUID MNT_NODEV MNT_UNION
+ MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
+ MNT_LOCAL MNT_QUOTA
+ MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
+ MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
+ 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
+
+: VFS_GENERIC 0 ; inline
+: VFS_NUMMNTOPS 1 ; inline
+: VFS_MAXTYPENUM 1 ; inline
+: VFS_CONF 2 ; inline
+: VFS_SET_PACKAGE_EXTS 3 ; inline
+
+: MNT_WAIT 1 ; inline
+: MNT_NOWAIT 2 ; inline
+
+: VFS_CTL_VERS1 HEX: 01 ; inline
+
+: 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
+
+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
+
+: 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
+
+: MFSNAMELEN 15 ; inline
+: MNAMELEN 90 ; inline
+: MFSTYPENAMELEN 16 ; inline
+
+C-STRUCT: fsid_t
+ { { "int32_t" 2 } "val" } ;
+
+C-STRUCT: statfs64
+ { "uint32_t" "f_bsize" }
+ { "int32_t" "f_iosize" }
+ { "uint64_t" "f_blocks" }
+ { "uint64_t" "f_bfree" }
+ { "uint64_t" "f_bavail" }
+ { "uint64_t" "f_files" }
+ { "uint64_t" "f_ffree" }
+ { "fsid_t" "f_fsid" }
+ { "uid_t" "f_owner" }
+ { "uint32_t" "f_type" }
+ { "uint32_t" "f_flags" }
+ { "uint32_t" "f_fssubtype" }
+ { { "char" MFSTYPENAMELEN } "f_fstypename" }
+ { { "char" MAXPATHLEN } "f_mntonname" }
+ { { "char" MAXPATHLEN } "f_mntfromname" }
+ { { "uint32_t" 8 } "f_reserved" } ;
+
+FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
+FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;
+
+
+TUPLE: macosx-file-system-info < file-system-info
+block-size io-size blocks blocks-free blocks-available files
+files-free file-system-id owner type-id flags filesystem-subtype ;
+
+M: macosx mounted ( -- array )
+ f <void*> dup 0 getmntinfo64 dup io-error
+ [ *void* ] dip
+ "statfs64" heap-size [ * memory>byte-array ] keep group
+ [ >file-system-info ] map ;
+
+M: macosx >file-system-info ( byte-array -- file-system-info )
+ [ \ macosx-file-system-info new ] dip
+ {
+ [
+ [ statfs64-f_bavail ] [ statfs64-f_bsize ] bi *
+ >>free-space
+ ]
+ [ statfs64-f_mntonname utf8 alien>string >>mount-point ]
+ [ 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 >>file-system-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_mntfromname
+ utf8 alien>string >>device-name
+ ]
+ } cleave ;
+
+M: macosx file-system-info ( path -- file-system-info )
+ normalize-path
+ "statfs64" <c-object> tuck statfs64 io-error
+ >file-system-info ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /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 unix.statfs io.files ;
+IN: unix.statfs.netbsd
+
+: _VFS_NAMELEN 32 ; inline
+: _VFS_MNAMELEN 1024 ; inline
+
+C-STRUCT: statvfs
+ { "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" }
+ { "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" }
+ { "fsid_t" "f_fsidx" }
+ { "ulong" "f_fsid" }
+ { "ulong" "f_namemax" }
+ { "uid_t" "f_owner" }
+ { { "uint32_t" 4 } "f_spare" }
+ { { "char" _VFS_NAMELEN } "f_fstypename" }
+ { { "char" _VFS_NAMELEN } "f_mntonname" }
+ { { "char" _VFS_NAMELEN } "f_mntfromname" } ;
+
+FUNCTION: int statvfs ( char* path, statvfs *buf ) ;
+
+TUPLE: netbsd-file-system-info < file-system-info
+flag bsize frsize io-size
+blocks blocks-free blocks-available blocks-reserved
+files ffree sync-reads sync-writes async-reads async-writes
+fsidx fsid namemax owner spare fstype mnotonname mntfromname
+file-system-type-name mount-from ;
+
+M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info )
+ [ \ netbsd-file-system-info new ] dip
+ {
+ [
+ [ statvfs-f_bsize ]
+ [ statvfs-f_bavail ] bi * >>free-space
+ ]
+ [ statvfs-f_flag >>flag ]
+ [ statvfs-f_bsize >>bsize ]
+ [ statvfs-f_frsize >>frsize ]
+ [ statvfs-f_iosize >>io-size ]
+ [ statvfs-f_blocks >>blocks ]
+ [ statvfs-f_bfree >>blocks-free ]
+ [ statvfs-f_favail >>blocks-available ]
+ [ statvfs-f_fresvd >>blocks-reserved ]
+ [ statvfs-f_files >>files ]
+ [ statvfs-f_ffree >>ffree ]
+ [ statvfs-f_syncreads >>sync-reads ]
+ [ statvfs-f_syncwrites >>sync-writes ]
+ [ statvfs-f_asyncreads >>async-reads ]
+ [ statvfs-f_asyncwrites >>async-writes ]
+ [ statvfs-f_fsidx >>fsidx ]
+ [ statvfs-f_namemax >>namemax ]
+ [ statvfs-f_owner >>owner ]
+ [ statvfs-f_spare >>spare ]
+ [ statvfs-f_fstypename utf8 alien>string >>file-system-type-name ]
+ [ statvfs-f_mntonname utf8 alien>string >>mount-point ]
+ [ statvfs-f_mntfromname utf8 alien>string >>mount-from ]
+ } cleave ;
+
+M: netbsd file-system-info
+ normalize-path "statvfs" <c-object> tuck statvfs io-error
+ >file-system-info ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel unix ;
+IN: unix.statfs.openbsd.32
+
+: MFSNAMELEN 16 ; inline
+: MNAMELEN 90 ; inline
+
+C-STRUCT: statfs
+ { "u_int32_t" "f_flags" }
+ { "int32_t" "f_bsize" }
+ { "u_int32_t" "f_iosize" }
+ { "u_int32_t" "f_blocks" }
+ { "u_int32_t" "f_bfree" }
+ { "int32_t" "f_bavail" }
+ { "u_int32_t" "f_files" }
+ { "u_int32_t" "f_ffree" }
+ { "fsid_t" "f_fsid" }
+ { "uid_t" "f_owner" }
+ { "u_int32_t" "f_syncwrites" }
+ { "u_int32_t" "f_asyncwrites" }
+ { "u_int32_t" "f_ctime" }
+ { { "u_int32_t" 3 } "f_spare" }
+ { { "char" MFSNAMELEN } "f_fstypename" }
+ { { "char" MNAMELEN } "f_mntonname" }
+ { { "char" MNAMELEN } "f_mntfromname" } ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax unix ;
+IN: unix.statfs.openbsd.64
+
+: MFSNAMELEN 16 ; inline
+: MNAMELEN 90 ; inline
+
+C-STRUCT: statfss
+ { "u_int32_t" "f_flags" }
+ { "u_int32_t" "f_bsize" }
+ { "u_int32_t" "f_iosize" }
+ { "u_int64_t" "f_blocks" }
+ { "u_int64_t" "f_bfree" }
+ { "int64_t" "f_bavail" }
+ { "u_int64_t" "f_files" }
+ { "u_int64_t" "f_ffree" }
+ { "int64_t" "f_favail" }
+ { "u_int64_t" "f_syncwrites" }
+ { "u_int64_t" "f_syncreads" }
+ { "u_int64_t" "f_asyncwrites" }
+ { "u_int64_t" "f_asyncreads" }
+ { "fsid_t" "f_fsid" }
+ { "u_int32_t" "f_namemax" }
+ { "uid_t" "f_owner" }
+ { "u_int32_t" "f_ctime" }
+ { { "u_int32_t" 3 } " f_spare" }
+ { { "char" MFSNAMELEN } "f_fstypename" }
+ { { "char" MNAMELEN } "f_mntonname" }
+ { { "char" MNAMELEN } "f_mntfromname" }
+ { { "char" 512 } "mount_info" } ;
+ ! { "mount_info" "mount_info" } ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax accessors combinators kernel
+unix.types math system io.backend alien.c-types unix
+unix.statfs io.files ;
+IN: unix.statfs.openbsd
+
+C-STRUCT: statvfs
+ { "ulong" "f_bsize" }
+ { "ulong" "f_frsize" }
+ { "fsblkcnt_t" "f_blocks" }
+ { "fsblkcnt_t" "f_bfree" }
+ { "fsblkcnt_t" "f_bavail" }
+ { "fsfilcnt_t" "f_files" }
+ { "fsfilcnt_t" "f_ffree" }
+ { "fsfilcnt_t" "f_favail" }
+ { "ulong" "f_fsid" }
+ { "ulong" "f_flag" }
+ { "ulong" "f_namemax" } ;
+
+: ST_RDONLY 1 ; inline
+: ST_NOSUID 2 ; inline
+
+FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
+
+TUPLE: openbsd-file-system-info < file-system-info
+bsize frsize blocks bfree bavail files ffree favail
+fsid flag namemax ;
+
+M: openbsd >file-system-info ( struct -- statfs )
+ [ \ openbsd-file-system-info new ] dip
+ {
+ [
+ [ statvfs-f_bsize ]
+ [ statvfs-f_bavail ] bi * >>free-space
+ ]
+ [ statvfs-f_bsize >>bsize ]
+ [ statvfs-f_frsize >>frsize ]
+ [ statvfs-f_blocks >>blocks ]
+ [ statvfs-f_bfree >>bfree ]
+ [ statvfs-f_bavail >>bavail ]
+ [ statvfs-f_files >>files ]
+ [ statvfs-f_ffree >>ffree ]
+ [ statvfs-f_favail >>favail ]
+ [ statvfs-f_fsid >>fsid ]
+ [ statvfs-f_flag >>flag ]
+ [ statvfs-f_namemax >>namemax ]
+ } cleave ;
+
+M: openbsd file-system-info ( path -- byte-array )
+ normalize-path
+ "statvfs" <c-object> tuck statvfs io-error
+ >file-system-info ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test unix.statfs ;
+IN: unix.statfs.tests
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences system vocabs.loader combinators accessors
+kernel math.order sorting ;
+IN: unix.statfs
+
+TUPLE: file-system-info root-directory total-free-size total-size ;
+
+HOOK: >file-system-info os ( struct -- statfs )
+
+HOOK: mounted os ( -- array )
+
+os {
+ { linux [ "unix.statfs.linux" require ] }
+ { macosx [ "unix.statfs.macosx" require ] }
+ { freebsd [ "unix.statfs.freebsd" require ] }
+ { netbsd [ "unix.statfs.netbsd" require ] }
+ { openbsd [ "unix.statfs.openbsd" require ] }
+} case
--- /dev/null
+unportable
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien.syntax alien.c-types math unix.types ;
+IN: unix.time
-USING: kernel alien.syntax alien.c-types math ;
+C-STRUCT: timeval
+ { "long" "sec" }
+ { "long" "usec" } ;
-IN: unix.time
+C-STRUCT: timespec
+ { "time_t" "sec" }
+ { "long" "nsec" } ;
+
+: make-timeval ( ms -- timeval )
+ 1000 /mod 1000 *
+ "timeval" <c-object>
+ [ set-timeval-usec ] keep
+ [ set-timeval-sec ] keep ;
-TYPEDEF: uint time_t
+: make-timespec ( ms -- timespec )
+ 1000 /mod 1000000 *
+ "timespec" <c-object>
+ [ set-timespec-nsec ] keep
+ [ set-timespec-sec ] keep ;
C-STRUCT: tm
{ "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
{ "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
{ "char*" "zone" } ;
-C-STRUCT: timespec
- { "time_t" "sec" }
- { "long" "nsec" } ;
-
-: make-timespec ( ms -- timespec )
- 1000 /mod 1000000 *
- "timespec" <c-object>
- [ set-timespec-nsec ] keep
- [ set-timespec-sec ] keep ;
-
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ;
-
USING: alien.syntax ;
-
IN: unix.types
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
TYPEDEF: ulonglong __uquad_type
TYPEDEF: ulong __ulongword_type
TYPEDEF: long __sword_type
TYPEDEF: uint __u32_type
TYPEDEF: int __s32_type
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
TYPEDEF: __uquad_type dev_t
TYPEDEF: __ulongword_type ino_t
+TYPEDEF: ino_t __ino_t
TYPEDEF: __u32_type mode_t
TYPEDEF: __uword_type nlink_t
TYPEDEF: __u32_type uid_t
TYPEDEF: __u32_type gid_t
TYPEDEF: __slongword_type off_t
+TYPEDEF: off_t __off_t
TYPEDEF: __slongword_type blksize_t
TYPEDEF: __slongword_type blkcnt_t
TYPEDEF: __sword_type ssize_t
TYPEDEF: __s32_type pid_t
-TYPEDEF: __slongword_type time_t
\ No newline at end of file
+TYPEDEF: __slongword_type time_t
+
+TYPEDEF: ssize_t __SWORD_TYPE
+TYPEDEF: ulonglong __fsblkcnt64_t
+TYPEDEF: ulonglong __fsfilcnt64_t
-
USING: alien.syntax ;
-
IN: unix.types
-! Darwin 9.1.0 ppc
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Darwin 9.1.0
TYPEDEF: ushort __uint16_t
TYPEDEF: uint __uint32_t
TYPEDEF: int __int32_t
TYPEDEF: longlong __int64_t
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
TYPEDEF: __int32_t dev_t
TYPEDEF: __uint32_t ino_t
TYPEDEF: __uint16_t mode_t
TYPEDEF: __uint32_t gid_t
TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __int64_t ino64_t
TYPEDEF: __int32_t blksize_t
TYPEDEF: long ssize_t
TYPEDEF: __int32_t pid_t
! NetBSD 4.0
-TYPEDEF: short __int16_t
-TYPEDEF: ushort __uint16_t
-TYPEDEF: int __int32_t
-TYPEDEF: uint __uint32_t
-TYPEDEF: longlong __int64_t
-TYPEDEF: longlong __uint64_t
-
-TYPEDEF: int int32_t
-TYPEDEF: uint uint32_t
-TYPEDEF: uint u_int32_t
-TYPEDEF: longlong int64_t
-TYPEDEF: ulonglong u_int64_t
-
TYPEDEF: __uint32_t __dev_t
TYPEDEF: __uint32_t dev_t
TYPEDEF: __uint32_t mode_t
TYPEDEF: __uint32_t nlink_t
TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t __uid_t
TYPEDEF: __uint32_t gid_t
TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t
! OpenBSD 4.2
-TYPEDEF: short __int16_t
-TYPEDEF: ushort __uint16_t
-TYPEDEF: int __int32_t
-TYPEDEF: uint __uint32_t
-TYPEDEF: longlong __int64_t
-TYPEDEF: longlong __uint64_t
-
-TYPEDEF: int int32_t
-TYPEDEF: uint u_int32_t
-TYPEDEF: uint uint32_t
-TYPEDEF: longlong int64_t
-TYPEDEF: ulonglong u_int64_t
-
TYPEDEF: __uint32_t __dev_t
TYPEDEF: __uint32_t dev_t
TYPEDEF: __uint32_t ino_t
system ;
IN: unix.types
+TYPEDEF: char int8_t
+TYPEDEF: short int16_t
+TYPEDEF: int int32_t
+TYPEDEF: longlong int64_t
+
+TYPEDEF: uchar uint8_t
+TYPEDEF: ushort uint16_t
+TYPEDEF: uint uint32_t
+TYPEDEF: ulonglong uint64_t
+
+TYPEDEF: uchar u_int8_t
+TYPEDEF: ushort u_int16_t
+TYPEDEF: uint u_int32_t
+TYPEDEF: ulonglong u_int64_t
+
+TYPEDEF: char __int8_t
+TYPEDEF: short __int16_t
+TYPEDEF: int __int32_t
+TYPEDEF: longlong __int64_t
+
+TYPEDEF: uchar __uint8_t
+TYPEDEF: ushort __uint16_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: ulonglong __uint64_t
+
TYPEDEF: void* caddr_t
+TYPEDEF: uint in_addr_t
+TYPEDEF: uint socklen_t
+
+TYPEDEF: __uint64_t fsblkcnt_t
+TYPEDEF: fsblkcnt_t __fsblkcnt_t
+TYPEDEF: __uint64_t fsfilcnt_t
+TYPEDEF: fsfilcnt_t __fsfilcnt_t
+TYPEDEF: __uint64_t rlim_t
+TYPEDEF: uint32_t id_t
os {
{ linux [ "unix.types.linux" require ] }
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax kernel libc structs
+USING: alien alien.c-types alien.syntax kernel libc
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader qualified accessors
stack-checker macros locals generalizations unix.types
debugger io prettyprint ;
IN: unix
-TYPEDEF: uint in_addr_t
-TYPEDEF: uint socklen_t
-
: PROT_NONE 0 ; inline
: PROT_READ 1 ; inline
: PROT_WRITE 2 ; inline
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( char* path ) ;
+FUNCTION: int chmod ( char* path, mode_t mode ) ;
+FUNCTION: int fchmod ( int fd, mode_t mode ) ;
FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int chroot ( char* path ) ;
FUNCTION: int close ( int fd ) ;
+FUNCTION: int closedir ( DIR* dirp ) ;
: close-file ( fd -- ) [ close ] unix-system-call drop ;
: _exit ( status -- * )
#! We throw to give this a terminating stack effect.
"int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
+FUNCTION: void endpwent ( ) ;
FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
FUNCTION: gid_t getegid ;
FUNCTION: uid_t geteuid ;
FUNCTION: gid_t getgid ;
+FUNCTION: char* getenv ( char* name ) ;
+
FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: passwd* getpwent ( ) ;
+FUNCTION: passwd* getpwuid ( uid_t uid ) ;
+FUNCTION: passwd* getpwnam ( char* login ) ;
FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ;
FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ;
+FUNCTION: int getrlimit ( int resource, rlimit* rlp ) ;
+FUNCTION: int setrlimit ( int resource, rlimit* rlp ) ;
+
+FUNCTION: int getpriority ( int which, id_t who ) ;
+FUNCTION: int setpriority ( int which, id_t who, int prio ) ;
+
+FUNCTION: int getrusage ( int who, rusage* r_usage ) ;
FUNCTION: group* getgrent ;
FUNCTION: int gethostname ( char* name, int len ) ;
FUNCTION: int open ( char* path, int flags, int prot ) ;
+FUNCTION: DIR* opendir ( char* path ) ;
+
: open-file ( path flags mode -- fd ) [ open ] unix-system-call ;
C-STRUCT: utimbuf
FUNCTION: void* popen ( char* command, char* type ) ;
FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
+FUNCTION: dirent* readdir ( DIR* dirp ) ;
+FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ;
+
FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
: PATH_MAX 1024 ; inline
FUNCTION: int rmdir ( char* path ) ;
FUNCTION: int select ( int nfds, void* readfds, void* writefds, void* exceptfds, timeval* timeout ) ;
FUNCTION: ssize_t sendto ( int s, void* buf, size_t len, int flags, sockaddr-in* to, socklen_t tolen ) ;
+FUNCTION: int setenv ( char* name, char* value, int overwrite ) ;
+FUNCTION: int unsetenv ( char* name ) ;
FUNCTION: int setegid ( gid_t egid ) ;
FUNCTION: int seteuid ( uid_t euid ) ;
FUNCTION: int setgid ( gid_t gid ) ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators accessors kernel unix unix.users
+system ;
+IN: unix.users.bsd
+
+TUPLE: bsd-passwd < passwd change class expire fields ;
+
+M: bsd new-passwd ( -- bsd-passwd ) bsd-passwd new ;
+
+M: bsd passwd>new-passwd ( passwd -- bsd-passwd )
+ [ call-next-method ] keep
+ {
+ [ passwd-pw_change >>change ]
+ [ passwd-pw_class >>class ]
+ [ passwd-pw_shell >>shell ]
+ [ passwd-pw_expire >>expire ]
+ [ passwd-pw_fields >>fields ]
+ } cleave ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string kernel quotations sequences strings math ;
+IN: unix.users
+
+HELP: all-users
+{ $values
+
+ { "seq" sequence } }
+{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
+
+HELP: effective-username
+{ $values
+
+ { "string" string } }
+{ $description "Returns the effective username for the current user." } ;
+
+HELP: effective-user-id
+{ $values
+
+ { "id" integer } }
+{ $description "Returns the effective username id for the current user." } ;
+
+HELP: new-passwd
+{ $values
+
+ { "passwd" passwd } }
+{ $description "Creates a new passwd tuple dependent on the operating system." } ;
+
+HELP: passwd
+{ $description "A platform-specific tuple correspding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } "," { $slot "expire" } ", " { $slot "fields" } "." } ;
+
+HELP: passwd-cache
+{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-passwd-cache } "." } ;
+
+HELP: passwd>new-passwd
+{ $values
+ { "passwd" "a passwd struct" }
+ { "new-passwd" "a passwd tuple" } }
+{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
+
+HELP: real-username
+{ $values
+
+ { "string" string } }
+{ $description "The real username of the current user." } ;
+
+HELP: real-user-id
+{ $values
+
+ { "id" integer } }
+{ $description "The real user id of the current user." } ;
+
+HELP: set-effective-user
+{ $values
+ { "string/id" "a string or a user id" } }
+{ $description "Sets the current effective user given a username or a user id." } ;
+
+HELP: set-real-user
+{ $values
+ { "string/id" "a string or a user id" } }
+{ $description "Sets the current real user given a username or a user id." } ;
+
+HELP: user-passwd
+{ $values
+ { "obj" object }
+ { "passwd" passwd } }
+{ $description "Returns the passwd tuple given a username string or user id." } ;
+
+HELP: username
+{ $values
+ { "id" integer }
+ { "string" string } }
+{ $description "Returns the username associated with the user id." } ;
+
+HELP: user-id
+{ $values
+ { "string" string }
+ { "id" integer } }
+{ $description "Returns the user id associated with the username." } ;
+
+HELP: with-effective-user
+{ $values
+ { "string/id" "a string or a uid" } { "quot" quotation } }
+{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
+
+HELP: with-passwd-cache
+{ $values
+ { "quot" quotation } }
+{ $description "Iterates over the password file using library calls and creates a cache in the " { $link passwd-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
+
+HELP: with-real-user
+{ $values
+ { "string/id" "a string or a uid" } { "quot" quotation } }
+{ $description "Sets the real username and calls the quotation. Restores the current username on success or on error after the call." } ;
+
+{
+ real-username real-user-id set-real-user
+ effective-username effective-user-id
+ set-effective-user
+} related-words
+
+ARTICLE: "unix.users" "unix.users"
+"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
+"Listing all users:"
+{ $subsection all-users }
+"Returning a passwd tuple:"
+"Real user:"
+{ $subsection real-username }
+{ $subsection real-user-id }
+{ $subsection set-real-user }
+"Effective user:"
+{ $subsection effective-username }
+{ $subsection effective-user-id }
+{ $subsection set-effective-user }
+"Combinators to change users:"
+{ $subsection with-real-user }
+{ $subsection with-effective-user } ;
+
+ABOUT: "unix.users"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test unix.users kernel strings math ;
+IN: unix.users.tests
+
+
+[ ] [ all-users drop ] unit-test
+
+\ all-users must-infer
+
+[ t ] [ real-username string? ] unit-test
+[ t ] [ effective-username string? ] unit-test
+
+[ t ] [ real-user-id integer? ] unit-test
+[ t ] [ effective-user-id integer? ] unit-test
+
+[ ] [ real-user-id set-real-user ] unit-test
+[ ] [ effective-user-id set-effective-user ] unit-test
+
+[ ] [ real-username [ ] with-real-user ] unit-test
+[ ] [ real-user-id [ ] with-real-user ] unit-test
+
+[ ] [ effective-username [ ] with-effective-user ] unit-test
+[ ] [ effective-user-id [ ] with-effective-user ] unit-test
--- /dev/null
+! 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 grouping byte-arrays combinators
+accessors math.parser fry assocs namespaces continuations
+vocabs.loader system ;
+IN: unix.users
+
+TUPLE: passwd username password uid gid gecos dir shell ;
+
+HOOK: new-passwd os ( -- passwd )
+HOOK: passwd>new-passwd os ( passwd -- new-passwd )
+
+<PRIVATE
+
+M: unix new-passwd ( -- passwd )
+ passwd new ;
+
+M: unix passwd>new-passwd ( passwd -- seq )
+ [ new-passwd ] dip
+ {
+ [ passwd-pw_name >>username ]
+ [ passwd-pw_passwd >>password ]
+ [ passwd-pw_uid >>uid ]
+ [ passwd-pw_gid >>gid ]
+ [ passwd-pw_gecos >>gecos ]
+ [ passwd-pw_dir >>dir ]
+ [ passwd-pw_shell >>shell ]
+ } cleave ;
+
+: with-pwent ( quot -- )
+ [ endpwent ] [ ] cleanup ; inline
+
+PRIVATE>
+
+: all-users ( -- seq )
+ [
+ [ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
+ ] with-pwent ;
+
+SYMBOL: passwd-cache
+
+: with-passwd-cache ( quot -- )
+ all-users [ [ uid>> ] keep ] H{ } map>assoc
+ passwd-cache swap with-variable ; inline
+
+GENERIC: user-passwd ( obj -- passwd )
+
+M: integer user-passwd ( id -- passwd/f )
+ passwd-cache get
+ [ at ] [ getpwuid passwd>new-passwd ] if* ;
+
+M: string user-passwd ( string -- passwd/f )
+ getpwnam dup [ passwd>new-passwd ] when ;
+
+: username ( id -- string )
+ user-passwd username>> ;
+
+: user-id ( string -- id )
+ user-passwd uid>> ;
+
+: real-user-id ( -- id )
+ getuid ; inline
+
+: real-username ( -- string )
+ real-user-id username ; inline
+
+: effective-user-id ( -- id )
+ geteuid ; inline
+
+: effective-username ( -- string )
+ effective-user-id username ; inline
+
+GENERIC: set-real-user ( string/id -- )
+
+GENERIC: set-effective-user ( string/id -- )
+
+: with-real-user ( string/id quot -- )
+ '[ _ set-real-user @ ]
+ real-user-id '[ _ set-real-user ]
+ [ ] cleanup ; inline
+
+: with-effective-user ( string/id quot -- )
+ '[ _ set-effective-user @ ]
+ effective-user-id '[ _ set-effective-user ]
+ [ ] cleanup ; inline
+
+<PRIVATE
+
+: (set-real-user) ( id -- )
+ setuid io-error ; inline
+
+: (set-effective-user) ( id -- )
+ seteuid io-error ; inline
+
+PRIVATE>
+
+M: string set-real-user ( string -- )
+ user-id (set-real-user) ;
+
+M: integer set-real-user ( id -- )
+ (set-real-user) ;
+
+M: integer set-effective-user ( id -- )
+ (set-effective-user) ;
+
+M: string set-effective-user ( string -- )
+ user-id (set-effective-user) ;
+
+os {
+ { [ dup bsd? ] [ drop "unix.users.bsd" require ] }
+ { [ dup linux? ] [ drop ] }
+} cond
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings
+combinators.short-circuit fry kernel layouts sequences ;
+IN: unix.utilities
+
+: more? ( alien -- ? )
+ { [ ] [ *void* ] } 1&& ;
+
+: advance ( void* -- void* )
+ cell swap <displaced-alien> ;
+
+: alien>strings ( alien encoding -- strings )
+ [ [ dup more? ] ] dip
+ '[ [ advance ] [ *void* _ alien>string ] bi ]
+ [ ] produce nip ;
+
+: strings>alien ( strings encoding -- alien )
+ '[ _ malloc-string ] map f suffix >c-void*-array ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test unix.utmpx.macosx ;
+IN: unix.utmpx.macosx.tests
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax unix.bsd.macosx ;
+IN: unix.utmpx.macosx
+
+! empty
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test unix.utmpx.netbsd ;
+IN: unix.utmpx.netbsd.tests
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax unix.utmpx unix.bsd.netbsd accessors
+unix.utmpx system kernel unix combinators ;
+IN: unix.utmpx.netbsd
+
+TUPLE: netbsd-utmpx-record < utmpx-record termination exit
+sockaddr ;
+
+M: netbsd new-utmpx-record ( -- utmpx-record )
+ netbsd-utmpx-record new ;
+
+M: netbsd utmpx>utmpx-record ( utmpx -- record )
+ [ new-utmpx-record ] keep
+ {
+ [
+ utmpx-ut_exit
+ [ exit_struct-e_termination >>termination ]
+ [ exit_struct-e_exit >>exit ] bi
+ ]
+ [ utmpx-ut_ss >>sockaddr ]
+ } cleave ;
--- /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 alien.syntax combinators continuations
+io.encodings.string io.encodings.utf8 kernel sequences strings
+unix calendar system accessors unix.time calendar.unix
+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
+
+FUNCTION: void setutxent ( ) ;
+FUNCTION: void endutxent ( ) ;
+FUNCTION: utmpx* getutxent ( ) ;
+FUNCTION: utmpx* getutxid ( utmpx* id ) ;
+FUNCTION: utmpx* getutxline ( utmpx* line ) ;
+FUNCTION: utmpx* pututxline ( utmpx* utx ) ;
+
+TUPLE: utmpx-record user id line pid type timestamp host ;
+
+HOOK: new-utmpx-record os ( -- utmpx-record )
+
+HOOK: utmpx>utmpx-record os ( utmpx -- utmpx-record )
+
+: memory>string ( alien n -- string )
+ memory>byte-array utf8 decode [ 0 = ] trim-right ;
+
+M: unix new-utmpx-record
+ utmpx-record new ;
+
+M: unix utmpx>utmpx-record ( utmpx -- utmpx-record )
+ [ new-utmpx-record ] dip
+ {
+ [ utmpx-ut_user _UTX_USERSIZE memory>string >>user ]
+ [ utmpx-ut_id _UTX_IDSIZE memory>string >>id ]
+ [ utmpx-ut_line _UTX_LINESIZE memory>string >>line ]
+ [ utmpx-ut_pid >>pid ]
+ [ utmpx-ut_type >>type ]
+ [ utmpx-ut_tv timeval>unix-time >>timestamp ]
+ [ utmpx-ut_host _UTX_HOSTSIZE memory>string >>host ]
+ } cleave ;
+
+: with-utmpx ( quot -- )
+ setutxent [ endutxent ] [ ] cleanup ; inline
+
+: all-utmpx ( -- seq )
+ [
+ [ getutxent dup ]
+ [ utmpx>utmpx-record ]
+ [ drop ] produce
+ ] with-utmpx ;
+
+os {
+ { macosx [ "unix.utmpx.macosx" require ] }
+ { netbsd [ "unix.utmpx.netbsd" require ] }
+} case
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
-
ALIAS: FindFirstFile FindFirstFileW
! FUNCTION: FindFirstVolumeA
! FUNCTION: FindFirstVolumeMountPointA
-! FUNCTION: FindFirstVolumeMountPointW
-! FUNCTION: FindFirstVolumeW
+
+FUNCTION: HANDLE FindFirstVolumeMountPointW (
+ LPTSTR lpszRootPathName,
+ LPTSTR lpszVolumeMountPoint,
+ DWORD cchBufferLength
+) ;
+ALIAS: FindFirstVolumeMountPoint FindFirstVolumeMountPointW
+
+FUNCTION: HANDLE FindFirstVolumeW ( LPTSTR lpszVolumeName, DWORD cchBufferLength ) ;
+ALIAS: FindFirstVolume FindFirstVolumeW
+
FUNCTION: BOOL FindNextChangeNotification ( HANDLE hChangeHandle ) ;
+
! FUNCTION: FindNextFileA
FUNCTION: BOOL FindNextFileW ( HANDLE hFindFile, LPWIN32_FIND_DATA lpFindFileData ) ;
ALIAS: FindNextFile FindNextFileW
+
! FUNCTION: FindNextVolumeA
! FUNCTION: FindNextVolumeMountPointA
-! FUNCTION: FindNextVolumeMountPointW
-! FUNCTION: FindNextVolumeW
+
+FUNCTION: BOOL FindNextVolumeMountPointW (
+ HANDLE hFindVolumeMountPoint,
+ LPTSTR lpszVolumeMountPoint,
+ DWORD cchBufferLength
+) ;
+ALIAS: FindNextVolumeMountPoint FindNextVolumeMountPointW
+
+FUNCTION: BOOL FindNextVolumeW ( HANDLE hFindVolume, LPTSTR lpszVolumeName, DWORD cchBufferLength ) ;
+ALIAS: FindNextVolume FindNextVolumeW
+
! FUNCTION: FindResourceA
! FUNCTION: FindResourceExA
! FUNCTION: FindResourceExW
! FUNCTION: FindResourceW
-! FUNCTION: FindVolumeClose
-! FUNCTION: FindVolumeMountPointClose
+FUNCTION: BOOL FindVolumeClose ( HANDLE hFindVolume ) ;
+FUNCTION: BOOL FindVolumeMountPointClose ( HANDLE hFindVolumeMountPoint ) ;
! FUNCTION: FlushConsoleInputBuffer
! FUNCTION: FlushFileBuffers
! FUNCTION: FlushInstructionCache
! FUNCTION: FormatMessageW
! FUNCTION: FreeConsole
! FUNCTION: FreeEnvironmentStringsA
-! FUNCTION: FreeEnvironmentStringsW
+FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ;
+ALIAS: FreeEnvironmentStrings FreeEnvironmentStringsW
! FUNCTION: FreeLibrary
! FUNCTION: FreeLibraryAndExitThread
! FUNCTION: FreeResource
! FUNCTION: GetDevicePowerState
! FUNCTION: GetDiskFreeSpaceA
! FUNCTION: GetDiskFreeSpaceExA
-! FUNCTION: GetDiskFreeSpaceExW
+FUNCTION: BOOL GetDiskFreeSpaceExW ( LPCTSTR lpDirectoryName, PULARGE_INTEGER pFreeBytesAvailable, PULARGE_INTEGER lpTotalNumberOfBytes, PULARGE_INTEGER lpTotalNumberOfFreeBytes ) ;
+ALIAS: GetDiskFreeSpaceEx GetDiskFreeSpaceExW
! FUNCTION: GetDiskFreeSpaceW
! FUNCTION: GetDllDirectoryA
! FUNCTION: GetDllDirectoryW
! FUNCTION: GetDriveTypeA
! FUNCTION: GetDriveTypeW
-! FUNCTION: GetEnvironmentStrings
+FUNCTION: void* GetEnvironmentStringsW ( ) ;
! FUNCTION: GetEnvironmentStringsA
-! FUNCTION: GetEnvironmentStringsW
+ALIAS: GetEnvironmentStrings GetEnvironmentStringsW
! FUNCTION: GetEnvironmentVariableA
-! FUNCTION: GetEnvironmentVariableW
+FUNCTION: DWORD GetEnvironmentVariableW ( LPCTSTR lpName, LPTSTR lpBuffer, DWORD nSize ) ;
+ALIAS: GetEnvironmentVariable GetEnvironmentVariableW
FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ;
! FUNCTION: GetExitCodeThread
! FUNCTION: GetExpandedNameA
FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ;
ALIAS: GetVersionEx GetVersionExW
! FUNCTION: GetVolumeInformationA
-! FUNCTION: GetVolumeInformationW
+FUNCTION: BOOL GetVolumeInformationW (
+ LPCTSTR lpRootPathName,
+ LPTSTR lpVolumNameBuffer,
+ DWORD nVolumeNameSize,
+ LPDWORD lpVolumeSerialNumber,
+ LPDWORD lpMaximumComponentLength,
+ LPDWORD lpFileSystemFlags,
+ LPCTSTR lpFileSystemNameBuffer,
+ DWORD nFileSystemNameSize
+) ;
+ALIAS: GetVolumeInformation GetVolumeInformationW
! FUNCTION: GetVolumeNameForVolumeMountPointA
! FUNCTION: GetVolumeNameForVolumeMountPointW
! FUNCTION: GetVolumePathNameA
! FUNCTION: SetDllDirectoryW
FUNCTION: BOOL SetEndOfFile ( HANDLE hFile ) ;
! FUNCTION: SetEnvironmentVariableA
-! FUNCTION: SetEnvironmentVariableW
+FUNCTION: BOOL SetEnvironmentVariableW ( LPCTSTR key, LPCTSTR value ) ;
+ALIAS: SetEnvironmentVariable SetEnvironmentVariableW
! FUNCTION: SetErrorMode
! FUNCTION: SetEvent
! FUNCTION: SetFileApisToANSI
TYPEDEF: uchar UCHAR
TYPEDEF: uchar BYTE
-TYPEDEF: ushort wchar_t
+TYPEDEF: ushort wchar_t
TYPEDEF: wchar_t WCHAR
TYPEDEF: short SHORT
TYPEDEF: longlong LONG64
TYPEDEF: ulonglong DWORD64
TYPEDEF: longlong LARGE_INTEGER
+TYPEDEF: ulonglong ULARGE_INTEGER
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
+TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
-TYPEDEF: WCHAR TCHAR
-TYPEDEF: TCHAR TBYTE
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
-
-
+TYPEDEF: WCHAR TCHAR
+TYPEDEF: LPWSTR LPTCH
+TYPEDEF: LPWSTR PTCH
+TYPEDEF: TCHAR TBYTE
TYPEDEF: WORD ATOM
TYPEDEF: BYTE BOOLEAN
! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
-
+! 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 structs windows math.bitwise alias ;
+windows.errors windows math.bitwise alias ;
IN: windows.winsock
USE: libc
{ "sockaddr*" "addr" }
{ "addrinfo*" "next" } ;
+C-STRUCT: timeval
+ { "long" "sec" }
+ { "long" "usec" } ;
+
: hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ;
LIBRARY: winsock
: init-winsock ( -- )
HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
-
"The Factor " { $snippet "Makefile" } " builds the Factor VM both as an executable and a library. The library can be used by other applications. File names for the library on various operating systems:"
{ $table
{ "OS" "Library name" "Shared?" }
- { "Windows XP/Vista" { $snippet "factor-nt.dll" } "Yes" }
- { "Windows CE" { $snippet "factor-ce.dll" } "Yes" }
+ { "Windows XP/Vista" { $snippet "factor.dll" } "Yes" }
+ ! { "Windows CE" { $snippet "factor-ce.dll" } "Yes" }
{ "Mac OS X" { $snippet "libfactor.dylib" } "Yes" }
{ "Other Unix" { $snippet "libfactor.a" } "No" }
}
{ "getenv" "kernel.private" }
{ "setenv" "kernel.private" }
{ "(exists?)" "io.files.private" }
- { "(directory)" "io.files.private" }
{ "gc" "memory" }
{ "gc-stats" "memory" }
{ "save-image" "memory" }
{ "exit" "system" }
{ "data-room" "memory" }
{ "code-room" "memory" }
- { "os-env" "system" }
{ "millis" "system" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
- { "(os-envs)" "system.private" }
- { "set-os-env" "system" }
- { "unset-os-env" "system" }
- { "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
[ T{ syntax-test } ] [ T{ syntax-test } ] unit-test
[ T{ syntax-test f { 2 3 } { 4 { 5 } } } ]
[ T{ syntax-test { bar { 2 3 } } { baz { 4 { 5 } } } } ] unit-test
+
+! Corner case
+TUPLE: parsing-corner-case x ;
+
+[ T{ parsing-corner-case f 3 } ] [
+ {
+ "USE: classes.tuple.parser.tests"
+ "T{ parsing-corner-case"
+ " f"
+ " 3"
+ "}"
+ } "\n" join eval
+] unit-test
: parse-tuple-literal ( -- tuple )
scan-word scan {
+ { f [ unexpected-eof ] }
{ "f" [ \ } parse-until boa>tuple ] }
{ "{" [ parse-slot-values assoc>tuple ] }
{ "}" [ new ] }
: tuple-instance? ( object class echelon -- ? )
#! 4 slot == superclasses>>
rot dup tuple? [
- layout-of 4 slot
- 2dup 1 slot fixnum<
- [ array-nth eq? ] [ 3drop f ] if
+ layout-of 4 slot { array } declare
+ 2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline
: define-tuple-predicate ( class -- )
dup dup tuple-layout echelon>>
[ tuple-instance? ] 2curry define-predicate ;
-: superclass-size ( class -- n )
- superclasses but-last [ "slots" word-prop length ] sigma ;
+: class-size ( class -- n )
+ superclasses [ "slots" word-prop length ] sigma ;
: (instance-check-quot) ( class -- quot )
[
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
-: finalize-tuple-slots ( class slots -- slots )
- swap superclass-size 2 + finalize-slots ;
+: prepare-slots ( slots superclass -- slots' )
+ [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
: define-tuple-slots ( class -- )
- dup dup "slots" word-prop finalize-tuple-slots
+ dup "slots" word-prop over superclass prepare-slots
define-accessors ;
: make-tuple-layout ( class -- layout )
[ ]
- [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
+ [ [ superclass class-size ] [ "slots" word-prop length ] bi + ]
[ superclasses dup length 1- ] tri
<tuple-layout> ;
} cleave ;
: define-new-tuple-class ( class superclass slots -- )
- make-slots
[ drop f f tuple-class define-class ]
[ nip "slots" set-word-prop ]
[ 2drop update-classes ]
: check-superclass ( superclass -- )
dup valid-superclass? [ bad-superclass ] unless drop ;
-PRIVATE>
+GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
-GENERIC# define-tuple-class 2 ( class superclass slots -- )
+PRIVATE>
-M: word define-tuple-class
+: define-tuple-class ( class superclass slots -- )
over check-superclass
+ over prepare-slots
+ (define-tuple-class) ;
+
+M: word (define-tuple-class)
define-new-tuple-class ;
-M: tuple-class define-tuple-class
- over check-superclass
+M: tuple-class (define-tuple-class)
3dup tuple-class-unchanged?
[ 3drop ] [ redefine-tuple-class ] if ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
-hashtables sorting words sets math.order ;
+hashtables sorting words sets math.order make ;
IN: combinators
! cleave
] [ drop f ] if
] [ drop f ] if ;
-: dispatch-case ( value from to default array -- )
- >r >r 3dup between? r> r> rot [
- >r 2drop - >fixnum r> dispatch
- ] [
- drop 2nip call
- ] if ; inline
-
: dispatch-case-quot ( default assoc -- quot )
- [ nip keys [ infimum ] [ supremum ] bi ] 2keep
- sort-keys values [ >quotation ] map
- [ dispatch-case ] 2curry 2curry ;
+ [
+ \ dup ,
+ dup keys [ infimum , ] [ supremum , ] bi \ between? ,
+ [
+ dup keys infimum , [ - >fixnum ] %
+ sort-keys values [ >quotation ] map ,
+ \ dispatch ,
+ ] [ ] make , , \ if ,
+ ] [ ] make ;
: case>quot ( default assoc -- quot )
dup keys {
"Home directory:"
{ $subsection home }
"Directory listing:"
-{ $subsection directory }
-{ $subsection directory* }
+{ $subsection directory-entries }
+{ $subsection directory-files }
+{ $subsection with-directory-files }
"Creating directories:"
{ $subsection make-directory }
{ $subsection make-directories }
{ $subsection link-info }
{ $subsection exists? }
{ $subsection directory? }
+
"File types:"
{ $subsection "file-types" } ;
{ $values { "file-info" file-info } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "file-info" } " is a directory." } ;
-HELP: (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 " { $link directory } " instead." } ;
+{ $notes "This is a low-level word, and user code should call one of the related words instead." } ;
-HELP: directory
-{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }
+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*
-{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ path dir? }" } " pairs" } }
-{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." }
-{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ;
+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: file-modified
-! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } }
-! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ;
+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-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" } }
HELP: pathname
{ $class-description "Class of path name objects. Path name objects can be created by calling " { $link <pathname> } "." } ;
-HELP: normalize-directory
-{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
-{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
-
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." } ;
"delete-tree-test" temp-file delete-tree
] unit-test
-[ { { "kernel" t } } ] [
+[ { "kernel" } ] [
"core" resource-path [
- "." directory [ first "kernel" = ] filter
+ "." directory-files [ "kernel" = ] filter
] with-directory
] unit-test
-[ { { "kernel" t } } ] [
+[ { "kernel" } ] [
"resource:core" [
- "." directory [ first "kernel" = ] filter
+ "." 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
"." last-split1 nip ;
! File info
-TUPLE: file-info type size permissions modified ;
+TUPLE: file-info type size permissions created modified
+accessed ;
HOOK: file-info io-backend ( path -- info )
: directory? ( file-info -- ? ) type>> +directory+ = ;
+! File-system
+
+TUPLE: file-system-info device-name mount-point type free-space ;
+
+HOOK: file-system-info os ( path -- file-system-info )
+
<PRIVATE
HOOK: cd io-backend ( path -- )
]
} cond drop ;
-! Directory listings
-: fixup-directory ( path seq -- newseq )
- [
- dup string?
- [ tuck append-path file-info directory? 2array ] [ nip ] if
- ] with map
- [ first { "." ".." } member? not ] filter ;
+TUPLE: directory-entry name type ;
+
+HOOK: >directory-entry os ( byte-array -- directory-entry )
-: directory ( path -- seq )
- normalize-directory dup (directory) fixup-directory ;
+HOOK: (directory-entries) os ( path -- seq )
-: directory* ( path -- seq )
- dup directory [ first2 >r append-path r> 2array ] with map ;
+: 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 -- )
: delete-tree ( path -- )
dup link-info type>> +directory+ = [
- dup directory over [
- [ first delete-tree ] each
- ] with-directory delete-directory
- ] [
- delete-file
- ] if ;
+ [ [ [ delete-tree ] each ] with-directory-files ]
+ [ delete-directory ]
+ bi
+ ] [ delete-file ] if ;
: to-directory ( from to -- from to' )
over file-name append-path ;
{
{ +symbolic-link+ [ copy-link ] }
{ +directory+ [
- >r dup directory r> rot [
- [ >r first r> copy-tree-into ] curry each
- ] with-directory
+ swap [
+ [ swap copy-tree-into ] with each
+ ] with-directory-files
] }
[ drop copy-file ]
} case ;
M: pathname <=> [ string>> ] compare ;
! Home directory
-HOOK: home os ( -- dir )
-
-M: winnt home "USERPROFILE" os-env ;
-
-M: wince home "" resource-path ;
+HOOK: home io-backend ( -- dir )
-M: unix home "HOME" os-env ;
+M: object home "" resource-path ;
{ $code "[ foo bar ] 2dip" }
} ;
+HELP: 3dip
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" quotation } }
+{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." }
+{ $notes "The following are equivalent:"
+ { $code ">r >r >r foo bar r> r> r>" }
+ { $code "[ foo bar ] 3dip" }
+} ;
+
HELP: while
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection dip }
{ $subsection 2dip }
+{ $subsection 3dip }
"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
{ $subsection slip }
{ $subsection 2slip }
: 2dip ( obj1 obj2 quot -- obj1 obj2 ) -rot 2slip ; inline
+: 3dip ( obj1 obj2 obj3 quot -- obj1 obj2 obj3 ) -roll 3slip ; inline
+
! Keepers
: keep ( x quot -- x ) over slip ; inline
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ;
+HELP: filter-here
+{ $values { "seq" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } }
+{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
+{ $side-effects "seq" } ;
+
HELP: monotonic?
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt elt -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
{ $description "Outputs the index of the last element in the sequence equal to " { $snippet "obj" } ", traversing the sequence backwards starting from the " { $snippet "i" } "th element and finishing at the first. If no element is found, outputs " { $link f } "." } ;
HELP: member?
-{ $values { "obj" object } { "seq" sequence } { "?" "a boolean" } }
-{ $description "Tests if the sequence contains an element equal to the object." } ;
+{ $values { "elt" object } { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests if the sequence contains an element equal to the object." }
+{ $notes "This word uses equality comparison (" { $link = } ")." } ;
HELP: memq?
-{ $values { "obj" object } { "seq" sequence } { "?" "a boolean" } }
+{ $values { "elt" object } { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if the sequence contains the object." }
-{ $examples
- "This word uses identity comparison, so the following will most likely print " { $link f } ":"
- { $example "USING: prettyprint sequences ;" "\"hello\" { \"hello\" } memq? ." "f" }
-} ;
+{ $notes "This word uses identity comparison (" { $link eq? } ")." } ;
HELP: remove
-{ $values { "obj" object } { "seq" sequence } { "newseq" "a new sequence" } }
-{ $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." } ;
+{ $values { "elt" object } { "seq" sequence } { "newseq" "a new sequence" } }
+{ $description "Outputs a new sequence containing all elements of the input sequence except for given element." }
+{ $notes "This word uses equality comparison (" { $link = } ")." } ;
+
+HELP: remq
+{ $values { "elt" object } { "seq" sequence } { "newseq" "a new sequence" } }
+{ $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." }
+{ $notes "This word uses identity comparison (" { $link eq? } ")." } ;
HELP: remove-nth
{ $values
HELP: delete
{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } "." }
+{ $notes "This word uses equality comparison (" { $link = } ")." }
+{ $side-effects "seq" } ;
+
+HELP: delq
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
+{ $description "Outputs a new sequence containing all elements of the input sequence except the given element." }
+{ $notes "This word uses identity comparison (" { $link eq? } ")." }
{ $side-effects "seq" } ;
HELP: delete-nth
{ $values { "seq" sequence } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence having the same elements as " { $snippet "seq" } " but in reverse order." } ;
-{ reverse <reversed> } related-words
+{ reverse <reversed> reverse-here } related-words
HELP: <reversed> ( seq -- reversed )
{ $values { "seq" sequence } { "reversed" "a new sequence" } }
{ $values { "seq" sequence } { "end" sequence } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " ends with " { $snippet "end" } ". If " { $snippet "end" } " is longer than " { $snippet "seq" } ", this word outputs " { $link f } "." } ;
-{ delete-nth remove delete } related-words
+{ remove remove-nth remq delq delete delete-nth } related-words
HELP: cut-slice
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before-slice" sequence } { "after-slice" "a slice" } }
}
} ;
-{ filter sift harvest } related-words
+{ filter filter-here sift harvest } related-words
HELP: set-first
{ $values
{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
+{ $subsection remq }
{ $subsection remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
{ $subsection trim-left-slice }
{ $subsection trim-right-slice } ;
+ARTICLE: "sequences-destructive-discussion" "When to use destructive operations"
+"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:"
+{ $list
+ "For the side-effect. Some code is simpler to express with destructive operations; constructive operations return new objects, and sometimes ``threading'' the objects through the program manually complicates stack shuffling."
+ { "As an optimization. Some code can be written to use constructive operations, however would suffer from worse performance. An example is a loop which adds an element to a sequence on each iteration; one could use either " { $link suffix } " or " { $link push } ", however the former copies the entire sequence first, which would cause the loop to run in quadratic time." }
+}
+"The second reason is much weaker than the first one. In particular, many combinators (see " { $link map } ", " { $link produce } " and " { $link "namespaces-make" } ") as well as more advanced data structures (such as " { $vocab-link "persistent.vectors" } ") alleviate the need for explicit use of side effects." ;
+
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
-$nl
-"In-place variant of " { $link reverse } ":"
-{ $subsection reverse-here }
-"In-place variant of " { $link append } ":"
-{ $subsection push-all }
-"In-place variant of " { $link remove } ":"
-{ $subsection delete }
-"In-place variant of " { $link map } ":"
-{ $subsection change-each }
+{ $subsection "sequences-destructive-discussion" }
"Changing elements:"
+{ $subsection change-each }
{ $subsection change-nth }
{ $subsection cache-nth }
"Deleting elements:"
+{ $subsection delete }
+{ $subsection delq }
{ $subsection delete-nth }
{ $subsection delete-slice }
{ $subsection delete-all }
+{ $subsection filter-here }
"Other destructive words:"
+{ $subsection reverse-here }
+{ $subsection push-all }
{ $subsection move }
{ $subsection exchange }
{ $subsection copy }
{ $subsection replace-slice }
+"Many operations have constructive and destructive variants:"
+{ $table
+ { "Constructive" "Destructive" }
+ { { $link suffix } { $link push } }
+ { { $link but-last } { $link pop* } }
+ { { $link unclip-last } { $link pop } }
+ { { $link remove } { $link delete } }
+ { { $link remq } { $link delq } }
+ { { $link remove-nth } { $link delete-nth } }
+ { { $link reverse } { $link reverse-here } }
+ { { $link append } { $link push-all } }
+ { { $link map } { $link change-each } }
+ { { $link filter } { $link filter-here } }
+}
{ $see-also set-nth push pop "sequences-stacks" } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
: contains? ( seq quot -- ? )
find drop >boolean ; inline
-: member? ( obj seq -- ? )
+: member? ( elt seq -- ? )
[ = ] with contains? ;
-: memq? ( obj seq -- ? )
+: memq? ( elt seq -- ? )
[ eq? ] with contains? ;
-: remove ( obj seq -- newseq )
+: remove ( elt seq -- newseq )
[ = not ] with filter ;
+: remq ( elt seq -- newseq )
+ [ eq? not ] with filter ;
+
: sift ( seq -- newseq )
[ ] filter ;
<PRIVATE
-: (delete) ( elt store scan seq -- elt store scan seq )
+: (filter-here) ( quot: ( elt -- ? ) store scan seq -- )
2dup length < [
- 3dup move
- [ nth pick = ] 2keep rot
- [ >r >r 1+ r> r> ] unless >r 1+ r> (delete)
- ] when ;
+ [ move ] 3keep
+ [ nth-unsafe pick call [ 1+ ] when ] 2keep
+ [ 1+ ] dip
+ (filter-here)
+ ] [ nip set-length drop ] if ; inline recursive
PRIVATE>
-: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
+: filter-here ( seq quot -- )
+ 0 0 roll (filter-here) ; inline
+
+: delete ( elt seq -- )
+ [ = not ] with filter-here ;
+
+: delq ( elt seq -- )
+ [ eq? not ] with filter-here ;
: prefix ( seq elt -- newseq )
over >r over length 1+ r> [
ARTICLE: "system" "System interface"
{ $subsection "cpu" }
{ $subsection "os" }
-{ $subsection "environment-variables" }
"Getting the path to the Factor VM and image:"
{ $subsection vm }
{ $subsection image }
"Exiting the Factor VM:"
{ $subsection exit } ;
-ARTICLE: "environment-variables" "Environment variables"
-"Reading environment variables:"
-{ $subsection os-env }
-{ $subsection os-envs }
-"Writing environment variables:"
-{ $subsection set-os-env }
-{ $subsection unset-os-env }
-{ $subsection set-os-envs } ;
-
ARTICLE: "cpu" "Processor detection"
"Processor detection:"
{ $subsection cpu }
{ $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." }
{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
-HELP: os-env ( key -- value )
-{ $values { "key" string } { "value" string } }
-{ $description "Looks up the value of a shell environment variable." }
-{ $examples
- "This is an operating system-specific feature. On Unix, you can do:"
- { $unchecked-example "\"USER\" os-env print" "jane" }
-}
-{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-
-HELP: os-envs
-{ $values { "assoc" "an association mapping strings to strings" } }
-{ $description "Outputs the current set of environment variables." }
-{ $notes
- "Names and values of environment variables are operating system-specific."
-}
-{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-
-HELP: set-os-envs
-{ $values { "assoc" "an association mapping strings to strings" } }
-{ $description "Replaces the current set of environment variables." }
-{ $notes
- "Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
-}
-{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-
-HELP: set-os-env ( value key -- )
-{ $values { "value" string } { "key" string } }
-{ $description "Set an environment variable." }
-{ $notes
- "Names and values of environment variables are operating system-specific."
-}
-{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-
-HELP: unset-os-env ( key -- )
-{ $values { "key" string } }
-{ $description "Unset an environment variable." }
-{ $notes
- "Names and values of environment variables are operating system-specific."
-}
-{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-
-{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
-
HELP: image
{ $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor image." } ;
+++ /dev/null
-USING: math tools.test system prettyprint namespaces kernel
-strings sequences ;
-IN: system.tests
-
-os wince? [
- [ ] [ os-envs . ] unit-test
-] unless
-
-os unix? [
- [ ] [ os-envs "envs" set ] unit-test
- [ ] [ { { "A" "B" } } set-os-envs ] unit-test
- [ "B" ] [ "A" os-env ] unit-test
- [ ] [ "envs" get set-os-envs ] unit-test
- [ t ] [ os-envs "envs" get = ] unit-test
-] when
-
-[ ] [ "factor-test-key-1" unset-os-env ] unit-test
-[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
-[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
-[ ] [ "factor-test-key-1" unset-os-env ] unit-test
-[ f ] [ "factor-test-key-1" os-env ] unit-test
-
-[ ] [
- 32766 CHAR: a <string> "factor-test-key-long" set-os-env
-] unit-test
-[ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
-[ ] [ "factor-test-key-long" unset-os-env ] unit-test
] "system" add-init-hook
: embedded? ( -- ? ) 15 getenv ;
-
-: os-envs ( -- assoc )
- (os-envs) [ "=" split1 ] H{ } map>assoc ;
-
-: set-os-envs ( assoc -- )
- [ "=" swap 3append ] { } assoc>map (set-os-envs) ;
-USING: io.sockets io kernel math threads io.encodings.ascii
-io.streams.duplex debugger tools.time prettyprint
-concurrency.count-downs namespaces arrays continuations
-destructors ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math threads io io.sockets
+io.encodings.ascii io.streams.duplex debugger tools.time
+prettyprint concurrency.count-downs concurrency.promises
+namespaces arrays continuations destructors ;
IN: benchmark.sockets
SYMBOL: counter
+SYMBOL: port-promise
+SYMBOL: server
: number-of-requests 1000 ;
-: server-addr ( -- addr ) "127.0.0.1" 7777 <inet4> ;
+: server-addr ( -- addr )
+ "127.0.0.1" port-promise get ?promise <inet4> ;
: server-loop ( server -- )
dup accept drop [
[
read1 CHAR: x = [
- "server" get dispose
+ server get dispose
] [
number-of-requests
[ read1 write1 flush ] times
: simple-server ( -- )
[
- server-addr ascii <server> dup "server" set [
- server-loop
- ] with-disposal
+ "127.0.0.1" 0 <inet4> ascii <server>
+ [ server set ]
+ [ addr>> port>> port-promise get fulfill ]
+ [ [ server-loop ] with-disposal ]
+ tri
] ignore-errors ;
: simple-client ( -- )
: clients ( n -- )
dup pprint " clients: " write [
+ <promise> port-promise set
dup 2 * <count-down> counter set
[ simple-server ] "Simple server" spawn drop
yield yield
--- /dev/null
+
+USING: kernel parser lexer locals.private ;
+
+IN: bind-in
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ->
+ "[" parse-tokens make-locals dup push-locals
+ \ ] (parse-lambda) <lambda>
+ parsed-lambda
+ \ call parsed ; parsing
\ No newline at end of file
USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
bunny.model bunny.outlined destructors kernel math opengl.demo-support
-opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ;
+opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
+ui.render words ;
IN: bunny
TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
>>draw-n relayout-1 ;
M: bunny-gadget graft* ( gadget -- )
+ dup find-gl-context
GL_DEPTH_TEST glEnable
dup model-triangles>> <bunny-geom> >>geom
dup
drop ;
M: bunny-gadget ungraft* ( gadget -- )
+ dup find-gl-context
[ geom>> [ dispose ] when* ]
[ draw-seq>> [ [ dispose ] when* ] each ] bi ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences grouping tools.test crypto.aes ;
+IN: crypto.aes.tests
+
+[ {
+ HEX: 00 HEX: 01 HEX: 02 HEX: 04 HEX: 08 HEX: 10
+ HEX: 20 HEX: 40 HEX: 80 HEX: 1b HEX: 36
+} ] [ rcon ] unit-test
+
+[ {
+ HEX: 63 HEX: 7c HEX: 77 HEX: 7b HEX: f2 HEX: 6b HEX: 6f HEX: c5
+ HEX: 30 HEX: 01 HEX: 67 HEX: 2b HEX: fe HEX: d7 HEX: ab HEX: 76
+ HEX: ca HEX: 82 HEX: c9 HEX: 7d HEX: fa HEX: 59 HEX: 47 HEX: f0
+ HEX: ad HEX: d4 HEX: a2 HEX: af HEX: 9c HEX: a4 HEX: 72 HEX: c0
+ HEX: b7 HEX: fd HEX: 93 HEX: 26 HEX: 36 HEX: 3f HEX: f7 HEX: cc
+ HEX: 34 HEX: a5 HEX: e5 HEX: f1 HEX: 71 HEX: d8 HEX: 31 HEX: 15
+ HEX: 04 HEX: c7 HEX: 23 HEX: c3 HEX: 18 HEX: 96 HEX: 05 HEX: 9a
+ HEX: 07 HEX: 12 HEX: 80 HEX: e2 HEX: eb HEX: 27 HEX: b2 HEX: 75
+ HEX: 09 HEX: 83 HEX: 2c HEX: 1a HEX: 1b HEX: 6e HEX: 5a HEX: a0
+ HEX: 52 HEX: 3b HEX: d6 HEX: b3 HEX: 29 HEX: e3 HEX: 2f HEX: 84
+ HEX: 53 HEX: d1 HEX: 00 HEX: ed HEX: 20 HEX: fc HEX: b1 HEX: 5b
+ HEX: 6a HEX: cb HEX: be HEX: 39 HEX: 4a HEX: 4c HEX: 58 HEX: cf
+ HEX: d0 HEX: ef HEX: aa HEX: fb HEX: 43 HEX: 4d HEX: 33 HEX: 85
+ HEX: 45 HEX: f9 HEX: 02 HEX: 7f HEX: 50 HEX: 3c HEX: 9f HEX: a8
+ HEX: 51 HEX: a3 HEX: 40 HEX: 8f HEX: 92 HEX: 9d HEX: 38 HEX: f5
+ HEX: bc HEX: b6 HEX: da HEX: 21 HEX: 10 HEX: ff HEX: f3 HEX: d2
+ HEX: cd HEX: 0c HEX: 13 HEX: ec HEX: 5f HEX: 97 HEX: 44 HEX: 17
+ HEX: c4 HEX: a7 HEX: 7e HEX: 3d HEX: 64 HEX: 5d HEX: 19 HEX: 73
+ HEX: 60 HEX: 81 HEX: 4f HEX: dc HEX: 22 HEX: 2a HEX: 90 HEX: 88
+ HEX: 46 HEX: ee HEX: b8 HEX: 14 HEX: de HEX: 5e HEX: 0b HEX: db
+ HEX: e0 HEX: 32 HEX: 3a HEX: 0a HEX: 49 HEX: 06 HEX: 24 HEX: 5c
+ HEX: c2 HEX: d3 HEX: ac HEX: 62 HEX: 91 HEX: 95 HEX: e4 HEX: 79
+ HEX: e7 HEX: c8 HEX: 37 HEX: 6d HEX: 8d HEX: d5 HEX: 4e HEX: a9
+ HEX: 6c HEX: 56 HEX: f4 HEX: ea HEX: 65 HEX: 7a HEX: ae HEX: 08
+ HEX: ba HEX: 78 HEX: 25 HEX: 2e HEX: 1c HEX: a6 HEX: b4 HEX: c6
+ HEX: e8 HEX: dd HEX: 74 HEX: 1f HEX: 4b HEX: bd HEX: 8b HEX: 8a
+ HEX: 70 HEX: 3e HEX: b5 HEX: 66 HEX: 48 HEX: 03 HEX: f6 HEX: 0e
+ HEX: 61 HEX: 35 HEX: 57 HEX: b9 HEX: 86 HEX: c1 HEX: 1d HEX: 9e
+ HEX: e1 HEX: f8 HEX: 98 HEX: 11 HEX: 69 HEX: d9 HEX: 8e HEX: 94
+ HEX: 9b HEX: 1e HEX: 87 HEX: e9 HEX: ce HEX: 55 HEX: 28 HEX: df
+ HEX: 8c HEX: a1 HEX: 89 HEX: 0d HEX: bf HEX: e6 HEX: 42 HEX: 68
+ HEX: 41 HEX: 99 HEX: 2d HEX: 0f HEX: b0 HEX: 54 HEX: bb HEX: 16
+} ] [ sbox ] unit-test
+
+[
+{
+ HEX: 52 HEX: 09 HEX: 6a HEX: d5 HEX: 30 HEX: 36 HEX: a5 HEX: 38
+ HEX: bf HEX: 40 HEX: a3 HEX: 9e HEX: 81 HEX: f3 HEX: d7 HEX: fb
+ HEX: 7c HEX: e3 HEX: 39 HEX: 82 HEX: 9b HEX: 2f HEX: ff HEX: 87
+ HEX: 34 HEX: 8e HEX: 43 HEX: 44 HEX: c4 HEX: de HEX: e9 HEX: cb
+ HEX: 54 HEX: 7b HEX: 94 HEX: 32 HEX: a6 HEX: c2 HEX: 23 HEX: 3d
+ HEX: ee HEX: 4c HEX: 95 HEX: 0b HEX: 42 HEX: fa HEX: c3 HEX: 4e
+ HEX: 08 HEX: 2e HEX: a1 HEX: 66 HEX: 28 HEX: d9 HEX: 24 HEX: b2
+ HEX: 76 HEX: 5b HEX: a2 HEX: 49 HEX: 6d HEX: 8b HEX: d1 HEX: 25
+ HEX: 72 HEX: f8 HEX: f6 HEX: 64 HEX: 86 HEX: 68 HEX: 98 HEX: 16
+ HEX: d4 HEX: a4 HEX: 5c HEX: cc HEX: 5d HEX: 65 HEX: b6 HEX: 92
+ HEX: 6c HEX: 70 HEX: 48 HEX: 50 HEX: fd HEX: ed HEX: b9 HEX: da
+ HEX: 5e HEX: 15 HEX: 46 HEX: 57 HEX: a7 HEX: 8d HEX: 9d HEX: 84
+ HEX: 90 HEX: d8 HEX: ab HEX: 00 HEX: 8c HEX: bc HEX: d3 HEX: 0a
+ HEX: f7 HEX: e4 HEX: 58 HEX: 05 HEX: b8 HEX: b3 HEX: 45 HEX: 06
+ HEX: d0 HEX: 2c HEX: 1e HEX: 8f HEX: ca HEX: 3f HEX: 0f HEX: 02
+ HEX: c1 HEX: af HEX: bd HEX: 03 HEX: 01 HEX: 13 HEX: 8a HEX: 6b
+ HEX: 3a HEX: 91 HEX: 11 HEX: 41 HEX: 4f HEX: 67 HEX: dc HEX: ea
+ HEX: 97 HEX: f2 HEX: cf HEX: ce HEX: f0 HEX: b4 HEX: e6 HEX: 73
+ HEX: 96 HEX: ac HEX: 74 HEX: 22 HEX: e7 HEX: ad HEX: 35 HEX: 85
+ HEX: e2 HEX: f9 HEX: 37 HEX: e8 HEX: 1c HEX: 75 HEX: df HEX: 6e
+ HEX: 47 HEX: f1 HEX: 1a HEX: 71 HEX: 1d HEX: 29 HEX: c5 HEX: 89
+ HEX: 6f HEX: b7 HEX: 62 HEX: 0e HEX: aa HEX: 18 HEX: be HEX: 1b
+ HEX: fc HEX: 56 HEX: 3e HEX: 4b HEX: c6 HEX: d2 HEX: 79 HEX: 20
+ HEX: 9a HEX: db HEX: c0 HEX: fe HEX: 78 HEX: cd HEX: 5a HEX: f4
+ HEX: 1f HEX: dd HEX: a8 HEX: 33 HEX: 88 HEX: 07 HEX: c7 HEX: 31
+ HEX: b1 HEX: 12 HEX: 10 HEX: 59 HEX: 27 HEX: 80 HEX: ec HEX: 5f
+ HEX: 60 HEX: 51 HEX: 7f HEX: a9 HEX: 19 HEX: b5 HEX: 4a HEX: 0d
+ HEX: 2d HEX: e5 HEX: 7a HEX: 9f HEX: 93 HEX: c9 HEX: 9c HEX: ef
+ HEX: a0 HEX: e0 HEX: 3b HEX: 4d HEX: ae HEX: 2a HEX: f5 HEX: b0
+ HEX: c8 HEX: eb HEX: bb HEX: 3c HEX: 83 HEX: 53 HEX: 99 HEX: 61
+ HEX: 17 HEX: 2b HEX: 04 HEX: 7e HEX: ba HEX: 77 HEX: d6 HEX: 26
+ HEX: e1 HEX: 69 HEX: 14 HEX: 63 HEX: 55 HEX: 21 HEX: 0c HEX: 7d
+}
+] [ inv-sbox ] unit-test
+
+[ {
+ HEX: 50a7f451 HEX: 5365417e HEX: c3a4171a HEX: 965e273a HEX: cb6bab3b HEX: f1459d1f HEX: ab58faac HEX: 9303e34b
+ HEX: 55fa3020 HEX: f66d76ad HEX: 9176cc88 HEX: 254c02f5 HEX: fcd7e54f HEX: d7cb2ac5 HEX: 80443526 HEX: 8fa362b5
+ HEX: 495ab1de HEX: 671bba25 HEX: 980eea45 HEX: e1c0fe5d HEX: 02752fc3 HEX: 12f04c81 HEX: a397468d HEX: c6f9d36b
+ HEX: e75f8f03 HEX: 959c9215 HEX: eb7a6dbf HEX: da595295 HEX: 2d83bed4 HEX: d3217458 HEX: 2969e049 HEX: 44c8c98e
+ HEX: 6a89c275 HEX: 78798ef4 HEX: 6b3e5899 HEX: dd71b927 HEX: b64fe1be HEX: 17ad88f0 HEX: 66ac20c9 HEX: b43ace7d
+ HEX: 184adf63 HEX: 82311ae5 HEX: 60335197 HEX: 457f5362 HEX: e07764b1 HEX: 84ae6bbb HEX: 1ca081fe HEX: 942b08f9
+ HEX: 58684870 HEX: 19fd458f HEX: 876cde94 HEX: b7f87b52 HEX: 23d373ab HEX: e2024b72 HEX: 578f1fe3 HEX: 2aab5566
+ HEX: 0728ebb2 HEX: 03c2b52f HEX: 9a7bc586 HEX: a50837d3 HEX: f2872830 HEX: b2a5bf23 HEX: ba6a0302 HEX: 5c8216ed
+ HEX: 2b1ccf8a HEX: 92b479a7 HEX: f0f207f3 HEX: a1e2694e HEX: cdf4da65 HEX: d5be0506 HEX: 1f6234d1 HEX: 8afea6c4
+ HEX: 9d532e34 HEX: a055f3a2 HEX: 32e18a05 HEX: 75ebf6a4 HEX: 39ec830b HEX: aaef6040 HEX: 069f715e HEX: 51106ebd
+ HEX: f98a213e HEX: 3d06dd96 HEX: ae053edd HEX: 46bde64d HEX: b58d5491 HEX: 055dc471 HEX: 6fd40604 HEX: ff155060
+ HEX: 24fb9819 HEX: 97e9bdd6 HEX: cc434089 HEX: 779ed967 HEX: bd42e8b0 HEX: 888b8907 HEX: 385b19e7 HEX: dbeec879
+ HEX: 470a7ca1 HEX: e90f427c HEX: c91e84f8 HEX: 00000000 HEX: 83868009 HEX: 48ed2b32 HEX: ac70111e HEX: 4e725a6c
+ HEX: fbff0efd HEX: 5638850f HEX: 1ed5ae3d HEX: 27392d36 HEX: 64d90f0a HEX: 21a65c68 HEX: d1545b9b HEX: 3a2e3624
+ HEX: b1670a0c HEX: 0fe75793 HEX: d296eeb4 HEX: 9e919b1b HEX: 4fc5c080 HEX: a220dc61 HEX: 694b775a HEX: 161a121c
+ HEX: 0aba93e2 HEX: e52aa0c0 HEX: 43e0223c HEX: 1d171b12 HEX: 0b0d090e HEX: adc78bf2 HEX: b9a8b62d HEX: c8a91e14
+ HEX: 8519f157 HEX: 4c0775af HEX: bbdd99ee HEX: fd607fa3 HEX: 9f2601f7 HEX: bcf5725c HEX: c53b6644 HEX: 347efb5b
+ HEX: 7629438b HEX: dcc623cb HEX: 68fcedb6 HEX: 63f1e4b8 HEX: cadc31d7 HEX: 10856342 HEX: 40229713 HEX: 2011c684
+ HEX: 7d244a85 HEX: f83dbbd2 HEX: 1132f9ae HEX: 6da129c7 HEX: 4b2f9e1d HEX: f330b2dc HEX: ec52860d HEX: d0e3c177
+ HEX: 6c16b32b HEX: 99b970a9 HEX: fa489411 HEX: 2264e947 HEX: c48cfca8 HEX: 1a3ff0a0 HEX: d82c7d56 HEX: ef903322
+ HEX: c74e4987 HEX: c1d138d9 HEX: fea2ca8c HEX: 360bd498 HEX: cf81f5a6 HEX: 28de7aa5 HEX: 268eb7da HEX: a4bfad3f
+ HEX: e49d3a2c HEX: 0d927850 HEX: 9bcc5f6a HEX: 62467e54 HEX: c2138df6 HEX: e8b8d890 HEX: 5ef7392e HEX: f5afc382
+ HEX: be805d9f HEX: 7c93d069 HEX: a92dd56f HEX: b31225cf HEX: 3b99acc8 HEX: a77d1810 HEX: 6e639ce8 HEX: 7bbb3bdb
+ HEX: 097826cd HEX: f418596e HEX: 01b79aec HEX: a89a4f83 HEX: 656e95e6 HEX: 7ee6ffaa HEX: 08cfbc21 HEX: e6e815ef
+ HEX: d99be7ba HEX: ce366f4a HEX: d4099fea HEX: d67cb029 HEX: afb2a431 HEX: 31233f2a HEX: 3094a5c6 HEX: c066a235
+ HEX: 37bc4e74 HEX: a6ca82fc HEX: b0d090e0 HEX: 15d8a733 HEX: 4a9804f1 HEX: f7daec41 HEX: 0e50cd7f HEX: 2ff69117
+ HEX: 8dd64d76 HEX: 4db0ef43 HEX: 544daacc HEX: df0496e4 HEX: e3b5d19e HEX: 1b886a4c HEX: b81f2cc1 HEX: 7f516546
+ HEX: 04ea5e9d HEX: 5d358c01 HEX: 737487fa HEX: 2e410bfb HEX: 5a1d67b3 HEX: 52d2db92 HEX: 335610e9 HEX: 1347d66d
+ HEX: 8c61d79a HEX: 7a0ca137 HEX: 8e14f859 HEX: 893c13eb HEX: ee27a9ce HEX: 35c961b7 HEX: ede51ce1 HEX: 3cb1477a
+ HEX: 59dfd29c HEX: 3f73f255 HEX: 79ce1418 HEX: bf37c773 HEX: eacdf753 HEX: 5baafd5f HEX: 146f3ddf HEX: 86db4478
+ HEX: 81f3afca HEX: 3ec468b9 HEX: 2c342438 HEX: 5f40a3c2 HEX: 72c31d16 HEX: 0c25e2bc HEX: 8b493c28 HEX: 41950dff
+ HEX: 7101a839 HEX: deb30c08 HEX: 9ce4b4d8 HEX: 90c15664 HEX: 6184cb7b HEX: 70b632d5 HEX: 745c6c48 HEX: 4257b8d0
+ HEX: a7f45150 HEX: 65417e53 HEX: a4171ac3 HEX: 5e273a96 HEX: 6bab3bcb HEX: 459d1ff1 HEX: 58faacab HEX: 03e34b93
+ HEX: fa302055 HEX: 6d76adf6 HEX: 76cc8891 HEX: 4c02f525 HEX: d7e54ffc HEX: cb2ac5d7 HEX: 44352680 HEX: a362b58f
+ HEX: 5ab1de49 HEX: 1bba2567 HEX: 0eea4598 HEX: c0fe5de1 HEX: 752fc302 HEX: f04c8112 HEX: 97468da3 HEX: f9d36bc6
+ HEX: 5f8f03e7 HEX: 9c921595 HEX: 7a6dbfeb HEX: 595295da HEX: 83bed42d HEX: 217458d3 HEX: 69e04929 HEX: c8c98e44
+ HEX: 89c2756a HEX: 798ef478 HEX: 3e58996b HEX: 71b927dd HEX: 4fe1beb6 HEX: ad88f017 HEX: ac20c966 HEX: 3ace7db4
+ HEX: 4adf6318 HEX: 311ae582 HEX: 33519760 HEX: 7f536245 HEX: 7764b1e0 HEX: ae6bbb84 HEX: a081fe1c HEX: 2b08f994
+ HEX: 68487058 HEX: fd458f19 HEX: 6cde9487 HEX: f87b52b7 HEX: d373ab23 HEX: 024b72e2 HEX: 8f1fe357 HEX: ab55662a
+ HEX: 28ebb207 HEX: c2b52f03 HEX: 7bc5869a HEX: 0837d3a5 HEX: 872830f2 HEX: a5bf23b2 HEX: 6a0302ba HEX: 8216ed5c
+ HEX: 1ccf8a2b HEX: b479a792 HEX: f207f3f0 HEX: e2694ea1 HEX: f4da65cd HEX: be0506d5 HEX: 6234d11f HEX: fea6c48a
+ HEX: 532e349d HEX: 55f3a2a0 HEX: e18a0532 HEX: ebf6a475 HEX: ec830b39 HEX: ef6040aa HEX: 9f715e06 HEX: 106ebd51
+ HEX: 8a213ef9 HEX: 06dd963d HEX: 053eddae HEX: bde64d46 HEX: 8d5491b5 HEX: 5dc47105 HEX: d406046f HEX: 155060ff
+ HEX: fb981924 HEX: e9bdd697 HEX: 434089cc HEX: 9ed96777 HEX: 42e8b0bd HEX: 8b890788 HEX: 5b19e738 HEX: eec879db
+ HEX: 0a7ca147 HEX: 0f427ce9 HEX: 1e84f8c9 HEX: 00000000 HEX: 86800983 HEX: ed2b3248 HEX: 70111eac HEX: 725a6c4e
+ HEX: ff0efdfb HEX: 38850f56 HEX: d5ae3d1e HEX: 392d3627 HEX: d90f0a64 HEX: a65c6821 HEX: 545b9bd1 HEX: 2e36243a
+ HEX: 670a0cb1 HEX: e757930f HEX: 96eeb4d2 HEX: 919b1b9e HEX: c5c0804f HEX: 20dc61a2 HEX: 4b775a69 HEX: 1a121c16
+ HEX: ba93e20a HEX: 2aa0c0e5 HEX: e0223c43 HEX: 171b121d HEX: 0d090e0b HEX: c78bf2ad HEX: a8b62db9 HEX: a91e14c8
+ HEX: 19f15785 HEX: 0775af4c HEX: dd99eebb HEX: 607fa3fd HEX: 2601f79f HEX: f5725cbc HEX: 3b6644c5 HEX: 7efb5b34
+ HEX: 29438b76 HEX: c623cbdc HEX: fcedb668 HEX: f1e4b863 HEX: dc31d7ca HEX: 85634210 HEX: 22971340 HEX: 11c68420
+ HEX: 244a857d HEX: 3dbbd2f8 HEX: 32f9ae11 HEX: a129c76d HEX: 2f9e1d4b HEX: 30b2dcf3 HEX: 52860dec HEX: e3c177d0
+ HEX: 16b32b6c HEX: b970a999 HEX: 489411fa HEX: 64e94722 HEX: 8cfca8c4 HEX: 3ff0a01a HEX: 2c7d56d8 HEX: 903322ef
+ HEX: 4e4987c7 HEX: d138d9c1 HEX: a2ca8cfe HEX: 0bd49836 HEX: 81f5a6cf HEX: de7aa528 HEX: 8eb7da26 HEX: bfad3fa4
+ HEX: 9d3a2ce4 HEX: 9278500d HEX: cc5f6a9b HEX: 467e5462 HEX: 138df6c2 HEX: b8d890e8 HEX: f7392e5e HEX: afc382f5
+ HEX: 805d9fbe HEX: 93d0697c HEX: 2dd56fa9 HEX: 1225cfb3 HEX: 99acc83b HEX: 7d1810a7 HEX: 639ce86e HEX: bb3bdb7b
+ HEX: 7826cd09 HEX: 18596ef4 HEX: b79aec01 HEX: 9a4f83a8 HEX: 6e95e665 HEX: e6ffaa7e HEX: cfbc2108 HEX: e815efe6
+ HEX: 9be7bad9 HEX: 366f4ace HEX: 099fead4 HEX: 7cb029d6 HEX: b2a431af HEX: 233f2a31 HEX: 94a5c630 HEX: 66a235c0
+ HEX: bc4e7437 HEX: ca82fca6 HEX: d090e0b0 HEX: d8a73315 HEX: 9804f14a HEX: daec41f7 HEX: 50cd7f0e HEX: f691172f
+ HEX: d64d768d HEX: b0ef434d HEX: 4daacc54 HEX: 0496e4df HEX: b5d19ee3 HEX: 886a4c1b HEX: 1f2cc1b8 HEX: 5165467f
+ HEX: ea5e9d04 HEX: 358c015d HEX: 7487fa73 HEX: 410bfb2e HEX: 1d67b35a HEX: d2db9252 HEX: 5610e933 HEX: 47d66d13
+ HEX: 61d79a8c HEX: 0ca1377a HEX: 14f8598e HEX: 3c13eb89 HEX: 27a9ceee HEX: c961b735 HEX: e51ce1ed HEX: b1477a3c
+ HEX: dfd29c59 HEX: 73f2553f HEX: ce141879 HEX: 37c773bf HEX: cdf753ea HEX: aafd5f5b HEX: 6f3ddf14 HEX: db447886
+ HEX: f3afca81 HEX: c468b93e HEX: 3424382c HEX: 40a3c25f HEX: c31d1672 HEX: 25e2bc0c HEX: 493c288b HEX: 950dff41
+ HEX: 01a83971 HEX: b30c08de HEX: e4b4d89c HEX: c1566490 HEX: 84cb7b61 HEX: b632d570 HEX: 5c6c4874 HEX: 57b8d042
+ HEX: f45150a7 HEX: 417e5365 HEX: 171ac3a4 HEX: 273a965e HEX: ab3bcb6b HEX: 9d1ff145 HEX: faacab58 HEX: e34b9303
+ HEX: 302055fa HEX: 76adf66d HEX: cc889176 HEX: 02f5254c HEX: e54ffcd7 HEX: 2ac5d7cb HEX: 35268044 HEX: 62b58fa3
+ HEX: b1de495a HEX: ba25671b HEX: ea45980e HEX: fe5de1c0 HEX: 2fc30275 HEX: 4c8112f0 HEX: 468da397 HEX: d36bc6f9
+ HEX: 8f03e75f HEX: 9215959c HEX: 6dbfeb7a HEX: 5295da59 HEX: bed42d83 HEX: 7458d321 HEX: e0492969 HEX: c98e44c8
+ HEX: c2756a89 HEX: 8ef47879 HEX: 58996b3e HEX: b927dd71 HEX: e1beb64f HEX: 88f017ad HEX: 20c966ac HEX: ce7db43a
+ HEX: df63184a HEX: 1ae58231 HEX: 51976033 HEX: 5362457f HEX: 64b1e077 HEX: 6bbb84ae HEX: 81fe1ca0 HEX: 08f9942b
+ HEX: 48705868 HEX: 458f19fd HEX: de94876c HEX: 7b52b7f8 HEX: 73ab23d3 HEX: 4b72e202 HEX: 1fe3578f HEX: 55662aab
+ HEX: ebb20728 HEX: b52f03c2 HEX: c5869a7b HEX: 37d3a508 HEX: 2830f287 HEX: bf23b2a5 HEX: 0302ba6a HEX: 16ed5c82
+ HEX: cf8a2b1c HEX: 79a792b4 HEX: 07f3f0f2 HEX: 694ea1e2 HEX: da65cdf4 HEX: 0506d5be HEX: 34d11f62 HEX: a6c48afe
+ HEX: 2e349d53 HEX: f3a2a055 HEX: 8a0532e1 HEX: f6a475eb HEX: 830b39ec HEX: 6040aaef HEX: 715e069f HEX: 6ebd5110
+ HEX: 213ef98a HEX: dd963d06 HEX: 3eddae05 HEX: e64d46bd HEX: 5491b58d HEX: c471055d HEX: 06046fd4 HEX: 5060ff15
+ HEX: 981924fb HEX: bdd697e9 HEX: 4089cc43 HEX: d967779e HEX: e8b0bd42 HEX: 8907888b HEX: 19e7385b HEX: c879dbee
+ HEX: 7ca1470a HEX: 427ce90f HEX: 84f8c91e HEX: 00000000 HEX: 80098386 HEX: 2b3248ed HEX: 111eac70 HEX: 5a6c4e72
+ HEX: 0efdfbff HEX: 850f5638 HEX: ae3d1ed5 HEX: 2d362739 HEX: 0f0a64d9 HEX: 5c6821a6 HEX: 5b9bd154 HEX: 36243a2e
+ HEX: 0a0cb167 HEX: 57930fe7 HEX: eeb4d296 HEX: 9b1b9e91 HEX: c0804fc5 HEX: dc61a220 HEX: 775a694b HEX: 121c161a
+ HEX: 93e20aba HEX: a0c0e52a HEX: 223c43e0 HEX: 1b121d17 HEX: 090e0b0d HEX: 8bf2adc7 HEX: b62db9a8 HEX: 1e14c8a9
+ HEX: f1578519 HEX: 75af4c07 HEX: 99eebbdd HEX: 7fa3fd60 HEX: 01f79f26 HEX: 725cbcf5 HEX: 6644c53b HEX: fb5b347e
+ HEX: 438b7629 HEX: 23cbdcc6 HEX: edb668fc HEX: e4b863f1 HEX: 31d7cadc HEX: 63421085 HEX: 97134022 HEX: c6842011
+ HEX: 4a857d24 HEX: bbd2f83d HEX: f9ae1132 HEX: 29c76da1 HEX: 9e1d4b2f HEX: b2dcf330 HEX: 860dec52 HEX: c177d0e3
+ HEX: b32b6c16 HEX: 70a999b9 HEX: 9411fa48 HEX: e9472264 HEX: fca8c48c HEX: f0a01a3f HEX: 7d56d82c HEX: 3322ef90
+ HEX: 4987c74e HEX: 38d9c1d1 HEX: ca8cfea2 HEX: d498360b HEX: f5a6cf81 HEX: 7aa528de HEX: b7da268e HEX: ad3fa4bf
+ HEX: 3a2ce49d HEX: 78500d92 HEX: 5f6a9bcc HEX: 7e546246 HEX: 8df6c213 HEX: d890e8b8 HEX: 392e5ef7 HEX: c382f5af
+ HEX: 5d9fbe80 HEX: d0697c93 HEX: d56fa92d HEX: 25cfb312 HEX: acc83b99 HEX: 1810a77d HEX: 9ce86e63 HEX: 3bdb7bbb
+ HEX: 26cd0978 HEX: 596ef418 HEX: 9aec01b7 HEX: 4f83a89a HEX: 95e6656e HEX: ffaa7ee6 HEX: bc2108cf HEX: 15efe6e8
+ HEX: e7bad99b HEX: 6f4ace36 HEX: 9fead409 HEX: b029d67c HEX: a431afb2 HEX: 3f2a3123 HEX: a5c63094 HEX: a235c066
+ HEX: 4e7437bc HEX: 82fca6ca HEX: 90e0b0d0 HEX: a73315d8 HEX: 04f14a98 HEX: ec41f7da HEX: cd7f0e50 HEX: 91172ff6
+ HEX: 4d768dd6 HEX: ef434db0 HEX: aacc544d HEX: 96e4df04 HEX: d19ee3b5 HEX: 6a4c1b88 HEX: 2cc1b81f HEX: 65467f51
+ HEX: 5e9d04ea HEX: 8c015d35 HEX: 87fa7374 HEX: 0bfb2e41 HEX: 67b35a1d HEX: db9252d2 HEX: 10e93356 HEX: d66d1347
+ HEX: d79a8c61 HEX: a1377a0c HEX: f8598e14 HEX: 13eb893c HEX: a9ceee27 HEX: 61b735c9 HEX: 1ce1ede5 HEX: 477a3cb1
+ HEX: d29c59df HEX: f2553f73 HEX: 141879ce HEX: c773bf37 HEX: f753eacd HEX: fd5f5baa HEX: 3ddf146f HEX: 447886db
+ HEX: afca81f3 HEX: 68b93ec4 HEX: 24382c34 HEX: a3c25f40 HEX: 1d1672c3 HEX: e2bc0c25 HEX: 3c288b49 HEX: 0dff4195
+ HEX: a8397101 HEX: 0c08deb3 HEX: b4d89ce4 HEX: 566490c1 HEX: cb7b6184 HEX: 32d570b6 HEX: 6c48745c HEX: b8d04257
+ HEX: 5150a7f4 HEX: 7e536541 HEX: 1ac3a417 HEX: 3a965e27 HEX: 3bcb6bab HEX: 1ff1459d HEX: acab58fa HEX: 4b9303e3
+ HEX: 2055fa30 HEX: adf66d76 HEX: 889176cc HEX: f5254c02 HEX: 4ffcd7e5 HEX: c5d7cb2a HEX: 26804435 HEX: b58fa362
+ HEX: de495ab1 HEX: 25671bba HEX: 45980eea HEX: 5de1c0fe HEX: c302752f HEX: 8112f04c HEX: 8da39746 HEX: 6bc6f9d3
+ HEX: 03e75f8f HEX: 15959c92 HEX: bfeb7a6d HEX: 95da5952 HEX: d42d83be HEX: 58d32174 HEX: 492969e0 HEX: 8e44c8c9
+ HEX: 756a89c2 HEX: f478798e HEX: 996b3e58 HEX: 27dd71b9 HEX: beb64fe1 HEX: f017ad88 HEX: c966ac20 HEX: 7db43ace
+ HEX: 63184adf HEX: e582311a HEX: 97603351 HEX: 62457f53 HEX: b1e07764 HEX: bb84ae6b HEX: fe1ca081 HEX: f9942b08
+ HEX: 70586848 HEX: 8f19fd45 HEX: 94876cde HEX: 52b7f87b HEX: ab23d373 HEX: 72e2024b HEX: e3578f1f HEX: 662aab55
+ HEX: b20728eb HEX: 2f03c2b5 HEX: 869a7bc5 HEX: d3a50837 HEX: 30f28728 HEX: 23b2a5bf HEX: 02ba6a03 HEX: ed5c8216
+ HEX: 8a2b1ccf HEX: a792b479 HEX: f3f0f207 HEX: 4ea1e269 HEX: 65cdf4da HEX: 06d5be05 HEX: d11f6234 HEX: c48afea6
+ HEX: 349d532e HEX: a2a055f3 HEX: 0532e18a HEX: a475ebf6 HEX: 0b39ec83 HEX: 40aaef60 HEX: 5e069f71 HEX: bd51106e
+ HEX: 3ef98a21 HEX: 963d06dd HEX: ddae053e HEX: 4d46bde6 HEX: 91b58d54 HEX: 71055dc4 HEX: 046fd406 HEX: 60ff1550
+ HEX: 1924fb98 HEX: d697e9bd HEX: 89cc4340 HEX: 67779ed9 HEX: b0bd42e8 HEX: 07888b89 HEX: e7385b19 HEX: 79dbeec8
+ HEX: a1470a7c HEX: 7ce90f42 HEX: f8c91e84 HEX: 00000000 HEX: 09838680 HEX: 3248ed2b HEX: 1eac7011 HEX: 6c4e725a
+ HEX: fdfbff0e HEX: 0f563885 HEX: 3d1ed5ae HEX: 3627392d HEX: 0a64d90f HEX: 6821a65c HEX: 9bd1545b HEX: 243a2e36
+ HEX: 0cb1670a HEX: 930fe757 HEX: b4d296ee HEX: 1b9e919b HEX: 804fc5c0 HEX: 61a220dc HEX: 5a694b77 HEX: 1c161a12
+ HEX: e20aba93 HEX: c0e52aa0 HEX: 3c43e022 HEX: 121d171b HEX: 0e0b0d09 HEX: f2adc78b HEX: 2db9a8b6 HEX: 14c8a91e
+ HEX: 578519f1 HEX: af4c0775 HEX: eebbdd99 HEX: a3fd607f HEX: f79f2601 HEX: 5cbcf572 HEX: 44c53b66 HEX: 5b347efb
+ HEX: 8b762943 HEX: cbdcc623 HEX: b668fced HEX: b863f1e4 HEX: d7cadc31 HEX: 42108563 HEX: 13402297 HEX: 842011c6
+ HEX: 857d244a HEX: d2f83dbb HEX: ae1132f9 HEX: c76da129 HEX: 1d4b2f9e HEX: dcf330b2 HEX: 0dec5286 HEX: 77d0e3c1
+ HEX: 2b6c16b3 HEX: a999b970 HEX: 11fa4894 HEX: 472264e9 HEX: a8c48cfc HEX: a01a3ff0 HEX: 56d82c7d HEX: 22ef9033
+ HEX: 87c74e49 HEX: d9c1d138 HEX: 8cfea2ca HEX: 98360bd4 HEX: a6cf81f5 HEX: a528de7a HEX: da268eb7 HEX: 3fa4bfad
+ HEX: 2ce49d3a HEX: 500d9278 HEX: 6a9bcc5f HEX: 5462467e HEX: f6c2138d HEX: 90e8b8d8 HEX: 2e5ef739 HEX: 82f5afc3
+ HEX: 9fbe805d HEX: 697c93d0 HEX: 6fa92dd5 HEX: cfb31225 HEX: c83b99ac HEX: 10a77d18 HEX: e86e639c HEX: db7bbb3b
+ HEX: cd097826 HEX: 6ef41859 HEX: ec01b79a HEX: 83a89a4f HEX: e6656e95 HEX: aa7ee6ff HEX: 2108cfbc HEX: efe6e815
+ HEX: bad99be7 HEX: 4ace366f HEX: ead4099f HEX: 29d67cb0 HEX: 31afb2a4 HEX: 2a31233f HEX: c63094a5 HEX: 35c066a2
+ HEX: 7437bc4e HEX: fca6ca82 HEX: e0b0d090 HEX: 3315d8a7 HEX: f14a9804 HEX: 41f7daec HEX: 7f0e50cd HEX: 172ff691
+ HEX: 768dd64d HEX: 434db0ef HEX: cc544daa HEX: e4df0496 HEX: 9ee3b5d1 HEX: 4c1b886a HEX: c1b81f2c HEX: 467f5165
+ HEX: 9d04ea5e HEX: 015d358c HEX: fa737487 HEX: fb2e410b HEX: b35a1d67 HEX: 9252d2db HEX: e9335610 HEX: 6d1347d6
+ HEX: 9a8c61d7 HEX: 377a0ca1 HEX: 598e14f8 HEX: eb893c13 HEX: ceee27a9 HEX: b735c961 HEX: e1ede51c HEX: 7a3cb147
+ HEX: 9c59dfd2 HEX: 553f73f2 HEX: 1879ce14 HEX: 73bf37c7 HEX: 53eacdf7 HEX: 5f5baafd HEX: df146f3d HEX: 7886db44
+ HEX: ca81f3af HEX: b93ec468 HEX: 382c3424 HEX: c25f40a3 HEX: 1672c31d HEX: bc0c25e2 HEX: 288b493c HEX: ff41950d
+ HEX: 397101a8 HEX: 08deb30c HEX: d89ce4b4 HEX: 6490c156 HEX: 7b6184cb HEX: d570b632 HEX: 48745c6c HEX: d04257b8
+} ] [ d-table ] unit-test
+
+[ {
+HEX: a56363c6 HEX: 847c7cf8 HEX: 997777ee HEX: 8d7b7bf6 HEX: 0df2f2ff HEX: bd6b6bd6 HEX: b16f6fde HEX: 54c5c591
+HEX: 50303060 HEX: 03010102 HEX: a96767ce HEX: 7d2b2b56 HEX: 19fefee7 HEX: 62d7d7b5 HEX: e6abab4d HEX: 9a7676ec
+HEX: 45caca8f HEX: 9d82821f HEX: 40c9c989 HEX: 877d7dfa HEX: 15fafaef HEX: eb5959b2 HEX: c947478e HEX: 0bf0f0fb
+HEX: ecadad41 HEX: 67d4d4b3 HEX: fda2a25f HEX: eaafaf45 HEX: bf9c9c23 HEX: f7a4a453 HEX: 967272e4 HEX: 5bc0c09b
+HEX: c2b7b775 HEX: 1cfdfde1 HEX: ae93933d HEX: 6a26264c HEX: 5a36366c HEX: 413f3f7e HEX: 02f7f7f5 HEX: 4fcccc83
+HEX: 5c343468 HEX: f4a5a551 HEX: 34e5e5d1 HEX: 08f1f1f9 HEX: 937171e2 HEX: 73d8d8ab HEX: 53313162 HEX: 3f15152a
+HEX: 0c040408 HEX: 52c7c795 HEX: 65232346 HEX: 5ec3c39d HEX: 28181830 HEX: a1969637 HEX: 0f05050a HEX: b59a9a2f
+HEX: 0907070e HEX: 36121224 HEX: 9b80801b HEX: 3de2e2df HEX: 26ebebcd HEX: 6927274e HEX: cdb2b27f HEX: 9f7575ea
+HEX: 1b090912 HEX: 9e83831d HEX: 742c2c58 HEX: 2e1a1a34 HEX: 2d1b1b36 HEX: b26e6edc HEX: ee5a5ab4 HEX: fba0a05b
+HEX: f65252a4 HEX: 4d3b3b76 HEX: 61d6d6b7 HEX: ceb3b37d HEX: 7b292952 HEX: 3ee3e3dd HEX: 712f2f5e HEX: 97848413
+HEX: f55353a6 HEX: 68d1d1b9 HEX: 00000000 HEX: 2cededc1 HEX: 60202040 HEX: 1ffcfce3 HEX: c8b1b179 HEX: ed5b5bb6
+HEX: be6a6ad4 HEX: 46cbcb8d HEX: d9bebe67 HEX: 4b393972 HEX: de4a4a94 HEX: d44c4c98 HEX: e85858b0 HEX: 4acfcf85
+HEX: 6bd0d0bb HEX: 2aefefc5 HEX: e5aaaa4f HEX: 16fbfbed HEX: c5434386 HEX: d74d4d9a HEX: 55333366 HEX: 94858511
+HEX: cf45458a HEX: 10f9f9e9 HEX: 06020204 HEX: 817f7ffe HEX: f05050a0 HEX: 443c3c78 HEX: ba9f9f25 HEX: e3a8a84b
+HEX: f35151a2 HEX: fea3a35d HEX: c0404080 HEX: 8a8f8f05 HEX: ad92923f HEX: bc9d9d21 HEX: 48383870 HEX: 04f5f5f1
+HEX: dfbcbc63 HEX: c1b6b677 HEX: 75dadaaf HEX: 63212142 HEX: 30101020 HEX: 1affffe5 HEX: 0ef3f3fd HEX: 6dd2d2bf
+HEX: 4ccdcd81 HEX: 140c0c18 HEX: 35131326 HEX: 2fececc3 HEX: e15f5fbe HEX: a2979735 HEX: cc444488 HEX: 3917172e
+HEX: 57c4c493 HEX: f2a7a755 HEX: 827e7efc HEX: 473d3d7a HEX: ac6464c8 HEX: e75d5dba HEX: 2b191932 HEX: 957373e6
+HEX: a06060c0 HEX: 98818119 HEX: d14f4f9e HEX: 7fdcdca3 HEX: 66222244 HEX: 7e2a2a54 HEX: ab90903b HEX: 8388880b
+HEX: ca46468c HEX: 29eeeec7 HEX: d3b8b86b HEX: 3c141428 HEX: 79dedea7 HEX: e25e5ebc HEX: 1d0b0b16 HEX: 76dbdbad
+HEX: 3be0e0db HEX: 56323264 HEX: 4e3a3a74 HEX: 1e0a0a14 HEX: db494992 HEX: 0a06060c HEX: 6c242448 HEX: e45c5cb8
+HEX: 5dc2c29f HEX: 6ed3d3bd HEX: efacac43 HEX: a66262c4 HEX: a8919139 HEX: a4959531 HEX: 37e4e4d3 HEX: 8b7979f2
+HEX: 32e7e7d5 HEX: 43c8c88b HEX: 5937376e HEX: b76d6dda HEX: 8c8d8d01 HEX: 64d5d5b1 HEX: d24e4e9c HEX: e0a9a949
+HEX: b46c6cd8 HEX: fa5656ac HEX: 07f4f4f3 HEX: 25eaeacf HEX: af6565ca HEX: 8e7a7af4 HEX: e9aeae47 HEX: 18080810
+HEX: d5baba6f HEX: 887878f0 HEX: 6f25254a HEX: 722e2e5c HEX: 241c1c38 HEX: f1a6a657 HEX: c7b4b473 HEX: 51c6c697
+HEX: 23e8e8cb HEX: 7cdddda1 HEX: 9c7474e8 HEX: 211f1f3e HEX: dd4b4b96 HEX: dcbdbd61 HEX: 868b8b0d HEX: 858a8a0f
+HEX: 907070e0 HEX: 423e3e7c HEX: c4b5b571 HEX: aa6666cc HEX: d8484890 HEX: 05030306 HEX: 01f6f6f7 HEX: 120e0e1c
+HEX: a36161c2 HEX: 5f35356a HEX: f95757ae HEX: d0b9b969 HEX: 91868617 HEX: 58c1c199 HEX: 271d1d3a HEX: b99e9e27
+HEX: 38e1e1d9 HEX: 13f8f8eb HEX: b398982b HEX: 33111122 HEX: bb6969d2 HEX: 70d9d9a9 HEX: 898e8e07 HEX: a7949433
+HEX: b69b9b2d HEX: 221e1e3c HEX: 92878715 HEX: 20e9e9c9 HEX: 49cece87 HEX: ff5555aa HEX: 78282850 HEX: 7adfdfa5
+HEX: 8f8c8c03 HEX: f8a1a159 HEX: 80898909 HEX: 170d0d1a HEX: dabfbf65 HEX: 31e6e6d7 HEX: c6424284 HEX: b86868d0
+HEX: c3414182 HEX: b0999929 HEX: 772d2d5a HEX: 110f0f1e HEX: cbb0b07b HEX: fc5454a8 HEX: d6bbbb6d HEX: 3a16162c
+HEX: 6363c6a5 HEX: 7c7cf884 HEX: 7777ee99 HEX: 7b7bf68d HEX: f2f2ff0d HEX: 6b6bd6bd HEX: 6f6fdeb1 HEX: c5c59154
+HEX: 30306050 HEX: 01010203 HEX: 6767cea9 HEX: 2b2b567d HEX: fefee719 HEX: d7d7b562 HEX: abab4de6 HEX: 7676ec9a
+HEX: caca8f45 HEX: 82821f9d HEX: c9c98940 HEX: 7d7dfa87 HEX: fafaef15 HEX: 5959b2eb HEX: 47478ec9 HEX: f0f0fb0b
+HEX: adad41ec HEX: d4d4b367 HEX: a2a25ffd HEX: afaf45ea HEX: 9c9c23bf HEX: a4a453f7 HEX: 7272e496 HEX: c0c09b5b
+HEX: b7b775c2 HEX: fdfde11c HEX: 93933dae HEX: 26264c6a HEX: 36366c5a HEX: 3f3f7e41 HEX: f7f7f502 HEX: cccc834f
+HEX: 3434685c HEX: a5a551f4 HEX: e5e5d134 HEX: f1f1f908 HEX: 7171e293 HEX: d8d8ab73 HEX: 31316253 HEX: 15152a3f
+HEX: 0404080c HEX: c7c79552 HEX: 23234665 HEX: c3c39d5e HEX: 18183028 HEX: 969637a1 HEX: 05050a0f HEX: 9a9a2fb5
+HEX: 07070e09 HEX: 12122436 HEX: 80801b9b HEX: e2e2df3d HEX: ebebcd26 HEX: 27274e69 HEX: b2b27fcd HEX: 7575ea9f
+HEX: 0909121b HEX: 83831d9e HEX: 2c2c5874 HEX: 1a1a342e HEX: 1b1b362d HEX: 6e6edcb2 HEX: 5a5ab4ee HEX: a0a05bfb
+HEX: 5252a4f6 HEX: 3b3b764d HEX: d6d6b761 HEX: b3b37dce HEX: 2929527b HEX: e3e3dd3e HEX: 2f2f5e71 HEX: 84841397
+HEX: 5353a6f5 HEX: d1d1b968 HEX: 00000000 HEX: ededc12c HEX: 20204060 HEX: fcfce31f HEX: b1b179c8 HEX: 5b5bb6ed
+HEX: 6a6ad4be HEX: cbcb8d46 HEX: bebe67d9 HEX: 3939724b HEX: 4a4a94de HEX: 4c4c98d4 HEX: 5858b0e8 HEX: cfcf854a
+HEX: d0d0bb6b HEX: efefc52a HEX: aaaa4fe5 HEX: fbfbed16 HEX: 434386c5 HEX: 4d4d9ad7 HEX: 33336655 HEX: 85851194
+HEX: 45458acf HEX: f9f9e910 HEX: 02020406 HEX: 7f7ffe81 HEX: 5050a0f0 HEX: 3c3c7844 HEX: 9f9f25ba HEX: a8a84be3
+HEX: 5151a2f3 HEX: a3a35dfe HEX: 404080c0 HEX: 8f8f058a HEX: 92923fad HEX: 9d9d21bc HEX: 38387048 HEX: f5f5f104
+HEX: bcbc63df HEX: b6b677c1 HEX: dadaaf75 HEX: 21214263 HEX: 10102030 HEX: ffffe51a HEX: f3f3fd0e HEX: d2d2bf6d
+HEX: cdcd814c HEX: 0c0c1814 HEX: 13132635 HEX: ececc32f HEX: 5f5fbee1 HEX: 979735a2 HEX: 444488cc HEX: 17172e39
+HEX: c4c49357 HEX: a7a755f2 HEX: 7e7efc82 HEX: 3d3d7a47 HEX: 6464c8ac HEX: 5d5dbae7 HEX: 1919322b HEX: 7373e695
+HEX: 6060c0a0 HEX: 81811998 HEX: 4f4f9ed1 HEX: dcdca37f HEX: 22224466 HEX: 2a2a547e HEX: 90903bab HEX: 88880b83
+HEX: 46468cca HEX: eeeec729 HEX: b8b86bd3 HEX: 1414283c HEX: dedea779 HEX: 5e5ebce2 HEX: 0b0b161d HEX: dbdbad76
+HEX: e0e0db3b HEX: 32326456 HEX: 3a3a744e HEX: 0a0a141e HEX: 494992db HEX: 06060c0a HEX: 2424486c HEX: 5c5cb8e4
+HEX: c2c29f5d HEX: d3d3bd6e HEX: acac43ef HEX: 6262c4a6 HEX: 919139a8 HEX: 959531a4 HEX: e4e4d337 HEX: 7979f28b
+HEX: e7e7d532 HEX: c8c88b43 HEX: 37376e59 HEX: 6d6ddab7 HEX: 8d8d018c HEX: d5d5b164 HEX: 4e4e9cd2 HEX: a9a949e0
+HEX: 6c6cd8b4 HEX: 5656acfa HEX: f4f4f307 HEX: eaeacf25 HEX: 6565caaf HEX: 7a7af48e HEX: aeae47e9 HEX: 08081018
+HEX: baba6fd5 HEX: 7878f088 HEX: 25254a6f HEX: 2e2e5c72 HEX: 1c1c3824 HEX: a6a657f1 HEX: b4b473c7 HEX: c6c69751
+HEX: e8e8cb23 HEX: dddda17c HEX: 7474e89c HEX: 1f1f3e21 HEX: 4b4b96dd HEX: bdbd61dc HEX: 8b8b0d86 HEX: 8a8a0f85
+HEX: 7070e090 HEX: 3e3e7c42 HEX: b5b571c4 HEX: 6666ccaa HEX: 484890d8 HEX: 03030605 HEX: f6f6f701 HEX: 0e0e1c12
+HEX: 6161c2a3 HEX: 35356a5f HEX: 5757aef9 HEX: b9b969d0 HEX: 86861791 HEX: c1c19958 HEX: 1d1d3a27 HEX: 9e9e27b9
+HEX: e1e1d938 HEX: f8f8eb13 HEX: 98982bb3 HEX: 11112233 HEX: 6969d2bb HEX: d9d9a970 HEX: 8e8e0789 HEX: 949433a7
+HEX: 9b9b2db6 HEX: 1e1e3c22 HEX: 87871592 HEX: e9e9c920 HEX: cece8749 HEX: 5555aaff HEX: 28285078 HEX: dfdfa57a
+HEX: 8c8c038f HEX: a1a159f8 HEX: 89890980 HEX: 0d0d1a17 HEX: bfbf65da HEX: e6e6d731 HEX: 424284c6 HEX: 6868d0b8
+HEX: 414182c3 HEX: 999929b0 HEX: 2d2d5a77 HEX: 0f0f1e11 HEX: b0b07bcb HEX: 5454a8fc HEX: bbbb6dd6 HEX: 16162c3a
+HEX: 63c6a563 HEX: 7cf8847c HEX: 77ee9977 HEX: 7bf68d7b HEX: f2ff0df2 HEX: 6bd6bd6b HEX: 6fdeb16f HEX: c59154c5
+HEX: 30605030 HEX: 01020301 HEX: 67cea967 HEX: 2b567d2b HEX: fee719fe HEX: d7b562d7 HEX: ab4de6ab HEX: 76ec9a76
+HEX: ca8f45ca HEX: 821f9d82 HEX: c98940c9 HEX: 7dfa877d HEX: faef15fa HEX: 59b2eb59 HEX: 478ec947 HEX: f0fb0bf0
+HEX: ad41ecad HEX: d4b367d4 HEX: a25ffda2 HEX: af45eaaf HEX: 9c23bf9c HEX: a453f7a4 HEX: 72e49672 HEX: c09b5bc0
+HEX: b775c2b7 HEX: fde11cfd HEX: 933dae93 HEX: 264c6a26 HEX: 366c5a36 HEX: 3f7e413f HEX: f7f502f7 HEX: cc834fcc
+HEX: 34685c34 HEX: a551f4a5 HEX: e5d134e5 HEX: f1f908f1 HEX: 71e29371 HEX: d8ab73d8 HEX: 31625331 HEX: 152a3f15
+HEX: 04080c04 HEX: c79552c7 HEX: 23466523 HEX: c39d5ec3 HEX: 18302818 HEX: 9637a196 HEX: 050a0f05 HEX: 9a2fb59a
+HEX: 070e0907 HEX: 12243612 HEX: 801b9b80 HEX: e2df3de2 HEX: ebcd26eb HEX: 274e6927 HEX: b27fcdb2 HEX: 75ea9f75
+HEX: 09121b09 HEX: 831d9e83 HEX: 2c58742c HEX: 1a342e1a HEX: 1b362d1b HEX: 6edcb26e HEX: 5ab4ee5a HEX: a05bfba0
+HEX: 52a4f652 HEX: 3b764d3b HEX: d6b761d6 HEX: b37dceb3 HEX: 29527b29 HEX: e3dd3ee3 HEX: 2f5e712f HEX: 84139784
+HEX: 53a6f553 HEX: d1b968d1 HEX: 00000000 HEX: edc12ced HEX: 20406020 HEX: fce31ffc HEX: b179c8b1 HEX: 5bb6ed5b
+HEX: 6ad4be6a HEX: cb8d46cb HEX: be67d9be HEX: 39724b39 HEX: 4a94de4a HEX: 4c98d44c HEX: 58b0e858 HEX: cf854acf
+HEX: d0bb6bd0 HEX: efc52aef HEX: aa4fe5aa HEX: fbed16fb HEX: 4386c543 HEX: 4d9ad74d HEX: 33665533 HEX: 85119485
+HEX: 458acf45 HEX: f9e910f9 HEX: 02040602 HEX: 7ffe817f HEX: 50a0f050 HEX: 3c78443c HEX: 9f25ba9f HEX: a84be3a8
+HEX: 51a2f351 HEX: a35dfea3 HEX: 4080c040 HEX: 8f058a8f HEX: 923fad92 HEX: 9d21bc9d HEX: 38704838 HEX: f5f104f5
+HEX: bc63dfbc HEX: b677c1b6 HEX: daaf75da HEX: 21426321 HEX: 10203010 HEX: ffe51aff HEX: f3fd0ef3 HEX: d2bf6dd2
+HEX: cd814ccd HEX: 0c18140c HEX: 13263513 HEX: ecc32fec HEX: 5fbee15f HEX: 9735a297 HEX: 4488cc44 HEX: 172e3917
+HEX: c49357c4 HEX: a755f2a7 HEX: 7efc827e HEX: 3d7a473d HEX: 64c8ac64 HEX: 5dbae75d HEX: 19322b19 HEX: 73e69573
+HEX: 60c0a060 HEX: 81199881 HEX: 4f9ed14f HEX: dca37fdc HEX: 22446622 HEX: 2a547e2a HEX: 903bab90 HEX: 880b8388
+HEX: 468cca46 HEX: eec729ee HEX: b86bd3b8 HEX: 14283c14 HEX: dea779de HEX: 5ebce25e HEX: 0b161d0b HEX: dbad76db
+HEX: e0db3be0 HEX: 32645632 HEX: 3a744e3a HEX: 0a141e0a HEX: 4992db49 HEX: 060c0a06 HEX: 24486c24 HEX: 5cb8e45c
+HEX: c29f5dc2 HEX: d3bd6ed3 HEX: ac43efac HEX: 62c4a662 HEX: 9139a891 HEX: 9531a495 HEX: e4d337e4 HEX: 79f28b79
+HEX: e7d532e7 HEX: c88b43c8 HEX: 376e5937 HEX: 6ddab76d HEX: 8d018c8d HEX: d5b164d5 HEX: 4e9cd24e HEX: a949e0a9
+HEX: 6cd8b46c HEX: 56acfa56 HEX: f4f307f4 HEX: eacf25ea HEX: 65caaf65 HEX: 7af48e7a HEX: ae47e9ae HEX: 08101808
+HEX: ba6fd5ba HEX: 78f08878 HEX: 254a6f25 HEX: 2e5c722e HEX: 1c38241c HEX: a657f1a6 HEX: b473c7b4 HEX: c69751c6
+HEX: e8cb23e8 HEX: dda17cdd HEX: 74e89c74 HEX: 1f3e211f HEX: 4b96dd4b HEX: bd61dcbd HEX: 8b0d868b HEX: 8a0f858a
+HEX: 70e09070 HEX: 3e7c423e HEX: b571c4b5 HEX: 66ccaa66 HEX: 4890d848 HEX: 03060503 HEX: f6f701f6 HEX: 0e1c120e
+HEX: 61c2a361 HEX: 356a5f35 HEX: 57aef957 HEX: b969d0b9 HEX: 86179186 HEX: c19958c1 HEX: 1d3a271d HEX: 9e27b99e
+HEX: e1d938e1 HEX: f8eb13f8 HEX: 982bb398 HEX: 11223311 HEX: 69d2bb69 HEX: d9a970d9 HEX: 8e07898e HEX: 9433a794
+HEX: 9b2db69b HEX: 1e3c221e HEX: 87159287 HEX: e9c920e9 HEX: ce8749ce HEX: 55aaff55 HEX: 28507828 HEX: dfa57adf
+HEX: 8c038f8c HEX: a159f8a1 HEX: 89098089 HEX: 0d1a170d HEX: bf65dabf HEX: e6d731e6 HEX: 4284c642 HEX: 68d0b868
+HEX: 4182c341 HEX: 9929b099 HEX: 2d5a772d HEX: 0f1e110f HEX: b07bcbb0 HEX: 54a8fc54 HEX: bb6dd6bb HEX: 162c3a16
+HEX: c6a56363 HEX: f8847c7c HEX: ee997777 HEX: f68d7b7b HEX: ff0df2f2 HEX: d6bd6b6b HEX: deb16f6f HEX: 9154c5c5
+HEX: 60503030 HEX: 02030101 HEX: cea96767 HEX: 567d2b2b HEX: e719fefe HEX: b562d7d7 HEX: 4de6abab HEX: ec9a7676
+HEX: 8f45caca HEX: 1f9d8282 HEX: 8940c9c9 HEX: fa877d7d HEX: ef15fafa HEX: b2eb5959 HEX: 8ec94747 HEX: fb0bf0f0
+HEX: 41ecadad HEX: b367d4d4 HEX: 5ffda2a2 HEX: 45eaafaf HEX: 23bf9c9c HEX: 53f7a4a4 HEX: e4967272 HEX: 9b5bc0c0
+HEX: 75c2b7b7 HEX: e11cfdfd HEX: 3dae9393 HEX: 4c6a2626 HEX: 6c5a3636 HEX: 7e413f3f HEX: f502f7f7 HEX: 834fcccc
+HEX: 685c3434 HEX: 51f4a5a5 HEX: d134e5e5 HEX: f908f1f1 HEX: e2937171 HEX: ab73d8d8 HEX: 62533131 HEX: 2a3f1515
+HEX: 080c0404 HEX: 9552c7c7 HEX: 46652323 HEX: 9d5ec3c3 HEX: 30281818 HEX: 37a19696 HEX: 0a0f0505 HEX: 2fb59a9a
+HEX: 0e090707 HEX: 24361212 HEX: 1b9b8080 HEX: df3de2e2 HEX: cd26ebeb HEX: 4e692727 HEX: 7fcdb2b2 HEX: ea9f7575
+HEX: 121b0909 HEX: 1d9e8383 HEX: 58742c2c HEX: 342e1a1a HEX: 362d1b1b HEX: dcb26e6e HEX: b4ee5a5a HEX: 5bfba0a0
+HEX: a4f65252 HEX: 764d3b3b HEX: b761d6d6 HEX: 7dceb3b3 HEX: 527b2929 HEX: dd3ee3e3 HEX: 5e712f2f HEX: 13978484
+HEX: a6f55353 HEX: b968d1d1 HEX: 00000000 HEX: c12ceded HEX: 40602020 HEX: e31ffcfc HEX: 79c8b1b1 HEX: b6ed5b5b
+HEX: d4be6a6a HEX: 8d46cbcb HEX: 67d9bebe HEX: 724b3939 HEX: 94de4a4a HEX: 98d44c4c HEX: b0e85858 HEX: 854acfcf
+HEX: bb6bd0d0 HEX: c52aefef HEX: 4fe5aaaa HEX: ed16fbfb HEX: 86c54343 HEX: 9ad74d4d HEX: 66553333 HEX: 11948585
+HEX: 8acf4545 HEX: e910f9f9 HEX: 04060202 HEX: fe817f7f HEX: a0f05050 HEX: 78443c3c HEX: 25ba9f9f HEX: 4be3a8a8
+HEX: a2f35151 HEX: 5dfea3a3 HEX: 80c04040 HEX: 058a8f8f HEX: 3fad9292 HEX: 21bc9d9d HEX: 70483838 HEX: f104f5f5
+HEX: 63dfbcbc HEX: 77c1b6b6 HEX: af75dada HEX: 42632121 HEX: 20301010 HEX: e51affff HEX: fd0ef3f3 HEX: bf6dd2d2
+HEX: 814ccdcd HEX: 18140c0c HEX: 26351313 HEX: c32fecec HEX: bee15f5f HEX: 35a29797 HEX: 88cc4444 HEX: 2e391717
+HEX: 9357c4c4 HEX: 55f2a7a7 HEX: fc827e7e HEX: 7a473d3d HEX: c8ac6464 HEX: bae75d5d HEX: 322b1919 HEX: e6957373
+HEX: c0a06060 HEX: 19988181 HEX: 9ed14f4f HEX: a37fdcdc HEX: 44662222 HEX: 547e2a2a HEX: 3bab9090 HEX: 0b838888
+HEX: 8cca4646 HEX: c729eeee HEX: 6bd3b8b8 HEX: 283c1414 HEX: a779dede HEX: bce25e5e HEX: 161d0b0b HEX: ad76dbdb
+HEX: db3be0e0 HEX: 64563232 HEX: 744e3a3a HEX: 141e0a0a HEX: 92db4949 HEX: 0c0a0606 HEX: 486c2424 HEX: b8e45c5c
+HEX: 9f5dc2c2 HEX: bd6ed3d3 HEX: 43efacac HEX: c4a66262 HEX: 39a89191 HEX: 31a49595 HEX: d337e4e4 HEX: f28b7979
+HEX: d532e7e7 HEX: 8b43c8c8 HEX: 6e593737 HEX: dab76d6d HEX: 018c8d8d HEX: b164d5d5 HEX: 9cd24e4e HEX: 49e0a9a9
+HEX: d8b46c6c HEX: acfa5656 HEX: f307f4f4 HEX: cf25eaea HEX: caaf6565 HEX: f48e7a7a HEX: 47e9aeae HEX: 10180808
+HEX: 6fd5baba HEX: f0887878 HEX: 4a6f2525 HEX: 5c722e2e HEX: 38241c1c HEX: 57f1a6a6 HEX: 73c7b4b4 HEX: 9751c6c6
+HEX: cb23e8e8 HEX: a17cdddd HEX: e89c7474 HEX: 3e211f1f HEX: 96dd4b4b HEX: 61dcbdbd HEX: 0d868b8b HEX: 0f858a8a
+HEX: e0907070 HEX: 7c423e3e HEX: 71c4b5b5 HEX: ccaa6666 HEX: 90d84848 HEX: 06050303 HEX: f701f6f6 HEX: 1c120e0e
+HEX: c2a36161 HEX: 6a5f3535 HEX: aef95757 HEX: 69d0b9b9 HEX: 17918686 HEX: 9958c1c1 HEX: 3a271d1d HEX: 27b99e9e
+HEX: d938e1e1 HEX: eb13f8f8 HEX: 2bb39898 HEX: 22331111 HEX: d2bb6969 HEX: a970d9d9 HEX: 07898e8e HEX: 33a79494
+HEX: 2db69b9b HEX: 3c221e1e HEX: 15928787 HEX: c920e9e9 HEX: 8749cece HEX: aaff5555 HEX: 50782828 HEX: a57adfdf
+HEX: 038f8c8c HEX: 59f8a1a1 HEX: 09808989 HEX: 1a170d0d HEX: 65dabfbf HEX: d731e6e6 HEX: 84c64242 HEX: d0b86868
+HEX: 82c34141 HEX: 29b09999 HEX: 5a772d2d HEX: 1e110f0f HEX: 7bcbb0b0 HEX: a8fc5454 HEX: 6dd6bbbb HEX: 2c3a1616
+} ] [ t-table ] unit-test
+
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math memoize sequences math.bitwise
+locals ;
+IN: crypto.aes
+
+: AES_BLOCK_SIZE 16 ; inline
+
+: sbox ( -- array )
+{
+ HEX: 63 HEX: 7c HEX: 77 HEX: 7b HEX: f2 HEX: 6b HEX: 6f HEX: c5
+ HEX: 30 HEX: 01 HEX: 67 HEX: 2b HEX: fe HEX: d7 HEX: ab HEX: 76
+ HEX: ca HEX: 82 HEX: c9 HEX: 7d HEX: fa HEX: 59 HEX: 47 HEX: f0
+ HEX: ad HEX: d4 HEX: a2 HEX: af HEX: 9c HEX: a4 HEX: 72 HEX: c0
+ HEX: b7 HEX: fd HEX: 93 HEX: 26 HEX: 36 HEX: 3f HEX: f7 HEX: cc
+ HEX: 34 HEX: a5 HEX: e5 HEX: f1 HEX: 71 HEX: d8 HEX: 31 HEX: 15
+ HEX: 04 HEX: c7 HEX: 23 HEX: c3 HEX: 18 HEX: 96 HEX: 05 HEX: 9a
+ HEX: 07 HEX: 12 HEX: 80 HEX: e2 HEX: eb HEX: 27 HEX: b2 HEX: 75
+ HEX: 09 HEX: 83 HEX: 2c HEX: 1a HEX: 1b HEX: 6e HEX: 5a HEX: a0
+ HEX: 52 HEX: 3b HEX: d6 HEX: b3 HEX: 29 HEX: e3 HEX: 2f HEX: 84
+ HEX: 53 HEX: d1 HEX: 00 HEX: ed HEX: 20 HEX: fc HEX: b1 HEX: 5b
+ HEX: 6a HEX: cb HEX: be HEX: 39 HEX: 4a HEX: 4c HEX: 58 HEX: cf
+ HEX: d0 HEX: ef HEX: aa HEX: fb HEX: 43 HEX: 4d HEX: 33 HEX: 85
+ HEX: 45 HEX: f9 HEX: 02 HEX: 7f HEX: 50 HEX: 3c HEX: 9f HEX: a8
+ HEX: 51 HEX: a3 HEX: 40 HEX: 8f HEX: 92 HEX: 9d HEX: 38 HEX: f5
+ HEX: bc HEX: b6 HEX: da HEX: 21 HEX: 10 HEX: ff HEX: f3 HEX: d2
+ HEX: cd HEX: 0c HEX: 13 HEX: ec HEX: 5f HEX: 97 HEX: 44 HEX: 17
+ HEX: c4 HEX: a7 HEX: 7e HEX: 3d HEX: 64 HEX: 5d HEX: 19 HEX: 73
+ HEX: 60 HEX: 81 HEX: 4f HEX: dc HEX: 22 HEX: 2a HEX: 90 HEX: 88
+ HEX: 46 HEX: ee HEX: b8 HEX: 14 HEX: de HEX: 5e HEX: 0b HEX: db
+ HEX: e0 HEX: 32 HEX: 3a HEX: 0a HEX: 49 HEX: 06 HEX: 24 HEX: 5c
+ HEX: c2 HEX: d3 HEX: ac HEX: 62 HEX: 91 HEX: 95 HEX: e4 HEX: 79
+ HEX: e7 HEX: c8 HEX: 37 HEX: 6d HEX: 8d HEX: d5 HEX: 4e HEX: a9
+ HEX: 6c HEX: 56 HEX: f4 HEX: ea HEX: 65 HEX: 7a HEX: ae HEX: 08
+ HEX: ba HEX: 78 HEX: 25 HEX: 2e HEX: 1c HEX: a6 HEX: b4 HEX: c6
+ HEX: e8 HEX: dd HEX: 74 HEX: 1f HEX: 4b HEX: bd HEX: 8b HEX: 8a
+ HEX: 70 HEX: 3e HEX: b5 HEX: 66 HEX: 48 HEX: 03 HEX: f6 HEX: 0e
+ HEX: 61 HEX: 35 HEX: 57 HEX: b9 HEX: 86 HEX: c1 HEX: 1d HEX: 9e
+ HEX: e1 HEX: f8 HEX: 98 HEX: 11 HEX: 69 HEX: d9 HEX: 8e HEX: 94
+ HEX: 9b HEX: 1e HEX: 87 HEX: e9 HEX: ce HEX: 55 HEX: 28 HEX: df
+ HEX: 8c HEX: a1 HEX: 89 HEX: 0d HEX: bf HEX: e6 HEX: 42 HEX: 68
+ HEX: 41 HEX: 99 HEX: 2d HEX: 0f HEX: b0 HEX: 54 HEX: bb HEX: 16
+} ;
+
+: inv-sbox ( -- array )
+ 256 0 <array>
+ dup 256 [ dup sbox nth rot set-nth ] with each ;
+
+: rcon ( -- array )
+ {
+ HEX: 00 HEX: 01 HEX: 02 HEX: 04 HEX: 08 HEX: 10
+ HEX: 20 HEX: 40 HEX: 80 HEX: 1b HEX: 36
+ } ;
+
+: xtime ( x -- x' )
+ [ 1 shift ]
+ [ HEX: 80 bitand 0 = 0 HEX: 1b ? ] bi bitxor 8 bits ;
+
+: ui32 ( a0 a1 a2 a3 -- a )
+ [ 8 shift ] [ 16 shift ] [ 24 shift ] tri*
+ bitor bitor bitor 32 bits ;
+
+:: set-t ( T i -- )
+ [let* |
+ a1 [ i sbox nth ]
+ a2 [ a1 xtime ]
+ a3 [ a1 a2 bitxor ] |
+ a2 a1 a1 a3 ui32 i T set-nth
+ a3 a2 a1 a1 ui32 i HEX: 100 + T set-nth
+ a1 a3 a2 a1 ui32 i HEX: 200 + T set-nth
+ a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth
+ ] ;
+
+
+MEMO:: t-table ( -- array )
+ 1024 0 <array>
+ dup 256 [ set-t ] with each ;
+
+:: set-d ( D i -- )
+ [let* |
+ a1 [ i inv-sbox nth ]
+ a2 [ a1 xtime ]
+ a4 [ a2 xtime ]
+ a8 [ a4 xtime ]
+ a9 [ a8 a1 bitxor ]
+ ab [ a9 a2 bitxor ]
+ ad [ a9 a4 bitxor ]
+ ae [ a8 a4 a2 bitxor bitxor ]
+ |
+ ae a9 ad ab ui32 i D set-nth
+ ab ae a9 ad ui32 i HEX: 100 + D set-nth
+ ad ab ae a9 ui32 i HEX: 200 + D set-nth
+ a9 ad ab ae ui32 i HEX: 300 + D set-nth
+ ] ;
+
+MEMO:: d-table ( -- array )
+ 1024 0 <array>
+ dup 256 [ set-d ] with each ;
+
+
+USE: multiline
+/*
+! : HT ( i x s --
+
+
+TUPLE: caes #rounds2 rkey ;
+! rounds / 2, rkey is a byte-array 60 long
+! key size is 16, 24, 32 bytes
+
+TUPLE: caescbc prev4 caes ;
+
+
+
+: aes-set-key-encode ( p key -- )
+
+ ;
+*/
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string strings ;
+IN: crypto.passwd-md5
+
+HELP: authenticate-password
+{ $values
+ { "shadow" string } { "password" string }
+ { "?" "a boolean" } }
+{ $description "Encodes the provided password and compares it to the encoded password entry from a shadowed password file." } ;
+
+HELP: parse-shadow-password
+{ $values
+ { "string" string }
+ { "magic" string } { "salt" string } { "password" string } }
+{ $description "Splits a shadowed password entry into a magic string, a salt, and an encoded password string." } ;
+
+HELP: passwd-md5
+{ $values
+ { "magic" string } { "salt" string } { "password" string }
+ { "bytes" "an md5-shadowed password entry" } }
+{ $description "Encodes the password with the given magic string and salt to an MD5-shadow password entry." } ;
+
+ARTICLE: "crypto.passwd-md5" "MD5 shadow passwords"
+"The " { $vocab-link "crypto.passwd-md5" } " vocabulary can encode passwords for use in an MD5 shadow password file." $nl
+
+"Encoding a password:"
+{ $subsection passwd-md5 }
+"Parsing a shadowed password entry:"
+{ $subsection parse-shadow-password }
+"Authenticating against a shadowed password:"
+{ $subsection authenticate-password } ;
+
+ABOUT: "crypto.passwd-md5"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test crypto.passwd-md5 ;
+IN: crypto.passwd-md5.tests
+
+
+[ "$1$npUpD5oQ$1.X7uXR2QG0FzPifVeZ2o1" ]
+[ "$1$" "npUpD5oQ" "factor" passwd-md5 ] unit-test
+
+[ "$1$Kilak4kR$wlEr5Dv5DcdqPjKjQtt430" ]
+[
+ "$1$"
+ "Kilak4kR"
+ "longpassword12345678901234567890"
+ passwd-md5
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel base64 checksums.md5 symbols sequences checksums
+locals prettyprint math math.bitwise grouping io combinators
+fry make combinators.short-circuit math.functions splitting ;
+IN: crypto.passwd-md5
+
+<PRIVATE
+
+: lookup-table ( n -- nth )
+ "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" nth ; inline
+
+: to64 ( v n -- string )
+ [ [ -6 shift ] [ 6 2^ 1- bitand lookup-table ] bi ]
+ replicate nip ; inline
+
+PRIVATE>
+
+:: passwd-md5 ( magic salt password -- bytes )
+ [let* | final! [ password magic salt 3append
+ salt password tuck 3append md5 checksum-bytes
+ password length
+ [ 16 / ceiling swap <repetition> concat ] keep
+ head-slice append
+ password [ length ] [ first ] bi
+ '[ [ CHAR: \0 _ ? , ] each-bit ] "" make append
+ md5 checksum-bytes ] |
+ 1000 [
+ "" swap
+ {
+ [ 0 bit? password final ? append ]
+ [ 3 mod 0 > [ salt append ] when ]
+ [ 7 mod 0 > [ password append ] when ]
+ [ 0 bit? final password ? append ]
+ } cleave md5 checksum-bytes final!
+ ] each
+
+ magic salt "$" 3append
+ { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group
+ [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat
+ 11 final nth 2 to64 3append ] ;
+
+: parse-shadow-password ( string -- magic salt password )
+ "$" split harvest first3 [ "$" tuck 3append ] 2dip ;
+
+: authenticate-password ( shadow password -- ? )
+ '[ parse-shadow-password drop _ passwd-md5 ] keep = ;
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: digraphs kernel sequences tools.test ;
+IN: digraphs.tests
+
+: test-digraph ( -- digraph )
+ <digraph>
+ { { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } }
+ [ first2 pick add-vertex ] each
+ { { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } }
+ [ first2 pick add-edge ] each ;
+
+[ 5 ] [ test-digraph topological-sort length ] unit-test
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs hashtables hashtables.private kernel sequences vectors ;
+IN: digraphs
+
+TUPLE: digraph < hashtable ;
+
+: <digraph> ( -- digraph )
+ 0 digraph new [ reset-hash ] keep ;
+
+TUPLE: vertex value edges ;
+
+: <vertex> ( value -- vertex )
+ V{ } clone vertex boa ;
+
+: add-vertex ( key value digraph -- )
+ [ <vertex> swap ] dip set-at ;
+
+: children ( key digraph -- seq )
+ at edges>> ;
+
+: @edges ( from to digraph -- to edges ) swapd at edges>> ;
+: add-edge ( from to digraph -- ) @edges push ;
+: delete-edge ( from to digraph -- ) @edges delete ;
+
+: delete-to-edges ( to digraph -- )
+ [ nip dupd edges>> delete ] assoc-each drop ;
+
+: delete-vertex ( key digraph -- )
+ 2dup delete-at delete-to-edges ;
+
+: unvisited? ( unvisited key -- ? ) swap key? ;
+: visited ( unvisited key -- ) swap delete-at ;
+
+DEFER: (topological-sort)
+: visit-children ( seq unvisited key -- seq unvisited )
+ over children [ (topological-sort) ] each ;
+
+: (topological-sort) ( seq unvisited key -- seq unvisited )
+ 2dup unvisited? [
+ [ visit-children ] keep 2dup visited pick push
+ ] [
+ drop
+ ] if ;
+
+: topological-sort ( digraph -- seq )
+ dup clone V{ } clone spin
+ [ drop (topological-sort) ] assoc-each drop reverse ;
+
+: topological-sorted-values ( digraph -- seq )
+ dup topological-sort swap [ at value>> ] curry map ;
--- /dev/null
+Simple directed graph implementation for topological sorting
--- /dev/null
+collections
+++ /dev/null
-
-USING: kernel system
- combinators
- vectors sequences assocs
- math math.functions
- prettyprint unicode.case
- accessors
- combinators.cleave
- newfx
- dns ;
-
-IN: dns.cache
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cache ( -- table ) H{ } ;
-
-! key: 'name type class' (as string)
-! val: entry
-
-TUPLE: entry time data ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: query->key ( query -- key )
- { [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } <arr> " " join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: table-get ( query -- result ) query->key cache of ;
-
-: table-check ( query -- ? ) query->key cache key? ;
-
-: table-add ( query value -- ) [ query->key ] [ ] bi* cache at-mutate ;
-
-: table-rem ( query -- ) query->key cache delete-key-of drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: now ( -- seconds ) millis 1000.0 / round >integer ;
-
-: ttl->time ( ttl -- seconds ) now + ;
-
-: time->ttl ( time -- ttl ) now - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: NX
-
-: cache-nx ( query ttl -- ) ttl->time NX entry boa table-add ;
-
-: nx? ( obj -- ? ) dup entry? [ data>> NX = ] [ drop f ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: query->rr ( query -- rr ) [ name>> ] [ type>> ] [ class>> ] tri f f rr boa ;
-
-: query+entry->rrs ( query entry -- rrs )
- swap ! entry query
- query->rr ! entry rr
- over ! entry rr entry
- time>> time->ttl >>ttl ! entry rr
- swap ! rr entry
- data>> [ >r dup clone r> >>rdata ] map
- nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
-
-: cache-get* ( query -- rrs/NX/f )
- dup table-get ! query result
- {
- { [ dup f = ] [ 2drop f ] } ! not in the cache
- { [ dup expired? ] [ drop table-rem f ] } ! here but expired
- { [ dup nx? ] [ 2drop NX ] } ! negative result cached
- { [ t ] [ query+entry->rrs ] } ! good to go
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cache-get ( query -- rrs/f )
- dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rr->entry ( rr -- entry )
- [ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
-
-: maybe-pushed-on ( obj seq -- )
- 2dup member-of?
- [ 2drop ]
- [ pushed-on ]
- if ;
-
-: add-rr-to-entry ( rr entry -- )
- over ttl>> ttl->time >>time
- [ rdata>> ] [ data>> ] bi* maybe-pushed-on ;
-
-: cache-add ( query rr -- )
- over table-get ! query rr entry
- {
- { [ dup f = ] [ drop rr->entry table-add ] }
- { [ dup nx? ] [ drop over table-rem rr->entry table-add ] }
- { [ dup expired? ] [ drop rr->entry table-add ] }
- { [ t ] [ rot drop add-rr-to-entry ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rr->query ( rr -- query ) [ name>> ] [ type>> ] [ class>> ] tri query boa ;
-
-: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
-
-: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! cache-name-error
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: message-soa ( message -- rr/soa )
- authority-section>> [ type>> SOA = ] filter 1st ;
-
-: cache-name-error ( message -- message )
- dup
- [ message-query ] [ message-soa ttl>> ] bi
- cache-nx ;
-
-: cache-message-records ( message -- message )
- dup
- {
- [ answer-section>> cache-add-rrs ]
- [ authority-section>> cache-add-rrs ]
- [ additional-section>> cache-add-rrs ]
- }
- cleave ;
-
-: cache-message ( message -- message )
- dup rcode>> NAME-ERROR = [ cache-name-error ] when
- cache-message-records ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
--- /dev/null
+
+USING: kernel assocs locals combinators
+ math math.functions system unicode.case ;
+
+IN: dns.cache.nx
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nx-cache ( -- table ) H{ } ;
+
+: nx-cache-at ( name -- time ) >lower nx-cache at ;
+: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ;
+: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+:: non-existent-name? ( NAME -- ? )
+ [let | TIME [ NAME nx-cache-at ] |
+ {
+ { [ TIME f = ] [ f ] }
+ { [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
+ { [ t ] [ t ] }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-non-existent-name ( NAME TTL -- )
+ [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel sequences assocs sets locals combinators
+ accessors system math math.functions unicode.case prettyprint
+ combinators.cleave dns ;
+
+IN: dns.cache.rr
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <entry> time data ;
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+: expired? ( <entry> -- ? ) time>> now <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-cache-key ( obj -- key )
+ { [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } 1arr " " join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache ( -- table ) H{ } ;
+
+: cache-at ( obj -- ent ) make-cache-key cache at ;
+: cache-delete ( obj -- ) make-cache-key cache delete-at ;
+: cache-set-at ( ent obj -- ) make-cache-key cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-get ( OBJ -- rrs/f )
+ [let | ENT [ OBJ cache-at ] |
+ {
+ { [ ENT f = ] [ f ] }
+ { [ ENT expired? ] [ OBJ cache-delete f ] }
+ {
+ [ t ]
+ [
+ [let | NAME [ OBJ name>> ]
+ TYPE [ OBJ type>> ]
+ CLASS [ OBJ class>> ]
+ TTL [ ENT time>> now - ] |
+ ENT data>>
+ [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
+ map
+ ]
+ ]
+ }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-add ( RR -- )
+ [let | ENT [ RR cache-at ]
+ TIME [ RR ttl>> now + ]
+ RDATA [ RR rdata>> ] |
+ {
+ { [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
+ { [ ENT expired? ] [ RR cache-delete RR cache-add ] }
+ { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
+ }
+ cond
+ ] ;
\ No newline at end of file
-USING: combinators.short-circuit kernel
- combinators
- vectors
- sequences
+USING: kernel sequences combinators accessors locals random
+ combinators.short-circuit
io.sockets
- accessors
- combinators.lib
- newfx
- dns dns.cache dns.misc ;
+ dns dns.util dns.cache.rr dns.cache.nx
+ dns.resolver ;
IN: dns.forwarding
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! DNS server - caching, forwarding
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (socket) ( -- vec ) V{ f } ;
-
-: socket ( -- socket ) (socket) 1st ;
-: init-socket-on-port ( port -- )
- f swap <inet4> <datagram> 0 (socket) as-mutate ;
-
-: init-socket ( -- ) 53 init-socket-on-port ;
+:: query->rrs ( QUERY -- rrs/f )
+ [let | RRS [ QUERY cache-get ] |
+ RRS
+ [ RRS ]
+ [
+ [let | NAME [ QUERY name>> ]
+ TYPE [ QUERY type>> ]
+ CLASS [ QUERY class>> ] |
+
+ [let | RRS/CNAME [ T{ query f NAME CNAME CLASS } cache-get ] |
+
+ RRS/CNAME f =
+ [ f ]
+ [
+ [let | RR/CNAME [ RRS/CNAME first ] |
+
+ [let | REAL-NAME [ RR/CNAME rdata>> ] |
+
+ [let | RRS [
+ T{ query f REAL-NAME TYPE CLASS } query->rrs
+ ] |
+
+ RRS
+ [ RRS/CNAME RRS append ]
+ [ f ]
+ if
+ ] ] ]
+ ]
+ if
+ ] ]
+ ]
+ if
+ ] ;
+
+:: answer-from-cache ( MSG -- msg/f )
+ [let | QUERY [ MSG message-query ] |
+
+ [let | NX [ QUERY name>> non-existent-name? ]
+ RRS [ QUERY query->rrs ] |
+
+ {
+ { [ NX ] [ MSG NAME-ERROR >>rcode ] }
+ { [ RRS ] [ MSG RRS >>answer-section ] }
+ { [ t ] [ f ] }
+ }
+ cond
+ ]
+ ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: (upstream-server) ( -- vec ) V{ f } ;
-
-: upstream-server ( -- ip ) (upstream-server) 1st ;
-
-: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
-
-: init-upstream-server ( -- )
- upstream-server not
- [ resolv-conf-server set-upstream-server ]
- when ;
+: message-soa ( message -- rr/soa )
+ authority-section>> [ type>> SOA = ] filter first ;
+
+! :: cache-message ( MSG -- msg )
+! MSG rcode>> NAME-ERROR =
+! [
+! [let | NAME [ MSG message-query name>> ]
+! TTL [ MSG message-soa ttl>> ] |
+! NAME TTL cache-non-existent-name
+! ]
+! ]
+! when
+! MSG answer-section>> [ cache-add ] each
+! MSG authority-section>> [ cache-add ] each
+! MSG additional-section>> [ cache-add ] each
+! MSG ;
+
+:: cache-message ( MSG -- msg )
+ MSG rcode>> NAME-ERROR =
+ [
+ [let | RR/SOA [ MSG
+ authority-section>>
+ [ type>> SOA = ] filter
+ dup empty? [ drop f ] [ first ] if ] |
+ RR/SOA
+ [
+ [let | NAME [ MSG message-query name>> ]
+ TTL [ MSG message-soa ttl>> ] |
+ NAME TTL cache-non-existent-name
+ ]
+ ]
+ when
+ ]
+ ]
+ when
+ MSG answer-section>> [ cache-add ] each
+ MSG authority-section>> [ cache-add ] each
+ MSG additional-section>> [ cache-add ] each
+ MSG ;
+
+! : answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
+
+: answer-from-server ( msg servers -- msg ) ask-servers cache-message ;
+
+:: find-answer ( MSG SERVERS -- msg )
+ { [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
+:: start-server ( ADDR-SPEC SERVERS -- )
+
+ [let | SOCKET [ ADDR-SPEC <datagram> ] |
-: query->answer/cache ( query -- rrs/NX/f )
- dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
- [ nip ]
[
- drop
- dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
- [ nip ]
- [ ! query rrs
- tuck ! rrs query rrs
- 1st ! rrs query rr/cname
- rdata>> ! rrs query name
- >r clone r> >>name ! rrs query
- query->answer/cache ! rrs rrs/NX/f
- dup rrs? [ append ] [ nip ] if
- ]
- if
+ SOCKET receive-packet
+ [ parse-message SERVERS find-answer message->ba ]
+ change-data
+ respond
]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: answer-from-cache ( message -- message/f )
- dup message-query ! message query
- dup query->answer/cache ! message query rrs/NX/f
- {
- { [ dup f = ] [ 3drop f ] }
- { [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] }
- { [ t ] [ nip >>answer-section ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: answer-from-server ( message -- message )
- upstream-server ask-server
- cache-message ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: find-answer ( message -- message )
- dup answer-from-cache dup
- [ nip ]
- [ drop answer-from-server ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: loop ( -- )
- socket receive ! byte-array addr-spec
- swap ! addr-spec byte-array
- parse-message ! addr-spec message
- find-answer ! addr-spec message
- message->ba ! addr-spec byte-array
- swap ! byte-array addr-spec
- socket send
- loop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start ( -- ) init-socket init-upstream-server loop ;
+ forever
-MAIN: start
\ No newline at end of file
+ ] ;
+++ /dev/null
-
-USING: kernel continuations
- combinators
- sequences
- math
- random
- unicode.case
- accessors symbols
- combinators.lib combinators.cleave
- newfx
- dns dns.cache ;
-
-IN: dns.recursive
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: root-dns-servers ( -- servers )
- {
- "192.5.5.241"
- "192.112.36.4"
- "128.63.2.53"
- "192.36.148.17"
- "192.58.128.30"
- "193.0.14.129"
- "199.7.83.42"
- "202.12.27.33"
- "198.41.0.4"
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: {name-type-class} ( obj -- seq )
- [ name>> >lower ] [ type>> ] [ class>> ] tri {3} ;
-
-: rr=query? ( rr query -- ? ) [ {name-type-class} ] bi@ = ;
-
-: rr-filter ( rrs query -- rrs ) [ rr=query? ] curry filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: answer-hits ( message -- rrs )
- [ answer-section>> ] [ message-query ] bi rr-filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: name-hits ( message -- rrs )
- [ answer-section>> ] [ message-query clone A >>type ] bi rr-filter ;
-
-: cname-hits ( message -- rrs )
- [ answer-section>> ] [ message-query clone CNAME >>type ] bi rr-filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: authority-hits ( message -- rrs )
- authority-section>> [ type>> NS = ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: ANSWERED NO-NAME-SERVERS UNCLASSIFIED ;
-
-: classify-message ( message -- symbol )
- {
- { [ dup rcode>> NAME-ERROR = ] [ drop NAME-ERROR ] }
- { [ dup rcode>> SERVER-FAILURE = ] [ drop SERVER-FAILURE ] }
- { [ dup answer-hits empty? not ] [ drop ANSWERED ] }
- { [ dup cname-hits empty? not ] [ drop CNAME ] }
- { [ dup authority-hits empty? ] [ drop NO-NAME-SERVERS ] }
- { [ t ] [ drop UNCLASSIFIED ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: name->ip
-
-! : name->ip/f ( name -- ip/f ) [ name->ip ] [ drop f ] recover ;
-
-! : extract-ns-ips ( message -- ips )
-! authority-hits [ rdata>> name->ip/f ] map [ ] filter ;
-
-: extract-ns-ips ( message -- ips )
- authority-hits [ rdata>> name->ip ] map [ ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (recursive-query) ( query servers -- message )
- dup random ! query servers server
- pick query->message 0 >>rd ! query servers server message
- over ask-server ! query servers server message
- cache-message ! query servers server message
- dup classify-message ! query servers server message sym
- {
- { NAME-ERROR [ -roll 3drop ] }
- { ANSWERED [ -roll 3drop ] }
- { CNAME [ -roll 3drop ] }
- { NO-NAME-SERVERS [ -roll 3drop ] }
- {
- SERVER-FAILURE
- [
- -roll ! message query servers server
- remove ! message query servers
- dup empty?
- [ 2drop ]
- [ rot drop (recursive-query) ]
- if
- ]
- }
- [ ! query servers server message sym
- drop nip nip ! query message
- extract-ns-ips ! query ips
- (recursive-query)
- ]
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
-
-: cache-get-ns ( name -- seq/f ) NS IN query boa cache-get ;
-
-: name->servers ( name -- servers )
- {
- { [ dup "" = ] [ drop root-dns-servers ] }
- { [ dup cache-get-ns ] [ cache-get-ns [ rdata>> name->ip ] map ] }
- { [ t ] [ cdr-name name->servers ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: recursive-query ( query -- message )
- dup name>> name->servers (recursive-query) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: canonical/cache ( name -- name )
- dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ;
-
-: name->ip/cache ( name -- ip/f )
- canonical/cache
- A IN query boa cache-get dup [ random rdata>> ] [ ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: name-hits? ( message -- message ? ) dup name-hits empty? not ;
-: cname-hits? ( message -- message ? ) dup cname-hits empty? not ;
-
-! : name->ip/server ( name -- ip-or-f )
-! A IN query boa root-dns-servers recursive-query ! message
-! {
-! { [ name-hits? ] [ name-hits random rdata>> ] }
-! { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
-! { [ t ] [ drop f ] }
-! }
-! cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: name->ip/server ( name -- ip-or-f )
- A IN query boa recursive-query ! message
- {
- { [ name-hits? ] [ name-hits random rdata>> ] }
- { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
- { [ t ] [ drop f ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! : name->ip ( name -- ip )
-! { [ name->ip/cache ] [ name->ip/server ] [ name-error ] } 1|| ;
-
-: name->ip ( name -- ip )
- dup name->ip/cache dup
- [ nip ]
- [
- drop dup name->ip/server dup
- [ nip ]
- [ drop name-error ]
- if
- ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-USING: kernel vectors sequences combinators random
- accessors newfx dns dns.cache ;
+USING: kernel accessors namespaces continuations
+ io io.sockets io.binary io.timeouts io.encodings.binary
+ destructors
+ locals strings sequences random prettyprint calendar dns dns.misc ;
IN: dns.resolver
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: canonical/cache ( name -- name )
- dup CNAME IN query boa cache-get dup vector? ! name result ?
- [ nip 1st rdata>> ]
- [ drop ]
- if ;
-
-: name->ip/cache ( name -- ip )
- canonical/cache
- dup A IN query boa cache-get ! name result
- {
- { [ dup NX = ] [ 2drop f ] }
- { [ dup f = ] [ 2drop f ] }
- { [ t ] [ nip random rdata>> ] }
- }
- cond ;
+:: send-receive-udp ( BA SERVER -- ba )
+ T{ inet4 f f 0 } <datagram>
+ T{ duration { second 3 } } over set-timeout
+ [| SOCKET | BA SERVER SOCKET send SOCKET receive drop ]
+ with-disposal ;
+
+:: send-receive-tcp ( BA SERVER -- ba )
+ [let | BA [ BA length 2 >be BA append ] |
+ SERVER binary
+ [
+ T{ duration { second 3 } } input-stream get set-timeout
+ BA write flush 2 read be> read
+ ]
+ with-client ] ;
+
+:: send-receive-server ( BA SERVER -- msg )
+ [let | RESULT [ BA SERVER send-receive-udp parse-message ] |
+ RESULT tc>> 1 =
+ [ BA SERVER send-receive-tcp parse-message ]
+ [ RESULT ]
+ if ] ;
+
+: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 <inet4> ] [ ] if ;
+
+:: send-receive-servers ( BA SERVERS -- msg )
+ SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when
+ [let | SERVER [ SERVERS random >dns-inet4 ] |
+ ! if this throws an error ...
+ [ BA SERVER send-receive-server ]
+ ! we try with the other servers...
+ [ drop BA SERVER SERVERS remove send-receive-servers ]
+ recover ] ;
+
+:: ask-servers ( MSG SERVERS -- msg )
+ MSG message->ba SERVERS send-receive-servers ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: canonical/server ( name -- name )
- dup CNAME IN query boa query->message ask cache-message answer-section>>
- [ type>> CNAME = ] filter dup empty? not
- [ nip 1st rdata>> ]
- [ drop ]
- if ;
-
-: name->ip/server ( name -- ip )
- canonical/server
- dup A IN query boa query->message ask cache-message answer-section>>
- [ type>> A = ] filter dup empty? not
- [ nip random rdata>> ]
- [ 2drop f ]
- if ;
+: dns-servers ( -- seq )
+ \ dns-servers get
+ [ ]
+ [ resolv-conf-servers \ dns-servers set dns-servers ]
+ if* ;
+
+! : dns-server ( -- server ) dns-servers random ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: name->ip ( name -- ip )
+: dns-ip4 ( name -- ips )
fully-qualified
- dup name->ip/cache dup
- [ nip ]
- [ drop name->ip/server ]
- if ;
+ [let | MSG [ A IN query boa query->message dns-servers ask-servers ] |
+ MSG rcode>> NO-ERROR =
+ [ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ]
+ [ "dns-ip: rcode = " MSG rcode>> unparse append throw ]
+ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
3array " " join ;
: directory-list ( -- seq )
- "" directory keys
+ "" directory-files
[ [ link-info ] keep file-info>string ] map ;
--- /dev/null
+unportable
--- /dev/null
+unportable
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
+USING: help.markup help.syntax kernel sequences strings ;
IN: hexdump
HELP: hexdump.
-{ $values { "sequence" "a sequence" } }
+{ $values { "seq" sequence } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time and writes it to standard out." } ;
HELP: hexdump
-{ $values { "sequence" "a sequence" } { "string" "a string" } }
+{ $values { "seq" sequence } { "str" string } }
{ $description "Converts a sequence to its hexadecimal and ASCII representation sixteen characters at a time. Lines are separated by a newline character." }
{ $see-also hexdump. } ;
<PRIVATE
-: header. ( len -- )
- "Length: " write dup unparse write ", " write >hex write "h" write nl ;
+: write-header ( len -- )
+ "Length: " write
+ [ unparse write ", " write ]
+ [ >hex write "h" write nl ] bi ;
-: offset. ( lineno -- )
+: write-offset ( lineno -- )
16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
-: h-pad. ( digit -- )
+: write-hex-digit ( digit -- )
>hex 2 CHAR: 0 pad-left write ;
-: line. ( str n -- )
- offset.
- dup [ h-pad. " " write ] each
+: write-hex-line ( str n -- )
+ write-offset
+ dup [ write-hex-digit bl ] each
16 over length - 3 * CHAR: \s <string> write
[ dup printable? [ drop CHAR: . ] unless write1 ] each
nl ;
PRIVATE>
-: hexdump ( sequence -- string )
+: hexdump ( seq -- str )
[
- dup length header.
- 16 <sliced-groups> [ line. ] each-index
+ [ length write-header ]
+ [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi
] with-string-writer ;
-: hexdump. ( sequence -- )
- hexdump write ;
+: hexdump. ( seq -- ) hexdump write ;
USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle unicode.case namespaces make
splitting http accessors io combinators http.client urls
-urls.encoding fry ;
+urls.encoding fry prettyprint ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
'[ _ [ second @ ] find-from rot drop swap 1+ ]
[ f 0 ] 2dip times drop first2 ; inline
-: find-first-name ( str vector -- i/f tag/f )
- [ >lower ] dip [ name>> = ] with find ; inline
+: find-first-name ( vector string -- i/f tag/f )
+ >lower '[ name>> _ = ] find ; inline
-: find-matching-close ( str vector -- i/f tag/f )
- [ >lower ] dip
- [ [ name>> = ] [ closing?>> ] bi and ] with find ; inline
+: find-matching-close ( vector string -- i/f tag/f )
+ >lower
+ '[ [ name>> _ = ] [ closing?>> ] bi and ] find ; inline
-: find-between* ( i/f tag/f vector -- vector )
- pick integer? [
- rot tail-slice
- >r name>> r>
- [ find-matching-close drop dup [ 1+ ] when ] keep
- swap [ head ] [ first ] if*
+: find-between* ( vector i/f tag/f -- vector )
+ over integer? [
+ [ tail-slice ] [ name>> ] bi*
+ dupd find-matching-close drop dup [ 1+ ] when
+ [ head ] [ first ] if*
] [
3drop V{ } clone
] if ; inline
-
-: find-between ( i/f tag/f vector -- vector )
+
+: find-between ( vector i/f tag/f -- vector )
find-between* dup length 3 >= [
[ rest-slice but-last-slice ] keep like
] when ; inline
-: find-between-first ( string vector -- vector' )
- [ find-first-name ] keep find-between ; inline
+: find-between-first ( vector string -- vector' )
+ dupd find-first-name find-between ; inline
: find-between-all ( vector quot -- seq )
- [ [ [ closing?>> not ] bi and ] curry find-all ] curry
- [ [ >r first2 r> find-between* ] curry map ] bi ; inline
-
+ dupd
+ '[ _ [ closing?>> not ] bi and ] find-all
+ [ first2 find-between* ] with map ;
: remove-blank-text ( vector -- vector' )
[
[ [ [ blank? ] trim ] change-text ] when
] map ;
-: find-by-id ( id vector -- vector )
- [ attributes>> "id" swap at = ] with filter ;
-
-: find-by-class ( id vector -- vector )
- [ attributes>> "class" swap at = ] with filter ;
-
-: find-by-name ( str vector -- vector )
- [ >lower ] dip [ name>> = ] with filter ;
+: find-by-id ( vector id -- vector' )
+ '[ attributes>> "id" at _ = ] find ;
+
+: find-by-class ( vector id -- vector' )
+ '[ attributes>> "class" at _ = ] find ;
-: find-by-attribute-key ( key vector -- vector )
- [ >lower ] dip
- [ attributes>> at ] with filter
- sift ;
+: find-by-name ( vector string -- vector )
+ >lower '[ name>> _ = ] find ;
-: find-by-attribute-key-value ( value key vector -- vector )
- [ >lower ] dip
+: find-by-id-between ( vector string -- vector' )
+ dupd
+ '[ attributes>> "id" swap at _ = ] find find-between* ;
+
+: find-by-class-between ( vector string -- vector' )
+ dupd
+ '[ attributes>> "class" swap at _ = ] find find-between* ;
+
+: find-by-class-id-between ( vector class id -- vector' )
+ '[
+ [ attributes>> "class" swap at _ = ]
+ [ attributes>> "id" swap at _ = ] bi and
+ ] dupd find find-between* ;
+
+: find-by-attribute-key ( vector key -- vector' )
+ >lower
+ [ attributes>> at _ = ] filter sift ;
+
+: find-by-attribute-key-value ( vector value key -- vector' )
+ >lower
[ attributes>> at over = ] with filter nip
sift ;
-: find-first-attribute-key-value ( value key vector -- i/f tag/f )
- [ >lower ] dip
+: find-first-attribute-key-value ( vector value key -- i/f tag/f )
+ >lower
[ attributes>> at over = ] with find rot drop ;
: tag-link ( tag -- link/f )
swap [ >r first2 r> find-between* ] curry map
[ [ name>> { "form" "input" } member? ] filter ] map ;
-: find-html-objects ( string vector -- vector' )
- [ find-opening-tags-by-name ] keep
- [ [ first2 ] dip find-between* ] curry map ;
+: find-html-objects ( vector string -- vector' )
+ dupd find-opening-tags-by-name
+ [ first2 find-between* ] curry map ;
: form-action ( vector -- string )
[ name>> "form" = ] find nip
: query>assoc* ( str -- hash )
"?" split1 nip query>assoc ;
+
+: html-class? ( tag string -- ? )
+ swap attributes>> "class" swap at = ;
+
+: html-id? ( tag string -- ? )
+ swap attributes>> "id" swap at = ;
+
+: opening-tag? ( tag -- ? )
+ closing?>> not ;
TUPLE: directory-iterator path bfs queue ;
: qualified-directory ( path -- seq )
- dup directory [ first2 [ append-path ] dip 2array ] with map ;
+ dup directory-files [ append-path ] with map ;
: push-directory ( path iter -- )
[ qualified-directory ] dip [
: next-file ( iter -- file/f )
dup queue>> deque-empty? [ drop f ] [
- dup queue>> pop-back first2
+ dup queue>> pop-back dup link-info directory?
[ over push-directory next-file ] [ nip ] if
] if ;
{ $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } }
{ $description "Registers " { $snippet "irc-chat" } " with " { $snippet "irc-client" } " and starts listening." } ;
-HELP: dettach-chat "Stop an unregister chat"
-{ $values { "irc-chat" "an irc chat object" } { "irc-client" "an irc client object" } }
+HELP: detach-chat "Stop an unregister chat"
+{ $values { "irc-chat" "an irc chat object" } }
{ $description "Unregisters " { $snippet "irc-chat" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ;
HELP: terminate-irc "Terminates an irc client"
{ $subsection connect-irc }
{ $subsection terminate-irc }
{ $subsection attach-chat }
-{ $subsection dettach-chat }
+{ $subsection detach-chat }
{ $subsection hear }
{ $subsection speak }
{ $heading "IRC messages" }
{ $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server."
{ $table
- { { $link irc-chat-end } "sent to a chat when it has been dettached from the client, the chat should stop after it receives this message. " }
+ { { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " }
{ { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." }
{ { $link irc-disconnected } " sent to notify chats that connection was lost." }
{ { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } }
}
;
-ABOUT: "irc.client"
\ No newline at end of file
+ABOUT: "irc.client"
TUPLE: irc-client profile stream in-messages out-messages
chats is-running nick connect reconnect-time is-ready ;
+
: <irc-client> ( profile -- irc-client )
- [ f <mailbox> <mailbox> H{ } clone f ] keep nickname>>
- [ <inet> latin1 <client> ] 15 seconds f irc-client boa ;
+ irc-client new
+ swap >>profile
+ <mailbox> >>in-messages
+ <mailbox> >>out-messages
+ H{ } clone >>chats
+ dup profile>> nickname>> >>nick
+ [ <inet> latin1 <client> ] >>connect
+ 15 seconds >>reconnect-time ;
TUPLE: irc-chat in-messages client ;
TUPLE: irc-server-chat < irc-chat ;
: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
-: dettach-chat ( irc-chat -- )
+: detach-chat ( irc-chat -- )
[ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
: speak ( message irc-chat -- )
arrays classes.tuple math.order ;
RENAME: join sequences => sjoin
EXCLUDE: sequences => join ;
-EXCLUDE: inverse => _ ;
IN: irc.messages
TUPLE: irc-message line prefix command parameters trailing timestamp ;
TUPLE: unhandled < irc-message ;
: <irc-client-message> ( command parameters trailing -- irc-message )
- irc-message new now >>timestamp
- [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
+ irc-message new
+ now >>timestamp
+ swap >>trailing
+ swap >>parameters
+ swap >>command ;
<PRIVATE
GENERIC: command-string>> ( irc-message -- string )
-M: irc-message command-string>> command>> ;
-M: ping command-string>> drop "PING" ;
-M: join command-string>> drop "JOIN" ;
-M: part command-string>> drop "PART" ;
-M: quit command-string>> drop "QUIT" ;
-M: nick command-string>> drop "NICK" ;
-M: privmsg command-string>> drop "PRIVMSG" ;
-M: notice command-string>> drop "NOTICE" ;
-M: mode command-string>> drop "MODE" ;
-M: kick command-string>> drop "KICK" ;
+M: irc-message command-string>> ( irc-message -- string ) command>> ;
+M: ping command-string>> ( ping -- string ) drop "PING" ;
+M: join command-string>> ( join -- string ) drop "JOIN" ;
+M: part command-string>> ( part -- string ) drop "PART" ;
+M: quit command-string>> ( quit -- string ) drop "QUIT" ;
+M: nick command-string>> ( nick -- string ) drop "NICK" ;
+M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
+M: notice command-string>> ( notice -- string ) drop "NOTICE" ;
+M: mode command-string>> ( mode -- string ) drop "MODE" ;
+M: kick command-string>> ( kick -- string ) drop "KICK" ;
GENERIC: command-parameters>> ( irc-message -- seq )
-M: irc-message command-parameters>> parameters>> ;
-M: ping command-parameters>> drop { } ;
-M: join command-parameters>> drop { } ;
-M: part command-parameters>> channel>> 1array ;
-M: quit command-parameters>> drop { } ;
-M: nick command-parameters>> drop { } ;
-M: privmsg command-parameters>> name>> 1array ;
-M: notice command-parameters>> type>> 1array ;
-M: kick command-parameters>> [ channel>> ] [ who>> ] bi 2array ;
-M: mode command-parameters>> [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
-
-GENERIC: (>>command-parameters) ( params irc-message -- )
-
-M: irc-message (>>command-parameters) 2drop ;
-M: logged-in (>>command-parameters) [ first ] dip (>>name) ;
-M: privmsg (>>command-parameters) [ first ] dip (>>name) ;
-M: notice (>>command-parameters) [ first ] dip (>>type) ;
-M: part (>>command-parameters) [ first ] dip (>>channel) ;
-M: nick-in-use (>>command-parameters) [ second ] dip (>>name) ;
-M: kick (>>command-parameters)
- [ first2 ] dip [ (>>who) ] [ (>>channel) ] bi ;
-M: names-reply (>>command-parameters)
- [ [ first ] dip (>>who) ] [ [ third ] dip (>>channel) ] 2bi ;
-M: mode (>>command-parameters)
- { { [ >r 2array r> ] [ [ (>>mode) ] [ (>>name) ] bi ] }
- { [ >r 3array r> ] [ [ (>>parameter) ] [ (>>mode) ] [ (>>name) ] tri ] }
- } switch ;
+M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
+M: ping command-parameters>> ( ping -- seq ) drop { } ;
+M: join command-parameters>> ( join -- seq ) drop { } ;
+M: part command-parameters>> ( part -- seq ) channel>> 1array ;
+M: quit command-parameters>> ( quit -- seq ) drop { } ;
+M: nick command-parameters>> ( nick -- seq ) drop { } ;
+M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ;
+M: notice command-parameters>> ( norice -- seq ) type>> 1array ;
+M: kick command-parameters>> ( kick -- seq )
+ [ channel>> ] [ who>> ] bi 2array ;
+M: mode command-parameters>> ( mode -- seq )
+ [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
+
+GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
+
+M: irc-message >>command-parameters ( irc-message params -- irc-message )
+ drop ;
+
+M: logged-in >>command-parameters ( part params -- part )
+ first >>name ;
+
+M: privmsg >>command-parameters ( privmsg params -- privmsg )
+ first >>name ;
+
+M: notice >>command-parameters ( notice params -- notice )
+ first >>type ;
+
+M: part >>command-parameters ( part params -- part )
+ first >>channel ;
+
+M: kick >>command-parameters ( kick params -- kick )
+ first2 [ >>channel ] [ >>who ] bi* ;
+
+M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
+ second >>name ;
+
+M: names-reply >>command-parameters ( names-reply params -- names-reply )
+ first3 nip [ >>who ] [ >>channel ] bi* ;
+
+M: mode >>command-parameters ( mode params -- mode )
+ dup length 3 = [
+ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
+ ] [
+ first2 [ >>name ] [ >>mode ] bi*
+ ] if ;
PRIVATE>
GENERIC: irc-message>client-line ( irc-message -- string )
-M: irc-message irc-message>client-line
+M: irc-message irc-message>client-line ( irc-message -- string )
[ command-string>> ]
[ command-parameters>> " " sjoin ]
[ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
tri 3array " " sjoin ;
GENERIC: irc-message>server-line ( irc-message -- string )
-M: irc-message irc-message>server-line drop "not implemented yet" ;
+
+M: irc-message irc-message>server-line ( irc-message -- string )
+ drop "not implemented yet" ;
<PRIVATE
+
! ======================================
! Message parsing
! ======================================
: split-at-first ( seq separators -- before after )
dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
-: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+: remove-heading-: ( seq -- seq )
+ ":" ?head drop ;
: parse-name ( string -- string )
remove-heading-: "!" split-at-first drop ;
: split-prefix ( string -- string/f string )
dup ":" head?
- [ remove-heading-: " " split1 ]
- [ f swap ]
- if ;
+ [ remove-heading-: " " split1 ] [ f swap ] if ;
: split-trailing ( string -- string string/f )
":" split1 ;
-: copy-message-in ( origin dest -- )
- { [ [ parameters>> ] dip [ (>>command-parameters) ] [ (>>parameters) ] 2bi ]
- [ [ line>> ] dip (>>line) ]
- [ [ prefix>> ] dip (>>prefix) ]
- [ [ command>> ] dip (>>command) ]
- [ [ trailing>> ] dip (>>trailing) ]
- [ [ timestamp>> ] dip (>>timestamp) ]
- } 2cleave ;
+: copy-message-in ( command irc-message -- command )
+ {
+ [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
+ [ line>> >>line ]
+ [ prefix>> >>prefix ]
+ [ command>> >>command ]
+ [ trailing>> >>trailing ]
+ [ timestamp>> >>timestamp ]
+ } cleave ;
PRIVATE>
UNION: sender-in-prefix privmsg join part quit kick mode nick ;
GENERIC: irc-message-sender ( irc-message -- sender )
-M: sender-in-prefix irc-message-sender prefix>> parse-name ;
+M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
+ prefix>> parse-name ;
: string>irc-message ( string -- object )
dup split-prefix split-trailing
[ [ blank? ] trim " " split unclip swap ] dip
now irc-message boa ;
+: irc-message>command ( irc-message -- command )
+ [
+ command>> {
+ { "PING" [ ping ] }
+ { "NOTICE" [ notice ] }
+ { "001" [ logged-in ] }
+ { "433" [ nick-in-use ] }
+ { "353" [ names-reply ] }
+ { "JOIN" [ join ] }
+ { "PART" [ part ] }
+ { "NICK" [ nick ] }
+ { "PRIVMSG" [ privmsg ] }
+ { "QUIT" [ quit ] }
+ { "MODE" [ mode ] }
+ { "KICK" [ kick ] }
+ [ drop unhandled ]
+ } case new
+ ] keep copy-message-in ;
+
: parse-irc-line ( string -- message )
- string>irc-message
- dup command>> {
- { "PING" [ ping ] }
- { "NOTICE" [ notice ] }
- { "001" [ logged-in ] }
- { "433" [ nick-in-use ] }
- { "353" [ names-reply ] }
- { "JOIN" [ join ] }
- { "PART" [ part ] }
- { "NICK" [ nick ] }
- { "PRIVMSG" [ privmsg ] }
- { "QUIT" [ quit ] }
- { "MODE" [ mode ] }
- { "KICK" [ kick ] }
- [ drop unhandled ]
- } case new [ copy-message-in ] keep ;
+ string>irc-message irc-message>command ;
[ chat>> ] [ window>> client>> ] bi attach-chat ;\r
\r
M: irc-tab ungraft*\r
- chat>> dettach-chat ;\r
+ chat>> detach-chat ;\r
\r
TUPLE: irc-channel-tab < irc-tab userlist ;\r
\r
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Jamshred" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
+IN: jamshred.game
+
+TUPLE: jamshred sounds tunnel players running quit ;
+
+: <jamshred> ( -- jamshred )
+ <sounds> <random-tunnel> "Player 1" pick <player>
+ 2dup swap play-in-tunnel 1array f f jamshred boa ;
+
+: jamshred-player ( jamshred -- player )
+ ! TODO: support more than one player
+ players>> first ;
+
+: jamshred-update ( jamshred -- )
+ dup running>> [
+ jamshred-player update-player
+ ] [ drop ] if ;
+
+: toggle-running ( jamshred -- )
+ dup running>> [
+ f >>running drop
+ ] [
+ [ jamshred-player moved ]
+ [ t >>running drop ] bi
+ ] if ;
+
+: mouse-moved ( x-radians y-radians jamshred -- )
+ jamshred-player -rot turn-player ;
+
+: units-per-full-roll ( -- n ) 50 ;
+
+: jamshred-roll ( jamshred n -- )
+ [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
+
+: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
+
+: mouse-scroll-y ( jamshred y -- )
+ neg swap jamshred-player change-player-speed ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences float-arrays ;
+IN: jamshred.gl
+
+: min-vertices 6 ; inline
+: max-vertices 32 ; inline
+
+: n-vertices ( -- n ) 32 ; inline
+
+! render enough of the tunnel that it looks continuous
+: n-segments-ahead ( -- n ) 60 ; inline
+: n-segments-behind ( -- n ) 40 ; inline
+
+: wall-drawing-offset ( -- n )
+ #! so that we can't see through the wall, we draw it a bit further away
+ 0.15 ;
+
+: wall-drawing-radius ( segment -- r )
+ radius>> wall-drawing-offset + ;
+
+: wall-up ( segment -- v )
+ [ wall-drawing-radius ] [ up>> ] bi n*v ;
+
+: wall-left ( segment -- v )
+ [ wall-drawing-radius ] [ left>> ] bi n*v ;
+
+: segment-vertex ( theta segment -- vertex )
+ [
+ [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
+ ] [
+ location>> v+
+ ] bi ;
+
+: segment-vertex-normal ( vertex segment -- normal )
+ location>> swap v- normalize ;
+
+: segment-vertex-and-normal ( segment theta -- vertex normal )
+ swap [ segment-vertex ] keep dupd segment-vertex-normal ;
+
+: equally-spaced-radians ( n -- seq )
+ #! return a sequence of n numbers between 0 and 2pi
+ dup [ / pi 2 * * ] curry map ;
+
+: draw-segment-vertex ( segment theta -- )
+ over color>> set-color segment-vertex-and-normal
+ gl-normal gl-vertex ;
+
+: draw-vertex-pair ( theta next-segment segment -- )
+ rot tuck draw-segment-vertex draw-segment-vertex ;
+
+: draw-segment ( next-segment segment -- )
+ GL_QUAD_STRIP [
+ [ draw-vertex-pair ] 2curry
+ n-vertices equally-spaced-radians F{ 0.0 } append swap each
+ ] do-state ;
+
+: draw-segments ( segments -- )
+ 1 over length pick subseq swap [ draw-segment ] 2each ;
+
+: segments-to-render ( player -- segments )
+ dup nearest-segment>> number>> dup n-segments-behind -
+ swap n-segments-ahead + rot tunnel>> sub-tunnel ;
+
+: draw-tunnel ( player -- )
+ segments-to-render draw-segments ;
+
+: init-graphics ( width height -- )
+ GL_DEPTH_TEST glEnable
+ GL_SCISSOR_TEST glDisable
+ 1.0 glClearDepth
+ 0.0 0.0 0.0 0.0 glClearColor
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_PROJECTION glMatrixMode glLoadIdentity
+ dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
+ GL_MODELVIEW glMatrixMode glLoadIdentity
+ GL_LEQUAL glDepthFunc
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_FOG glEnable
+ GL_FOG_DENSITY 0.09 glFogf
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ GL_COLOR_MATERIAL glEnable
+ GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv
+ GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv
+ GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv
+ GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
+
+: player-view ( player -- )
+ [ location>> ]
+ [ [ location>> ] [ forward>> ] bi v+ ]
+ [ up>> ] tri gl-look-at ;
+
+: draw-jamshred ( jamshred width height -- )
+ init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;
+
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
+IN: jamshred
+
+TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
+
+: <jamshred-gadget> ( jamshred -- gadget )
+ jamshred-gadget new-gadget swap >>jamshred ;
+
+: default-width ( -- x ) 800 ;
+: default-height ( -- y ) 600 ;
+
+M: jamshred-gadget pref-dim*
+ drop default-width default-height 2array ;
+
+M: jamshred-gadget draw-gadget* ( gadget -- )
+ [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
+
+: jamshred-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ [ jamshred>> jamshred-update ]
+ [ relayout-1 ]
+ [ 10 sleep yield jamshred-loop ] tri
+ ] if ;
+
+: fullscreen ( gadget -- )
+ find-world t swap set-fullscreen* ;
+
+: no-fullscreen ( gadget -- )
+ find-world f swap set-fullscreen* ;
+
+: toggle-fullscreen ( world -- )
+ [ fullscreen? not ] keep set-fullscreen* ;
+
+M: jamshred-gadget graft* ( gadget -- )
+ [ jamshred-loop ] curry in-thread ;
+
+M: jamshred-gadget ungraft* ( gadget -- )
+ jamshred>> t swap (>>quit) ;
+
+: jamshred-restart ( jamshred-gadget -- )
+ <jamshred> >>jamshred drop ;
+
+: pix>radians ( n m -- theta )
+ / pi 4 * * ; ! 2 / / pi 2 * * ;
+
+: x>radians ( x gadget -- theta )
+ #! translate motion of x pixels to an angle
+ rect-dim first pix>radians neg ;
+
+: y>radians ( y gadget -- theta )
+ #! translate motion of y pixels to an angle
+ rect-dim second pix>radians ;
+
+: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
+ over jamshred>> >r
+ [ first swap x>radians ] 2keep second swap y>radians
+ r> mouse-moved ;
+
+: handle-mouse-motion ( jamshred-gadget -- )
+ hand-loc get [
+ over last-hand-loc>> [
+ v- (handle-mouse-motion)
+ ] [ 2drop ] if*
+ ] 2keep >>last-hand-loc drop ;
+
+: handle-mouse-scroll ( jamshred-gadget -- )
+ jamshred>> scroll-direction get
+ [ first mouse-scroll-x ]
+ [ second mouse-scroll-y ] 2bi ;
+
+: quit ( gadget -- )
+ [ no-fullscreen ] [ close-window ] bi ;
+
+jamshred-gadget H{
+ { T{ key-down f f "r" } [ jamshred-restart ] }
+ { T{ key-down f f " " } [ jamshred>> toggle-running ] }
+ { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
+ { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
+ { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
+ { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
+ { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
+ { T{ key-down f f "q" } [ quit ] }
+ { T{ motion } [ handle-mouse-motion ] }
+ { T{ mouse-scroll } [ handle-mouse-scroll ] }
+} set-gestures
+
+: jamshred-window ( -- gadget )
+ [ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
+
+MAIN: jamshred-window
--- /dev/null
+USING: kernel logging ;
+IN: jamshred.log
+
+LOG: (jamshred-log) DEBUG
+
+: with-jamshred-log ( quot -- )
+ "jamshred" swap with-logging ;
+
+: jamshred-log ( message -- )
+ [ (jamshred-log) ] with-jamshred-log ; ! ugly...
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
+[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
+[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
+[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
+[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+IN: jamshred.oint
+
+! An oint is a point with three linearly independent unit vectors
+! given relative to that point. In jamshred a player's location and
+! direction are given by the player's oint. Similarly, a tunnel
+! segment's location and orientation are given by an oint.
+
+TUPLE: oint location forward up left ;
+C: <oint> oint
+
+: rotation-quaternion ( theta axis -- quaternion )
+ swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
+
+: rotate-vector ( q qrecip v -- v )
+ v>q swap q* q* q>v ;
+
+: rotate-oint ( oint theta axis -- )
+ rotation-quaternion dup qrecip pick
+ [ forward>> rotate-vector >>forward ]
+ [ up>> rotate-vector >>up ]
+ [ left>> rotate-vector >>left ] 3tri drop ;
+
+: left-pivot ( oint theta -- )
+ over left>> rotate-oint ;
+
+: up-pivot ( oint theta -- )
+ over up>> rotate-oint ;
+
+: forward-pivot ( oint theta -- )
+ over forward>> rotate-oint ;
+
+: random-float+- ( n -- m )
+ #! find a random float between -n/2 and n/2
+ dup 10000 * >fixnum random 10000 / swap 2 / - ;
+
+: random-turn ( oint theta -- )
+ 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
+
+: location+ ( v oint -- )
+ [ location>> v+ ] [ (>>location) ] bi ;
+
+: go-forward ( distance oint -- )
+ [ forward>> n*v ] [ location+ ] bi ;
+
+: distance-vector ( oint oint -- vector )
+ [ location>> ] bi@ swap v- ;
+
+: distance ( oint oint -- distance )
+ distance-vector norm ;
+
+: scalar-projection ( v1 v2 -- n )
+ #! the scalar projection of v1 onto v2
+ tuck v. swap norm / ;
+
+: proj-perp ( u v -- w )
+ dupd proj v- ;
+
+: perpendicular-distance ( oint oint -- distance )
+ tuck distance-vector swap 2dup left>> scalar-projection abs
+ -rot up>> scalar-projection abs + ;
+
+:: reflect ( v n -- v' )
+ #! bounce v on a surface with normal n
+ v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+ over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+ [ location>> ] bi@ half-way ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ;
+IN: jamshred.player
+
+TUPLE: player < oint
+ { name string }
+ { sounds sounds }
+ tunnel
+ nearest-segment
+ { last-move integer }
+ { speed float } ;
+
+! speeds are in GL units / second
+: default-speed ( -- speed ) 1.0 ;
+: max-speed ( -- speed ) 30.0 ;
+
+: <player> ( name sounds -- player )
+ [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
+ f f 0 default-speed player boa ;
+
+: turn-player ( player x-radians y-radians -- )
+ >r over r> left-pivot up-pivot ;
+
+: roll-player ( player z-radians -- )
+ forward-pivot ;
+
+: to-tunnel-start ( player -- )
+ [ tunnel>> first dup location>> ]
+ [ tuck (>>location) (>>nearest-segment) ] bi ;
+
+: play-in-tunnel ( player segments -- )
+ >>tunnel to-tunnel-start ;
+
+: update-nearest-segment ( player -- )
+ [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
+ [ (>>nearest-segment) ] tri ;
+
+: update-time ( player -- seconds-passed )
+ millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
+
+: moved ( player -- ) millis swap (>>last-move) ;
+
+: speed-range ( -- range )
+ max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+ [ + speed-range clamp-to-range ] change-speed drop ;
+
+: multiply-player-speed ( n player -- )
+ [ * speed-range clamp-to-range ] change-speed drop ;
+
+: distance-to-move ( seconds-passed player -- distance )
+ speed>> * ;
+
+: bounce ( d-left player -- d-left' player )
+ {
+ [ dup nearest-segment>> bounce-off-wall ]
+ [ sounds>> bang ]
+ [ 3/4 swap multiply-player-speed ]
+ [ ]
+ } cleave ;
+
+:: (distance) ( heading player -- current next location heading )
+ player nearest-segment>>
+ player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+ player location>> heading ;
+
+: distance-to-heading-segment ( heading player -- distance )
+ (distance) distance-to-next-segment ;
+
+: distance-to-heading-segment-area ( heading player -- distance )
+ (distance) distance-to-next-segment-area ;
+
+: distance-to-collision ( player -- distance )
+ dup nearest-segment>> (distance-to-collision) ;
+
+: almost-to-collision ( player -- distance )
+ distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
+
+: from ( player -- radius distance-from-centre )
+ [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+ distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+ fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
+ ] [
+ 2drop
+ ] if ;
+
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+ [let* | d-to-move [ d-left distance min ]
+ move-v [ d-to-move heading n*v ] |
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ] ;
+
+: distance-to-move-freely ( player -- distance )
+ [ almost-to-collision ]
+ [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
+
+: ?move-player-freely ( d-left player -- d-left' player )
+ over 0 > [
+ ! must make sure we are moving a significant distance, otherwise
+ ! we can recurse endlessly due to floating-point imprecision.
+ ! (at least I /think/ that's what causes it...)
+ dup distance-to-move-freely dup 0.1 > [
+ over forward>> move-player-on-heading ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: drag-heading ( player -- heading )
+ [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+ [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+ ?move-player-freely over 0 > [
+ ! bounce
+ drag-player
+ (move-player)
+ ] when ;
+
+: move-player ( player -- )
+ [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
+
+: update-player ( player -- )
+ [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.files kernel openal sequences ;
+IN: jamshred.sound
+
+TUPLE: sounds bang ;
+
+: assign-sound ( source wav-path -- )
+ resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
+
+: <sounds> ( -- sounds )
+ init-openal 1 gen-sources first sounds boa
+ dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
+
+: bang ( sounds -- ) bang>> source-play check-error ;
--- /dev/null
+A simple 3d tunnel racing game
--- /dev/null
+applications
+games
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ;
+IN: jamshred.tunnel.tests
+
+[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
+ T{ segment f { 1 1 1 } f f f 1 }
+ T{ oint f { 0 0 0.25 } }
+ nearer-segment number>> ] unit-test
+
+[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+
+[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
+
+[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
+
+: test-segment-oint ( -- oint )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
+
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
+
+: simplest-straight-ahead ( -- oint segment )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
+
+: simple-collision-up ( -- oint segment )
+ { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
+[ { 0.0 1.0 0.0 } ]
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
+USE: tools.walker
+IN: jamshred.tunnel
+
+: n-segments ( -- n ) 5000 ; inline
+
+TUPLE: segment < oint number color radius ;
+C: <segment> segment
+
+: segment-number++ ( segment -- )
+ [ number>> 1+ ] keep (>>number) ;
+
+: random-color ( -- color )
+ { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
+
+: tunnel-segment-distance ( -- n ) 0.4 ;
+: random-rotation-angle ( -- theta ) pi 20 / ;
+
+: random-segment ( previous-segment -- segment )
+ clone dup random-rotation-angle random-turn
+ tunnel-segment-distance over go-forward
+ random-color >>color dup segment-number++ ;
+
+: (random-segments) ( segments n -- segments )
+ dup 0 > [
+ >r dup peek random-segment over push r> 1- (random-segments)
+ ] [ drop ] if ;
+
+: default-segment-radius ( -- r ) 1 ;
+
+: initial-segment ( -- segment )
+ F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
+ 0 random-color default-segment-radius <segment> ;
+
+: random-segments ( n -- segments )
+ initial-segment 1vector swap (random-segments) ;
+
+: simple-segment ( n -- segment )
+ [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
+ random-color default-segment-radius <segment> ;
+
+: simple-segments ( n -- segments )
+ [ simple-segment ] map ;
+
+: <random-tunnel> ( -- segments )
+ n-segments random-segments ;
+
+: <straight-tunnel> ( -- segments )
+ n-segments simple-segments ;
+
+: sub-tunnel ( from to segments -- segments )
+ #! return segments between from and to, after clamping from and to to
+ #! valid values
+ [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
+
+: nearer-segment ( segment segment oint -- segment )
+ #! return whichever of the two segments is nearer to the oint
+ >r 2dup r> tuck distance >r distance r> < -rot ? ;
+
+: (find-nearest-segment) ( nearest next oint -- nearest ? )
+ #! find the nearest of 'next' and 'nearest' to 'oint', and return
+ #! t if the nearest hasn't changed
+ pick >r nearer-segment dup r> = ;
+
+: find-nearest-segment ( oint segments -- segment )
+ dup first swap rest-slice rot [ (find-nearest-segment) ] curry
+ find 2drop ;
+
+: nearest-segment-forward ( segments oint start -- segment )
+ rot dup length swap <slice> find-nearest-segment ;
+
+: nearest-segment-backward ( segments oint start -- segment )
+ swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+
+: nearest-segment ( segments oint start-segment -- segment )
+ #! find the segment nearest to 'oint', and return it.
+ #! start looking at segment 'start-segment'
+ number>> over >r
+ [ nearest-segment-forward ] 3keep
+ nearest-segment-backward r> nearer-segment ;
+
+: get-segment ( segments n -- segment )
+ over sequence-index-range clamp-to-range swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+ number>> 1+ get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+ number>> 1- get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+ #! the next segment on the given heading
+ over forward>> v. 0 <=> {
+ { +gt+ [ next-segment ] }
+ { +lt+ [ previous-segment ] }
+ { +eq+ [ nip ] } ! current segment
+ } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+ [let | cf [ current forward>> ] |
+ cf next location>> v. cf location v. - cf heading v. / ] ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ [let | cf [ current forward>> ]
+ h [ next current half-way-between-oints ] |
+ cf h v. cf location v. - cf heading v. / ] ;
+
+: vector-to-centre ( seg loc -- v )
+ over location>> swap v- swap forward>> proj-perp ;
+
+: distance-from-centre ( seg loc -- distance )
+ vector-to-centre norm ;
+
+: wall-normal ( seg oint -- n )
+ location>> vector-to-centre normalize ;
+
+: distant ( -- n ) 1000 ;
+
+: max-real ( a b -- c )
+ #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ dup real? [
+ over real? [ max ] [ nip ] if
+ ] [
+ drop dup real? [ drop distant ] unless
+ ] if ;
+
+:: collision-coefficient ( v w r -- c )
+ v norm 0 = [
+ distant
+ ] [
+ [let* | a [ v dup v. ]
+ b [ v w v. 2 * ]
+ c [ w dup v. r sq - ] |
+ c b a quadratic max-real ]
+ ] if ;
+
+: sideways-heading ( oint segment -- v )
+ [ forward>> ] bi@ proj-perp ;
+
+: sideways-relative-location ( oint segment -- loc )
+ [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
+
+: (distance-to-collision) ( oint segment -- distance )
+ [ sideways-heading ] [ sideways-relative-location ]
+ [ nip radius>> ] 2tri collision-coefficient ;
+
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
+
+: bounce-forward ( segment oint -- )
+ [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-left ( segment oint -- )
+ #! must be done after forward
+ [ forward>> vneg ] dip [ left>> swap reflect ]
+ [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
+
+: bounce-up ( segment oint -- )
+ #! must be done after forward and left!
+ nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
+
+: bounce-off-wall ( oint segment -- )
+ swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.floating-point ;
+IN: math.floating-point.tests
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences ;
+IN: math.floating-point
+
+: float-sign ( float -- ? )
+ float>bits -31 shift { 1 -1 } nth ;
+
+: double-sign ( float -- ? )
+ double>bits -63 shift { 1 -1 } nth ;
+
+: float-exponent-bits ( float -- n )
+ float>bits -23 shift 8 2^ 1- bitand ;
+
+: double-exponent-bits ( double -- n )
+ double>bits -52 shift 11 2^ 1- bitand ;
+
+: float-mantissa-bits ( float -- n )
+ float>bits 23 2^ 1- bitand ;
+
+: double-mantissa-bits ( double -- n )
+ double>bits 52 2^ 1- bitand ;
+
+: float-e ( -- float ) 127 ; inline
+: double-e ( -- float ) 1023 ; inline
+
+! : calculate-float ( S M E -- float )
+ ! float-e - 2^ * * ; ! bits>float ;
+
+! : calculate-double ( S M E -- frac )
+ ! double-e - 2^ swap 52 2^ /f 1+ * * ;
+
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
{ $see-also roman* roman/i /mod } ;
+
+HELP: ROMAN:
+{ $description "A parsing word that reads the next token and converts it to an integer." } ;
[ "i" ] [ "iii" "ii" roman/i ] unit-test
[ "i" "ii" ] [ "v" "iii" roman/mod ] unit-test
[ "iii" "iii" roman- ] must-fail
+
+[ 30 ] [ ROMAN: xxx ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.order math.vectors
namespaces make quotations sequences sequences.lib
-sequences.private strings unicode.case ;
+sequences.private strings unicode.case lexer parser ;
IN: roman
<PRIVATE
+
: roman-digits ( -- seq )
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
] [
first2 swap -
] if ;
+
PRIVATE>
: >roman ( n -- str )
] map sum ;
<PRIVATE
+
: 2roman> ( str1 str2 -- m n )
[ roman> ] bi@ ;
: binary-roman-op ( str1 str2 quot -- str3 )
>r 2roman> r> call >roman ; inline
+
PRIVATE>
: roman+ ( str1 str2 -- str3 )
: roman/mod ( str1 str2 -- str3 str4 )
[ /mod ] binary-roman-op >r >roman r> ;
+
+: ROMAN: scan roman> parsed ; parsing
USING: combinators.lib kernel sequences math namespaces make
assocs random sequences.private shuffle math.functions arrays
math.parser math.private sorting strings ascii macros assocs.lib
-quotations hashtables math.order locals generalizations ;
+quotations hashtables math.order locals generalizations
+math.ranges random ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
: power-set ( seq -- subsets )
2 over length exact-number-strings swap [ switches ] curry map ;
-USE: continuations
-: ?subseq ( from to seq -- subseq )
- >r >r 0 max r> r>
- [ length tuck min >r min r> ] keep subseq ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
: attempt-each ( seq quot -- result )
(each) iterate-prep (attempt-each-integer) ; inline
-: ?nth* ( n seq -- elt/f ? )
- 2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-USE: math.ranges
-USE: random
: randomize ( seq -- seq' )
dup length 1 (a,b] [ dup random pick exchange ] each ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: enumerate ( seq -- seq' )
- <enum> >alist ;
+: enumerate ( seq -- seq' ) <enum> >alist ;
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 ;
+ combinators.short-circuit eval environment ;
IN: shell
METHOD: expand { glob-expr }
expr>>
dup "*" =
- [ drop current-directory get directory [ first ] map ]
+ [ drop current-directory get directory-files ]
[ ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MAIN: ix
\ No newline at end of file
+MAIN: ix
USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
-opengl multiline ui.gadgets accessors sequences ui.render ui math
-arrays generalizations combinators ;
+opengl multiline ui.gadgets accessors sequences ui.render ui math locals
+arrays generalizations combinators opengl.capabilities ui.gadgets.worlds ;
IN: spheres
STRING: plane-vertex-shader
3array <gl-program> check-gl-program ;
M: spheres-gadget graft* ( gadget -- )
+ dup find-gl-context
+ "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
+ { "GL_EXT_framebuffer_object" } require-gl-extensions
(plane-program) >>plane-program
(solid-sphere-program) >>solid-sphere-program
(texture-sphere-program) >>texture-sphere-program
drop ;
M: spheres-gadget ungraft* ( gadget -- )
+ dup find-gl-context
{
[ reflection-framebuffer>> [ delete-framebuffer ] when* ]
[ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
M: spheres-gadget pref-dim* ( gadget -- dim )
drop { 640 480 } ;
-
-: (draw-sphere) ( program center radius surfacecolor -- )
- roll
- [ [ "center" glGetAttribLocation swap first3 glVertexAttrib3f ] curry ]
- [ [ "radius" glGetAttribLocation swap glVertexAttrib1f ] curry ]
- [ [ "surface_color" glGetAttribLocation swap first4 glVertexAttrib4f ] curry ]
- tri tri*
+
+:: (draw-sphere) ( program center radius -- )
+ program "center" glGetAttribLocation center first3 glVertexAttrib3f
+ program "radius" glGetAttribLocation radius glVertexAttrib1f
{ -1.0 -1.0 } { 1.0 1.0 } rect-vertices ;
+
+:: (draw-colored-sphere) ( program center radius surfacecolor -- )
+ program "surface_color" glGetAttribLocation surfacecolor first4 glVertexAttrib4f
+ program center radius (draw-sphere) ;
: sphere-scene ( gadget -- )
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
solid-sphere-program>> [
{
[ "light_position" glGetUniformLocation 0.0 0.0 100.0 glUniform3f ]
- [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
- [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ]
- [ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ]
- [ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ]
- [ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-sphere) ]
- [ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-sphere) ]
+ [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-colored-sphere) ]
+ [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-colored-sphere) ]
+ [ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-colored-sphere) ]
+ [ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-colored-sphere) ]
+ [ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-colored-sphere) ]
+ [ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-colored-sphere) ]
} cleave
] with-gl-program
] [
[
texture-sphere-program>> [
[ "surface_texture" glGetUniformLocation 0 glUniform1i ]
- [ { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
+ [ { 0.0 0.0 0.0 } 4.0 (draw-sphere) ]
bi
] with-gl-program
]
--- /dev/null
+This is a simple tetris game. To play, open factor (in GUI mode), and run:
+
+"tetris" run
+
+This should open a new window with a running tetris game. The commands are:
+
+left, right arrows: move the current piece left or right
+up arrow: rotate the piece clockwise
+down arrow: lower the piece one row
+space bar: drop the piece
+p: pause/unpause
+n: start a new game
+
+TODO:
+- rotation of pieces when they're on the far right of the board
+- make blocks prettier
+- possibly make piece inherit from tetromino
--- /dev/null
+Alex Chapman
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: accessors arrays colors kernel tetris.board tetris.piece tools.test ;
+
+[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test
+[ { { f f } { f f } { f f } } ] [ 2 3 <board> rows>> ] unit-test
+[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
+[ f ] [ 2 3 <board> { 1 1 } block ] unit-test
+[ 2 3 <board> { 2 3 } block ] must-fail
+red 1array [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block ] unit-test
+[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
+[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test
+[ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
+[ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
+[ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
+[ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
+[ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
+[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test
+[ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
+[ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } >>location piece-valid? ] unit-test
+[ { { f } { f } } ] [ 1 1 <board> add-row rows>> ] unit-test
+[ { { f } } ] [ 1 2 <board> dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test
+[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel math sequences tetris.piece ;
+IN: tetris.board
+
+TUPLE: board { width integer } { height integer } rows ;
+
+: make-rows ( width height -- rows )
+ [ drop f <array> ] with map ;
+
+: <board> ( width height -- board )
+ 2dup make-rows board boa ;
+
+#! A block is simply an array of form { x y } where { 0 0 } is the top-left of
+#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board.
+
+: board@block ( board block -- n row )
+ [ second swap rows>> nth ] keep first swap ;
+
+: set-block ( board block colour -- ) -rot board@block set-nth ;
+
+: block ( board block -- colour ) board@block nth ;
+
+: block-free? ( board block -- ? ) block not ;
+
+: block-in-bounds? ( board block -- ? )
+ [ first swap width>> bounds-check? ] 2keep
+ second swap height>> bounds-check? and ;
+
+: location-valid? ( board block -- ? )
+ 2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
+
+: piece-valid? ( board piece -- ? )
+ piece-blocks [ location-valid? ] with all? ;
+
+: row-not-full? ( row -- ? ) f swap member? ;
+
+: add-row ( board -- board )
+ dup rows>> over width>> f <array> prefix >>rows ;
+
+: top-up-rows ( board -- )
+ dup height>> over rows>> length = [
+ drop
+ ] [
+ add-row top-up-rows
+ ] if ;
+
+: remove-full-rows ( board -- board )
+ [ [ row-not-full? ] filter ] change-rows ;
+
+: check-rows ( board -- n )
+ #! remove full rows, then add blank ones at the top, returning the number
+ #! of rows removed (and added)
+ remove-full-rows dup height>> over rows>> length - swap top-up-rows ;
+
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-ui? t }
+ { deploy-compiler? t }
+ { deploy-threads? t }
+ { deploy-word-props? f }
+ { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
+ { deploy-random? t }
+ { deploy-io 2 }
+ { deploy-math? t }
+ { deploy-word-defs? f }
+ { deploy-c-types? f }
+ { deploy-name "Tetris" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: accessors kernel tetris.game tetris.board tetris.piece tools.test
+sequences ;
+
+[ t ] [ <default-tetris> [ current-piece ] [ next-piece ] bi and t f ? ] unit-test
+[ t ] [ <default-tetris> { 1 1 } can-move? ] unit-test
+[ t ] [ <default-tetris> { 1 1 } tetris-move ] unit-test
+[ 1 ] [ <default-tetris> dup { 1 1 } tetris-move drop current-piece location>> second ] unit-test
+[ 1 ] [ <default-tetris> level>> ] unit-test
+[ 1 ] [ <default-tetris> 9 >>rows level>> ] unit-test
+[ 2 ] [ <default-tetris> 10 >>rows level>> ] unit-test
+[ 0 ] [ 3 0 rows-score ] unit-test
+[ 80 ] [ 1 1 rows-score ] unit-test
+[ 4800 ] [ 3 4 rows-score ] unit-test
+[ 1 ] [ <default-tetris> dup 3 score-rows dup 3 score-rows dup 3 score-rows level>> ] unit-test
+[ 2 ] [ <default-tetris> dup 4 score-rows dup 4 score-rows dup 2 score-rows level>> ] unit-test
+
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel lists math math.functions sequences system tetris.board tetris.piece tetris.tetromino ;
+IN: tetris.game
+
+TUPLE: tetris
+ { board board }
+ { pieces }
+ { last-update integer initial: 0 }
+ { rows integer initial: 0 }
+ { score integer initial: 0 }
+ { paused? initial: f }
+ { running? initial: t } ;
+
+: default-width 10 ; inline
+: default-height 20 ; inline
+
+: <tetris> ( width height -- tetris )
+ dupd <board> swap <piece-llist>
+ tetris new swap >>pieces swap >>board ;
+
+: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
+
+: <new-tetris> ( old -- new )
+ board>> [ width>> ] [ height>> ] bi <tetris> ;
+
+: current-piece ( tetris -- piece ) pieces>> car ;
+
+: next-piece ( tetris -- piece ) pieces>> cdr car ;
+
+: toggle-pause ( tetris -- )
+ [ not ] change-paused? drop ;
+
+: level>> ( tetris -- level )
+ rows>> 1+ 10 / ceiling ;
+
+: update-interval ( tetris -- interval )
+ level>> 1- 60 * 1000 swap - ;
+
+: add-block ( tetris block -- )
+ over board>> spin current-piece tetromino>> colour>> set-block ;
+
+: game-over? ( tetris -- ? )
+ [ board>> ] [ next-piece ] bi piece-valid? not ;
+
+: new-current-piece ( tetris -- tetris )
+ dup game-over? [
+ f >>running?
+ ] [
+ [ cdr ] change-pieces
+ ] if ;
+
+: rows-score ( level n -- score )
+ {
+ { 0 [ 0 ] }
+ { 1 [ 40 ] }
+ { 2 [ 100 ] }
+ { 3 [ 300 ] }
+ { 4 [ 1200 ] }
+ } case swap 1+ * ;
+
+: add-score ( tetris n-rows -- tetris )
+ over level>> swap rows-score swap [ + ] change-score ;
+
+: add-rows ( tetris rows -- tetris )
+ swap [ + ] change-rows ;
+
+: score-rows ( tetris n -- )
+ [ add-score ] keep add-rows drop ;
+
+: lock-piece ( tetris -- )
+ [ dup current-piece piece-blocks [ add-block ] with each ] keep
+ new-current-piece dup board>> check-rows score-rows ;
+
+: can-rotate? ( tetris -- ? )
+ [ board>> ] [ current-piece clone 1 rotate-piece ] bi piece-valid? ;
+
+: (rotate) ( inc tetris -- )
+ dup can-rotate? [ current-piece swap rotate-piece drop ] [ 2drop ] if ;
+
+: rotate-left ( tetris -- ) -1 swap (rotate) ;
+
+: rotate-right ( tetris -- ) 1 swap (rotate) ;
+
+: can-move? ( tetris move -- ? )
+ [ drop board>> ] [ [ current-piece clone ] dip move-piece ] 2bi piece-valid? ;
+
+: tetris-move ( tetris move -- ? )
+ #! moves the piece if possible, returns whether the piece was moved
+ 2dup can-move? [
+ >r current-piece r> move-piece drop t
+ ] [
+ 2drop f
+ ] if ;
+
+: move-left ( tetris -- ) { -1 0 } tetris-move drop ;
+
+: move-right ( tetris -- ) { 1 0 } tetris-move drop ;
+
+: move-down ( tetris -- )
+ dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
+
+: move-drop ( tetris -- )
+ dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
+
+: update ( tetris -- )
+ millis over last-update>> -
+ over update-interval > [
+ dup move-down
+ millis >>last-update
+ ] when drop ;
+
+: ?update ( tetris -- )
+ dup [ paused?>> ] [ running?>> not ] bi or [ drop ] [ update ] if ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators kernel math math.vectors namespaces opengl opengl.gl sequences tetris.board tetris.game tetris.piece ui.render tetris.tetromino ui.gadgets ;
+IN: tetris.gl
+
+#! OpenGL rendering for tetris
+
+: draw-block ( block -- )
+ dup { 1 1 } v+ gl-fill-rect ;
+
+: draw-piece-blocks ( piece -- )
+ piece-blocks [ draw-block ] each ;
+
+: draw-piece ( piece -- )
+ dup tetromino>> colour>> set-color draw-piece-blocks ;
+
+: draw-next-piece ( piece -- )
+ dup tetromino>> colour>>
+ clone 0.2 >>alpha set-color draw-piece-blocks ;
+
+! TODO: move implementation specific stuff into tetris-board
+: (draw-row) ( x y row -- )
+ >r over r> nth dup
+ [ set-color 2array draw-block ] [ 3drop ] if ;
+
+: draw-row ( y row -- )
+ dup length -rot [ (draw-row) ] 2curry each ;
+
+: draw-board ( board -- )
+ rows>> dup length swap
+ [ dupd nth draw-row ] curry each ;
+
+: scale-board ( width height board -- )
+ [ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
+
+: (draw-tetris) ( width height tetris -- )
+ #! width and height are in pixels
+ GL_MODELVIEW [
+ {
+ [ board>> scale-board ]
+ [ board>> draw-board ]
+ [ next-piece draw-next-piece ]
+ [ current-piece draw-piece ]
+ } cleave
+ ] do-matrix ;
+
+: draw-tetris ( width height tetris -- )
+ origin get [ (draw-tetris) ] with-translation ;
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: accessors kernel tetris.tetromino tetris.piece tools.test sequences arrays namespaces ;
+
+! Tests for tetris.tetromino and tetris.piece, since there's not much to test in tetris.tetromino
+
+! these two tests rely on the first rotation of the first tetromino being the
+! 'I' tetromino in its vertical orientation.
+[ 4 ] [ tetrominoes get first states>> first blocks-width ] unit-test
+[ 1 ] [ tetrominoes get first states>> first blocks-height ] unit-test
+
+[ { 0 0 } ] [ random-tetromino <piece> location>> ] unit-test
+[ 0 ] [ 10 <random-piece> rotation>> ] unit-test
+
+[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ]
+[ tetrominoes get first <piece> piece-blocks ] unit-test
+
+[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ]
+[ tetrominoes get first <piece> 1 rotate-piece piece-blocks ] unit-test
+
+[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ]
+[ tetrominoes get first <piece> { 1 1 } move-piece piece-blocks ] unit-test
+
+[ 3 ] [ tetrominoes get second <piece> piece-width ] unit-test
+[ 2 ] [ tetrominoes get second <piece> 1 rotate-piece piece-width ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel math math.vectors sequences tetris.tetromino lists.lazy ;
+IN: tetris.piece
+
+#! The rotation is an index into the tetromino's states array, and the
+#! position is added to the tetromino's blocks to give them their location on the
+#! tetris board. If the location is f then the piece is not yet on the board.
+
+TUPLE: piece
+ { tetromino tetromino }
+ { rotation integer initial: 0 }
+ { location array initial: { 0 0 } } ;
+
+: <piece> ( tetromino -- piece )
+ piece new swap >>tetromino ;
+
+: (piece-blocks) ( piece -- blocks )
+ #! rotates the piece
+ [ rotation>> ] [ tetromino>> states>> ] bi nth ;
+
+: piece-blocks ( piece -- blocks )
+ #! rotates and positions the piece
+ [ (piece-blocks) ] [ location>> ] bi [ v+ ] curry map ;
+
+: piece-width ( piece -- width )
+ piece-blocks blocks-width ;
+
+: set-start-location ( piece board-width -- piece )
+ over piece-width [ 2 /i ] bi@ - 0 2array >>location ;
+
+: <random-piece> ( board-width -- piece )
+ random-tetromino <piece> swap set-start-location ;
+
+: <piece-llist> ( board-width -- llist )
+ [ [ <random-piece> ] curry ] keep [ <piece-llist> ] curry lazy-cons ;
+
+: modulo ( n m -- n )
+ #! -2 7 mod => -2, -2 7 modulo => 5
+ tuck mod over + swap mod ;
+
+: (rotate-piece) ( rotation inc n-states -- rotation' )
+ [ + ] dip modulo ;
+
+: rotate-piece ( piece inc -- piece )
+ over tetromino>> states>> length
+ [ (rotate-piece) ] 2curry change-rotation ;
+
+: move-piece ( piece move -- piece )
+ [ v+ ] curry change-location ;
--- /dev/null
+Graphical Tetris game
--- /dev/null
+demos
+applications
+games
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alarms arrays calendar kernel make math math.geometry.rect math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ;
+IN: tetris
+
+TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ;
+
+: <tetris-gadget> ( tetris -- gadget )
+ tetris-gadget new-gadget swap >>tetris ;
+
+M: tetris-gadget pref-dim* drop { 200 400 } ;
+
+: update-status ( gadget -- )
+ dup tetris>> [
+ "Level: " % dup level>> #
+ " Score: " % score>> #
+ ] "" make swap show-status ;
+
+M: tetris-gadget draw-gadget* ( gadget -- )
+ [
+ dup rect-dim [ first ] [ second ] bi rot tetris>> draw-tetris
+ ] keep update-status ;
+
+: new-tetris ( gadget -- gadget )
+ [ <new-tetris> ] change-tetris ;
+
+tetris-gadget H{
+ { 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 ] }
+ { T{ key-down f f "e" } [ tetris>> rotate-left ] } ! dvorak d
+ { T{ key-down f f "u" } [ tetris>> rotate-right ] } ! dvorak f
+ { T{ key-down f f "LEFT" } [ tetris>> move-left ] }
+ { T{ key-down f f "RIGHT" } [ tetris>> move-right ] }
+ { T{ key-down f f "DOWN" } [ tetris>> move-down ] }
+ { T{ key-down f f " " } [ tetris>> move-drop ] }
+ { T{ key-down f f "p" } [ tetris>> toggle-pause ] }
+ { T{ key-down f f "n" } [ new-tetris drop ] }
+} set-gestures
+
+: tick ( gadget -- )
+ [ tetris>> ?update ] [ relayout-1 ] bi ;
+
+M: tetris-gadget graft* ( gadget -- )
+ [ [ tick ] curry 100 milliseconds every ] keep (>>alarm) ;
+
+M: tetris-gadget ungraft* ( gadget -- )
+ [ cancel-alarm f ] change-alarm drop ;
+
+: tetris-window ( -- )
+ [
+ <default-tetris> <tetris-gadget>
+ "Tetris" open-status-window
+ ] with-ui ;
+
+MAIN: tetris-window
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays namespaces sequences math math.vectors
+colors random ;
+IN: tetris.tetromino
+
+TUPLE: tetromino states colour ;
+
+C: <tetromino> tetromino
+
+SYMBOL: tetrominoes
+
+{
+ [
+ { {
+ { 0 0 } { 1 0 } { 2 0 } { 3 0 }
+ }
+ { { 0 0 }
+ { 0 1 }
+ { 0 2 }
+ { 0 3 }
+ }
+ } cyan
+ ] [
+ {
+ { { 1 0 }
+ { 0 1 } { 1 1 } { 2 1 }
+ } {
+ { 0 0 }
+ { 0 1 } { 1 1 }
+ { 0 2 }
+ } {
+ { 0 0 } { 1 0 } { 2 0 }
+ { 1 1 }
+ } {
+ { 1 0 }
+ { 0 1 } { 1 1 }
+ { 1 2 }
+ }
+ } purple
+ ] [
+ { { { 0 0 } { 1 0 }
+ { 0 1 } { 1 1 } }
+ } yellow
+ ] [
+ {
+ { { 0 0 } { 1 0 } { 2 0 }
+ { 0 1 }
+ } {
+ { 0 0 } { 1 0 }
+ { 1 1 }
+ { 1 2 }
+ } {
+ { 2 0 }
+ { 0 1 } { 1 1 } { 2 1 }
+ } {
+ { 0 0 }
+ { 0 1 }
+ { 0 2 } { 1 2 }
+ }
+ } orange
+ ] [
+ {
+ { { 0 0 } { 1 0 } { 2 0 }
+ { 2 1 }
+ } {
+ { 1 0 }
+ { 1 1 }
+ { 0 2 } { 1 2 }
+ } {
+ { 0 0 }
+ { 0 1 } { 1 1 } { 2 1 }
+ } {
+ { 0 0 } { 1 0 }
+ { 0 1 }
+ { 0 2 }
+ }
+ } blue
+ ] [
+ {
+ { { 1 0 } { 2 0 }
+ { 0 1 } { 1 1 }
+ } {
+ { 0 0 }
+ { 0 1 } { 1 1 }
+ { 1 2 }
+ }
+ } green
+ ] [
+ {
+ {
+ { 0 0 } { 1 0 }
+ { 1 1 } { 2 1 }
+ } {
+ { 1 0 }
+ { 0 1 } { 1 1 }
+ { 0 2 }
+ }
+ } red
+ ]
+} [ call <tetromino> ] map tetrominoes set-global
+
+: random-tetromino ( -- tetromino )
+ tetrominoes get random ;
+
+: blocks-max ( blocks quot -- max )
+ map [ 1+ ] map supremum ; inline
+
+: blocks-width ( blocks -- width )
+ [ first ] blocks-max ;
+
+: blocks-height ( blocks -- height )
+ [ second ] blocks-max ;
+
! Deployment example
USING: db.sqlite furnace.alloy namespaces http.server ;
-: calculator-db ( -- params db ) "calculator.db" sqlite-db ;
+: calculator-db ( -- db ) "calculator.db" <sqlite-db> ;
: run-calculator ( -- )
<calculator>
! Deployment example
USING: db.sqlite furnace.alloy namespaces ;
-: counter-db ( -- params db ) "counter.db" sqlite-db ;
+: counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- )
<counter-app>
{ wiki "wiki-common" } >>template ;
: init-wiki ( -- )
- "resource:extra/webapps/wiki/initial-content" directory* keys
- [
- dup file-name ".txt" ?tail [
- swap ascii file-contents
- f <revision>
- swap >>content
- swap >>title
- "slava" >>author
- now >>date
- add-revision
- ] [ 2drop ] if
- ] each ;
+ "resource:extra/webapps/wiki/initial-content" [
+ [
+ dup ".txt" ?tail [
+ swap ascii file-contents
+ f <revision>
+ swap >>content
+ swap >>title
+ "slava" >>author
+ now >>date
+ add-revision
+ ] [ 2drop ] if
+ ] each
+ ] with-directory-files ;
--- /dev/null
+! Based on http://research.sun.com/people/mario/java_benchmarking/
+! Ported by Factor by Slava Pestov
+!
+! Based on original version written in BCPL by Dr Martin Richards
+! in 1981 at Cambridge University Computer Laboratory, England
+! Java version: Copyright (C) 1995 Sun Microsystems, Inc.
+! by Jonathan Gibbons.
+! Outer loop added 8/7/96 by Alex Jacoby
+USING: values kernel accessors math math.bitwise sequences
+arrays combinators fry locals ;
+IN: benchmark.richards
+
+! Packets
+TUPLE: packet link id kind a1 a2 ;
+
+: BUFSIZE 4 ; inline
+
+: <packet> ( link id kind -- packet )
+ packet new
+ swap >>kind
+ swap >>id
+ swap >>link
+ 0 >>a1
+ BUFSIZE 0 <array> >>a2 ;
+
+: last-packet ( packet -- last )
+ dup link>> [ last-packet ] [ ] ?if ;
+
+: append-to ( packet list -- packet )
+ [ f >>link ] dip
+ [ tuck last-packet >>link drop ] when* ;
+
+! Tasks
+: I_IDLE 1 ; inline
+: I_WORK 2 ; inline
+: I_HANDLERA 3 ; inline
+: I_HANDLERB 4 ; inline
+: I_DEVA 5 ; inline
+: I_DEVB 6 ; inline
+
+! Packet types
+: K_DEV 1000 ; inline
+: K_WORK 1001 ; inline
+
+: PKTBIT 1 ; inline
+: WAITBIT 2 ; inline
+: 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
+
+: task-tab-size 10 ; inline
+
+VALUE: task-tab
+VALUE: task-list
+VALUE: tracing
+VALUE: hold-count
+VALUE: qpkt-count
+
+TUPLE: task link id pri wkq state ;
+
+: new-task ( id pri wkq state class -- task )
+ new
+ swap >>state
+ swap >>wkq
+ swap >>pri
+ swap >>id
+ task-list >>link
+ dup to: task-list
+ dup dup id>> task-tab set-nth ; inline
+
+GENERIC: fn ( packet task -- task )
+
+: state-on ( task flag -- task )
+ '[ _ bitor ] change-state ; inline
+
+: state-off ( task flag -- task )
+ '[ _ bitnot bitand ] change-state ; inline
+
+: wait-task ( task -- task )
+ WAITBIT state-on ;
+
+: hold ( task -- task )
+ hold-count 1+ to: hold-count
+ HOLDBIT state-on
+ link>> ;
+
+: highest-priority ( t1 t2 -- t1/t2 )
+ [ [ pri>> ] bi@ > ] most ;
+
+: find-tcb ( i -- task )
+ task-tab nth [ "Bad task" throw ] unless* ;
+
+: release ( task i -- task )
+ find-tcb HOLDBIT state-off highest-priority ;
+
+:: qpkt ( task pkt -- task )
+ [let | t [ pkt id>> find-tcb ] |
+ t [
+ qpkt-count 1+ to: qpkt-count
+ f pkt (>>link)
+ task id>> pkt (>>id)
+ t wkq>> [
+ pkt t wkq>> append-to t (>>wkq)
+ task
+ ] [
+ pkt t (>>wkq)
+ t PKTBIT state-on drop
+ t task highest-priority
+ ] if
+ ] [ task ] if
+ ] ;
+
+: schedule-waitpkt ( task -- task pkt )
+ dup wkq>>
+ 2dup link>> >>wkq drop
+ 2dup S_RUNPKT S_RUN ? >>state drop ; inline
+
+: schedule-run ( task pkt -- task )
+ swap fn ; inline
+
+: schedule-wait ( task -- task )
+ link>> ; inline
+
+: (schedule) ( task -- )
+ [
+ dup state>> {
+ { S_WAITPKT [ schedule-waitpkt schedule-run (schedule) ] }
+ { S_RUN [ f schedule-run (schedule) ] }
+ { S_RUNPKT [ f schedule-run (schedule) ] }
+ { S_WAIT [ schedule-wait (schedule) ] }
+ { S_HOLD [ schedule-wait (schedule) ] }
+ { S_HOLDPKT [ schedule-wait (schedule) ] }
+ { S_HOLDWAIT [ schedule-wait (schedule) ] }
+ { S_HOLDWAITPKT [ schedule-wait (schedule) ] }
+ [ 2drop ]
+ } case
+ ] when* ;
+
+: schedule ( -- )
+ task-list (schedule) ;
+
+! Device task
+TUPLE: device-task < task v1 ;
+
+: <device-task> ( id pri wkq -- task )
+ dup S_WAITPKT S_WAIT ? device-task new-task ;
+
+M:: device-task fn ( pkt task -- task )
+ pkt [
+ task dup v1>>
+ [ wait-task ]
+ [ [ f ] change-v1 swap qpkt ] if
+ ] [ pkt task (>>v1) task hold ] if ;
+
+TUPLE: handler-task < task workpkts devpkts ;
+
+: <handler-task> ( id pri wkq -- task )
+ dup S_WAITPKT S_WAIT ? handler-task new-task ;
+
+M:: handler-task fn ( pkt task -- task )
+ pkt [
+ task over kind>> K_WORK =
+ [ [ append-to ] change-workpkts ]
+ [ [ append-to ] change-devpkts ]
+ if drop
+ ] when*
+
+ task workpkts>> [
+ [let* | devpkt [ task devpkts>> ]
+ workpkt [ task workpkts>> ]
+ count [ workpkt a1>> ] |
+ count BUFSIZE > [
+ workpkt link>> task (>>workpkts)
+ task workpkt qpkt
+ ] [
+ devpkt [
+ devpkt link>> task (>>devpkts)
+ count workpkt a2>> nth devpkt (>>a1)
+ count 1+ workpkt (>>a1)
+ task devpkt qpkt
+ ] [
+ task wait-task
+ ] if
+ ] if
+ ]
+ ] [ task wait-task ] if ;
+
+! Idle task
+TUPLE: idle-task < task { v1 fixnum } { v2 fixnum } ;
+
+: <idle-task> ( i a1 a2 -- task )
+ [ 0 f S_RUN idle-task new-task ] 2dip
+ [ >>v1 ] [ >>v2 ] bi* ;
+
+M: idle-task fn ( pkt task -- task )
+ nip
+ [ 1- ] change-v2
+ dup v2>> 0 = [ hold ] [
+ dup v1>> 1 bitand 0 = [
+ [ -1 shift ] change-v1
+ I_DEVA release
+ ] [
+ [ -1 shift HEX: d008 bitor ] change-v1
+ I_DEVB release
+ ] if
+ ] if ;
+
+! Work task
+TUPLE: work-task < task { handler fixnum } { n fixnum } ;
+
+: <work-task> ( id pri w -- work-task )
+ dup S_WAITPKT S_WAIT ? work-task new-task
+ I_HANDLERA >>handler
+ 0 >>n ;
+
+M:: work-task fn ( pkt task -- task )
+ pkt [
+ task [ I_HANDLERA = I_HANDLERB I_HANDLERA ? ] change-handler drop
+ task handler>> pkt (>>id)
+ 0 pkt (>>a1)
+ BUFSIZE [| i |
+ task [ 1+ ] change-n drop
+ task n>> 26 > [ 1 task (>>n) ] when
+ task n>> 1 - CHAR: A + i pkt a2>> set-nth
+ ] each
+ task pkt qpkt
+ ] [ task wait-task ] if ;
+
+! Main
+: init ( -- )
+ task-tab-size f <array> to: task-tab
+ f to: tracing
+ 0 to: hold-count
+ 0 to: qpkt-count ;
+
+: start ( -- )
+ I_IDLE 1 10000 <idle-task> drop
+
+ I_WORK 1000
+ f 0 K_WORK <packet> 0 K_WORK <packet>
+ <work-task> drop
+
+ I_HANDLERA 2000
+ f I_DEVA K_DEV <packet>
+ I_DEVA K_DEV <packet>
+ I_DEVA K_DEV <packet>
+ <handler-task> drop
+
+ I_HANDLERB 3000
+ f I_DEVB K_DEV <packet>
+ I_DEVB K_DEV <packet>
+ I_DEVB K_DEV <packet>
+ <handler-task> drop
+
+ I_DEVA 4000 f <device-task> drop
+ I_DEVB 4000 f <device-task> drop ;
+
+: check ( -- )
+ qpkt-count 23246 assert=
+ hold-count 9297 assert= ;
+
+: run ( -- )
+ init
+ start
+ schedule check ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
-alien.c-types alien.structs compiler.backend ;
+alien.c-types alien.structs cpu.architecture ;
IN: compiler.alien
-! Common utilities
-
: large-struct? ( ctype -- ? )
- dup c-struct? [
- heap-size struct-small-enough? not
- ] [ drop f ] if ;
+ dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
[ parameter-align drop dup , ] keep stack-size +
] reduce cell align
] { } make ;
-
-: return-size ( ctype -- n )
- #! Amount of space we reserve for a return value.
- dup large-struct? [ heap-size ] [ drop 0 ] if ;
-
-: alien-stack-frame ( params -- n )
- alien-parameters parameter-sizes drop ;
-
-: alien-invoke-frame ( params -- n )
- #! One cell is temporary storage, temp@
- dup return>> return-size
- swap alien-stack-frame +
- cell + ;
HOOK: load-indirect cpu ( obj reg -- )
-HOOK: stack-frame cpu ( frame-size -- n )
-
-: stack-frame* ( -- n )
- \ stack-frame get stack-frame ;
+HOOK: stack-frame-size cpu ( frame-size -- n )
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
-locals layouts
+locals layouts alien.c-types alien.structs
stack-checker.inlining
compiler.intrinsics
compiler.tree
: emit-call ( word -- next )
finalize-phantoms
{
- { [ tail-call? not ] [ 0 ##frame-required ##call iterate-next ] }
+ { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
[ ##epilogue ##jump stop-iterating ]
} cond ;
(write-barrier)
} [ t "intrinsic" set-word-prop ] each
-: allot-size ( #call -- n )
+: allot-size ( -- n )
1 phantom-datastack get phantom-input first value>> ;
:: emit-allot ( size type tag -- )
M: #terminate emit-node drop stop-iterating ;
! FFI
+: return-size ( ctype -- n )
+ #! Amount of space we reserve for a return value.
+ {
+ { [ dup c-struct? not ] [ drop 0 ] }
+ { [ dup large-struct? not ] [ drop 2 cells ] }
+ [ heap-size ]
+ } cond ;
+
+: <alien-stack-frame> ( params -- stack-frame )
+ stack-frame new
+ swap
+ [ return>> return-size >>return ]
+ [ alien-parameters parameter-sizes drop >>params ] bi
+ dup [ params>> ] [ return>> ] bi + >>size ;
+
+: alien-stack-frame ( node -- )
+ params>> <alien-stack-frame> ##stack-frame ;
+
+: emit-alien-node ( node quot -- next )
+ [ drop alien-stack-frame ]
+ [ [ params>> ] dip call ] 2bi
+ iterate-next ; inline
+
M: #alien-invoke emit-node
- params>>
- [ alien-invoke-frame ##frame-required ]
- [ ##alien-invoke iterate-next ]
- bi ;
+ [ ##alien-invoke ] emit-alien-node ;
M: #alien-indirect emit-node
- params>>
- [ alien-invoke-frame ##frame-required ]
- [ ##alien-indirect iterate-next ]
- bi ;
+ [ ##alien-indirect ] emit-alien-node ;
M: #alien-callback emit-node
params>> dup xt>> dup
- [ init-phantoms ##alien-callback ] with-cfg-builder
+ [
+ init-phantoms
+ [ ##alien-callback ] emit-alien-node drop
+ ] with-cfg-builder
iterate-next ;
! No-op nodes
V{ } clone >>instructions
V{ } clone >>successors ;
-TUPLE: mr instructions word label frame-size spill-counts ;
+TUPLE: mr instructions word label ;
: <mr> ( instructions word label -- mr )
mr new
INSN: ##inc-d n ;
INSN: ##inc-r n ;
-! Calling convention
-INSN: ##return ;
-
! Subroutine calls
+TUPLE: stack-frame
+{ size integer }
+{ params integer }
+{ return integer }
+{ total-size integer } ;
+
+INSN: ##stack-frame stack-frame ;
+ : ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
INSN: ##call word ;
INSN: ##jump word ;
+INSN: ##return ;
+
INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables
! Instructions used by CFG IR only.
INSN: ##prologue ;
INSN: ##epilogue ;
-INSN: ##frame-required n ;
INSN: ##branch ;
INSN: ##branch-f < ##cond-branch ;
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
! Instructions used by machine IR only.
-INSN: _prologue ;
-INSN: _epilogue ;
+INSN: _prologue stack-frame ;
+INSN: _epilogue stack-frame ;
INSN: _label id ;
SYMBOL: frame-required?
-SYMBOL: frame-size
-
SYMBOL: spill-counts
: init-stack-frame-builder ( -- )
frame-required? off
- 0 frame-size set ;
+ T{ stack-frame } clone stack-frame set ;
+
+GENERIC: compute-stack-frame* ( insn -- )
-GENERIC: compute-frame-size* ( insn -- )
+: max-stack-frame ( frame1 frame2 -- frame3 )
+ {
+ [ [ size>> ] bi@ max ]
+ [ [ params>> ] bi@ max ]
+ [ [ return>> ] bi@ max ]
+ [ [ total-size>> ] bi@ max ]
+ } cleave
+ stack-frame boa ;
-M: ##frame-required compute-frame-size*
+M: ##stack-frame compute-stack-frame*
frame-required? on
- n>> frame-size [ max ] change ;
+ stack-frame>> stack-frame [ max-stack-frame ] change ;
-M: _spill-integer compute-frame-size*
+M: _spill-integer compute-stack-frame*
drop frame-required? on ;
-M: _spill-float compute-frame-size*
+M: _spill-float compute-stack-frame*
drop frame-required? on ;
-M: insn compute-frame-size* drop ;
+M: insn compute-stack-frame* drop ;
-: compute-frame-size ( insns -- )
- [ compute-frame-size* ] each ;
+: compute-stack-frame ( insns -- )
+ [ compute-stack-frame* ] each ;
GENERIC: insert-pro/epilogues* ( insn -- )
-M: ##frame-required insert-pro/epilogues* drop ;
+M: ##stack-frame insert-pro/epilogues* drop ;
M: ##prologue insert-pro/epilogues*
- drop frame-required? get [ _prologue ] when ;
+ drop frame-required? get [ stack-frame get _prologue ] when ;
M: ##epilogue insert-pro/epilogues*
- drop frame-required? get [ _epilogue ] when ;
+ drop frame-required? get [ stack-frame get _epilogue ] when ;
M: insn insert-pro/epilogues* , ;
[
init-stack-frame-builder
[
- [ compute-frame-size ]
+ [ compute-stack-frame ]
[ insert-pro/epilogues ]
bi
] change-instructions
- frame-size get >>frame-size
] with-scope ;
finalize-contents
finalize-heights
fresh-objects get [
- empty? [ 0 ##frame-required ##gc ] unless
+ empty? [ ##simple-stack-frame ##gc ] unless
] [ delete-all ] bi ;
: init-phantoms ( -- )
: lazy-load ( specs -- seq )
[ length phantom-datastack get phantom-input ] keep
- [ drop ] [
- [
- 2dup second clobbered?
- [ first (eager-load) ] [ first (lazy-load) ] if
- ] 2map
- ] 2bi
- [ substitute-vregs ] keep ;
+ [
+ 2dup second clobbered?
+ [ first (eager-load) ] [ first (lazy-load) ] if
+ ] 2map ;
: load-inputs ( template -- assoc )
[
compiler.codegen.fixup
compiler.cfg
compiler.cfg.instructions
-compiler.cfg.registers ;
+compiler.cfg.registers
+compiler.cfg.builder ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
id>> lookup-label , ;
M: _prologue generate-insn
- drop %prologue ;
+ stack-frame>>
+ [ stack-frame set ]
+ [ dup size>> stack-frame-size >>total-size drop ]
+ [ total-size>> %prologue ]
+ tri ;
M: _epilogue generate-insn
- drop %epilogue ;
+ stack-frame>> total-size>> %epilogue ;
M: ##load-literal generate-insn
[ obj>> ] [ dst>> v>operand ] bi load-literal ;
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
- return>> dup large-struct?
- [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+ return>> large-struct?
+ [ %prepare-box-struct cell ] [ 0 ] if ;
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
: callback-unwind ( params -- n )
{
- { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: digraphs kernel sequences tools.test ;
-IN: digraphs.tests
-
-: test-digraph ( -- digraph )
- <digraph>
- { { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each
- { { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ;
-
-[ 5 ] [ test-digraph topological-sort length ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel sequences vectors ;
-IN: digraphs
-
-TUPLE: digraph ;
-TUPLE: vertex value edges ;
-
-: <digraph> ( -- digraph )
- digraph new H{ } clone over set-delegate ;
-
-: <vertex> ( value -- vertex )
- V{ } clone vertex boa ;
-
-: add-vertex ( key value digraph -- )
- >r <vertex> swap r> set-at ;
-
-: children ( key digraph -- seq )
- at edges>> ;
-
-: @edges ( from to digraph -- to edges ) swapd at edges>> ;
-: add-edge ( from to digraph -- ) @edges push ;
-: delete-edge ( from to digraph -- ) @edges delete ;
-
-: delete-to-edges ( to digraph -- )
- [ nip dupd edges>> delete ] assoc-each drop ;
-
-: delete-vertex ( key digraph -- )
- 2dup delete-at delete-to-edges ;
-
-: unvisited? ( unvisited key -- ? ) swap key? ;
-: visited ( unvisited key -- ) swap delete-at ;
-
-DEFER: (topological-sort)
-: visit-children ( seq unvisited key -- seq unvisited )
- over children [ (topological-sort) ] each ;
-
-: (topological-sort) ( seq unvisited key -- seq unvisited )
- 2dup unvisited? [
- [ visit-children ] keep 2dup visited pick push
- ] [
- drop
- ] if ;
-
-: topological-sort ( digraph -- seq )
- dup clone V{ } clone spin
- [ drop (topological-sort) ] assoc-each drop reverse ;
-
-: topological-sorted-values ( digraph -- seq )
- dup topological-sort swap [ at value>> ] curry map ;
+++ /dev/null
-Simple directed graph implementation for topological sorting
+++ /dev/null
-collections
+++ /dev/null
-USING: calendar io io-internals kernel math namespaces
-nonblocking-io prettyprint quotations sequences ;
-IN: libs-io
-
-: bit-set? ( m n -- ? ) [ bitand ] keep = ;
-: set-bit ( m bit -- n ) bitor ;
-: clear-bit ( m bit -- n ) bitnot bitand ;
-
: SEEK_END 2 ; inline
: EEXIST 17 ; inline
-FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
-: append-mode
- O_WRONLY O_APPEND O_CREAT bitor bitor ; foldable
-
-: open-append ( path -- fd )
- append-mode file-mode open dup io-error
- [ 0 SEEK_END lseek io-error ] keep ;
-
-: touch-mode
- O_WRONLY O_APPEND O_CREAT O_EXCL bitor bitor bitor ; foldable
-
-: open-touch ( path -- fd )
- touch-mode file-mode open
- [ io-error close t ]
- [ 2drop err_no EEXIST = [ err_no io-error ] unless -1 ] recover ;
-
-: <file-appender> ( path -- stream ) open-append <writer> ;
-
-FUNCTION: int unlink ( char* path ) ;
-: delete-file ( path -- )
- unlink io-error ;
-
-FUNCTION: int mkdir ( char* path, mode_t mode ) ;
-
-: (create-directory) ( path mode -- )
- mkdir io-error ;
-
-: create-directory ( path -- )
- 0 (create-directory) ;
-
-FUNCTION: int rmdir ( char* path ) ;
-
-: delete-directory ( path -- )
- rmdir io-error ;
-
-FUNCTION: int chroot ( char* path ) ;
-FUNCTION: int chdir ( char* path ) ;
-FUNCTION: int fchdir ( int fd ) ;
-
-FUNCTION: int utimes ( char* path, timeval[2] times ) ;
-FUNCTION: int futimes ( int id, timeval[2] times ) ;
-
-TYPEDEF: longlong blkcnt_t
-TYPEDEF: int blksize_t
-TYPEDEF: int dev_t
-TYPEDEF: uint ino_t
-TYPEDEF: ushort mode_t
-TYPEDEF: ushort nlink_t
-TYPEDEF: uint uid_t
-TYPEDEF: uint gid_t
-TYPEDEF: longlong quad_t
-TYPEDEF: ulong u_long
-
-FUNCTION: int stat ( char* path, stat* sb ) ;
-
-C-STRUCT: stat
- { "dev_t" "dev" } ! device inode resides on
- { "ino_t" "ino" } ! inode's number
- { "mode_t" "mode" } ! inode protection mode
- { "nlink_t" "nlink" } ! number or hard links to the file
- { "uid_t" "uid" } ! user-id of owner
- { "gid_t" "gid" } ! group-id of owner
- { "dev_t" "rdev" } ! device type, for special file inode
- { "timespec" "atime" } ! time of last access
- { "timespec" "mtime" } ! time of last data modification
- { "timespec" "ctime" } ! time of last file status change
- { "off_t" "size" } ! file size, in bytes
- { "blkcnt_t" "blocks" } ! blocks allocated for file
- { "blksize_t" "blksize" } ! optimal file sys I/O ops blocksize
- { "u_long" "flags" } ! user defined flags for file
- { "u_long" "gen" } ; ! file generation number
-
-: stat* ( path -- byte-array )
- "stat" <c-object> [ stat io-error ] keep ;
-
-: make-timeval-array ( array -- byte-array )
- [ length "timeval" <c-array> ] keep
- dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
-
-: (set-file-times) ( timestamp timestamp -- alien )
- [ [ timestamp>timeval ] [ f ] if* ] 2apply 2array
- make-timeval-array ;
-
-: set-file-times ( path timestamp timestamp -- )
- #! set access, write
- (set-file-times) utimes io-error ;
-
-: set-file-times* ( fd timestamp timestamp -- )
- (set-file-times) futimes io-error ;
-
-
-: set-file-access-time ( path timestamp -- )
- f set-file-times ;
-
-: set-file-write-time ( path timestamp -- )
- >r f r> set-file-times ;
-
-
-: file-write-time ( path -- timestamp )
- stat* stat-mtime timespec>timestamp ;
-
-: file-access-time ( path -- timestamp )
- stat* stat-atime timespec>timestamp ;
-
-! File type
-: S_IFMT OCT: 0170000 ; inline ! type of file
-: S_IFIFO OCT: 0010000 ; inline ! named pipe (fifo)
-: S_IFCHR OCT: 0020000 ; inline ! character special
-: S_IFDIR OCT: 0040000 ; inline ! directory
-: S_IFBLK OCT: 0060000 ; inline ! block special
-: S_IFREG OCT: 0100000 ; inline ! regular
-: S_IFLNK OCT: 0120000 ; inline ! symbolic link
-: S_IFSOCK OCT: 0140000 ; inline ! socket
-: S_IFWHT OCT: 0160000 ; inline ! whiteout
-: S_IFXATTR OCT: 0200000 ; inline ! extended attribute
-
-! File mode
-! Read, write, execute/search by owner
-: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
-: S_IRUSR OCT: 0000400 ; inline ! r owner
-: S_IWUSR OCT: 0000200 ; inline ! w owner
-: S_IXUSR OCT: 0000100 ; inline ! x owner
-! Read, write, execute/search by group
-: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
-: S_IRGRP OCT: 0000040 ; inline ! r group
-: S_IWGRP OCT: 0000020 ; inline ! w group
-: S_IXGRP OCT: 0000010 ; inline ! x group
-! Read, write, execute/search by others
-: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
-: S_IROTH OCT: 0000004 ; inline ! r other
-: S_IWOTH OCT: 0000002 ; inline ! w other
-: S_IXOTH OCT: 0000001 ; inline ! x other
-
-: S_ISUID OCT: 0004000 ; inline ! set user id on execution
-: S_ISGID OCT: 0002000 ; inline ! set group id on execution
-: S_ISVTX OCT: 0001000 ; inline ! sticky bit
-
-FUNCTION: uid_t getuid ;
-FUNCTION: uid_t geteuid ;
-
-FUNCTION: gid_t getgid ;
-FUNCTION: gid_t getegid ;
-
-FUNCTION: int setuid ( uid_t uid ) ;
-FUNCTION: int seteuid ( uid_t euid ) ;
-FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ;
-
-FUNCTION: int setgid ( gid_t gid ) ;
-FUNCTION: int setegid ( gid_t egid ) ;
-FUNCTION: int setregid ( gid_t rgid, gid_t egid ) ;
-
-FUNCTION: int issetugid ;
-
-FUNCTION: int chmod ( char* path, mode_t mode ) ;
-FUNCTION: int fchmod ( int fd, mode_t mode ) ;
-
-FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
-FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
-#! lchown does not follow symbolic links
-FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
-
-FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
-FUNCTION: int setgroups ( int ngroups, gid_t* gidset ) ;
-
-FUNCTION: int flock ( int fd, int operation ) ;
-! FUNCTION: int dup ( int oldd ) ;
-! FUNCTION: int dup2 ( int oldd, int newd ) ;
-
-FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
-FUNCTION: int getdtablesize ;
-
-: file-mode? ( path mask -- ? )
- >r stat* stat-mode r> bit-set? ;
-
-: user-read? ( path -- ? ) S_IRUSR file-mode? ;
-: user-write? ( path -- ? ) S_IWUSR file-mode? ;
-: user-execute? ( path -- ? ) S_IXUSR file-mode? ;
-
-: group-read? ( path -- ? ) S_IRGRP file-mode? ;
-: group-write? ( path -- ? ) S_IWGRP file-mode? ;
-: group-execute? ( path -- ? ) S_IXGRP file-mode? ;
-
-: other-read? ( path -- ? ) S_IROTH file-mode? ;
-: other-write? ( path -- ? ) S_IWOTH file-mode? ;
-: other-execute? ( path -- ? ) S_IXOTH file-mode? ;
-
-: set-uid? ( path -- ? ) S_ISUID bit-set? ;
-: set-gid? ( path -- ? ) S_ISGID bit-set? ;
-: set-sticky? ( path -- ? ) S_ISVTX bit-set? ;
-
-: chmod* ( path mask ? -- )
- >r >r dup stat* stat-mode r> r> [
- set-bit
- ] [
- clear-bit
- ] if chmod io-error ;
-
-: set-user-read ( path ? -- ) >r S_IRUSR r> chmod* ;
-: set-user-write ( path ? -- ) >r S_IWUSR r> chmod* ;
-: set-user-execute ( path ? -- ) >r S_IXUSR r> chmod* ;
-
-: set-group-read ( path ? -- ) >r S_IRGRP r> chmod* ;
-: set-group-write ( path ? -- ) >r S_IWGRP r> chmod* ;
-: set-group-execute ( path ? -- ) >r S_IXGRP r> chmod* ;
-
-: set-other-read ( path ? -- ) >r S_IROTH r> chmod* ;
-: set-other-write ( path ? -- ) >r S_IWOTH r> chmod* ;
-: set-other-execute ( path ? -- ) >r S_IXOTH r> chmod* ;
-
-: set-uid ( path ? -- ) >r S_ISUID r> chmod* ;
-: set-gid ( path ? -- ) >r S_ISGID r> chmod* ;
-: set-sticky ( path ? -- ) >r S_ISVTX r> chmod* ;
-
: mode>symbol ( mode -- ch )
S_IFMT bitand
{
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Jamshred" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
-IN: jamshred.game
-
-TUPLE: jamshred sounds tunnel players running quit ;
-
-: <jamshred> ( -- jamshred )
- <sounds> <random-tunnel> "Player 1" pick <player>
- 2dup swap play-in-tunnel 1array f f jamshred boa ;
-
-: jamshred-player ( jamshred -- player )
- ! TODO: support more than one player
- players>> first ;
-
-: jamshred-update ( jamshred -- )
- dup running>> [
- jamshred-player update-player
- ] [ drop ] if ;
-
-: toggle-running ( jamshred -- )
- dup running>> [
- f >>running drop
- ] [
- [ jamshred-player moved ]
- [ t >>running drop ] bi
- ] if ;
-
-: mouse-moved ( x-radians y-radians jamshred -- )
- jamshred-player -rot turn-player ;
-
-: units-per-full-roll ( -- n ) 50 ;
-
-: jamshred-roll ( jamshred n -- )
- [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
-
-: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
-
-: mouse-scroll-y ( jamshred y -- )
- neg swap jamshred-player change-player-speed ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types colors jamshred.game
-jamshred.oint jamshred.player jamshred.tunnel kernel math
-math.constants math.functions math.vectors opengl opengl.gl
-opengl.glu sequences float-arrays ;
-IN: jamshred.gl
-
-: min-vertices 6 ; inline
-: max-vertices 32 ; inline
-
-: n-vertices ( -- n ) 32 ; inline
-
-! render enough of the tunnel that it looks continuous
-: n-segments-ahead ( -- n ) 60 ; inline
-: n-segments-behind ( -- n ) 40 ; inline
-
-: wall-drawing-offset ( -- n )
- #! so that we can't see through the wall, we draw it a bit further away
- 0.15 ;
-
-: wall-drawing-radius ( segment -- r )
- radius>> wall-drawing-offset + ;
-
-: wall-up ( segment -- v )
- [ wall-drawing-radius ] [ up>> ] bi n*v ;
-
-: wall-left ( segment -- v )
- [ wall-drawing-radius ] [ left>> ] bi n*v ;
-
-: segment-vertex ( theta segment -- vertex )
- [
- [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
- ] [
- location>> v+
- ] bi ;
-
-: segment-vertex-normal ( vertex segment -- normal )
- location>> swap v- normalize ;
-
-: segment-vertex-and-normal ( segment theta -- vertex normal )
- swap [ segment-vertex ] keep dupd segment-vertex-normal ;
-
-: equally-spaced-radians ( n -- seq )
- #! return a sequence of n numbers between 0 and 2pi
- dup [ / pi 2 * * ] curry map ;
-: draw-segment-vertex ( segment theta -- )
- over segment-color gl-color segment-vertex-and-normal
- gl-normal gl-vertex ;
-
-: draw-vertex-pair ( theta next-segment segment -- )
- rot tuck draw-segment-vertex draw-segment-vertex ;
-
-: draw-segment ( next-segment segment -- )
- GL_QUAD_STRIP [
- [ draw-vertex-pair ] 2curry
- n-vertices equally-spaced-radians F{ 0.0 } append swap each
- ] do-state ;
-
-: draw-segments ( segments -- )
- 1 over length pick subseq swap [ draw-segment ] 2each ;
-
-: segments-to-render ( player -- segments )
- dup player-nearest-segment segment-number dup n-segments-behind -
- swap n-segments-ahead + rot player-tunnel sub-tunnel ;
-
-: draw-tunnel ( player -- )
- segments-to-render draw-segments ;
-
-: init-graphics ( width height -- )
- GL_DEPTH_TEST glEnable
- GL_SCISSOR_TEST glDisable
- 1.0 glClearDepth
- 0.0 0.0 0.0 0.0 glClearColor
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- GL_PROJECTION glMatrixMode glLoadIdentity
- dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
- GL_MODELVIEW glMatrixMode glLoadIdentity
- GL_LEQUAL glDepthFunc
- GL_LIGHTING glEnable
- GL_LIGHT0 glEnable
- GL_FOG glEnable
- GL_FOG_DENSITY 0.09 glFogf
- GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
- GL_COLOR_MATERIAL glEnable
- GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv
- GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv
- GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv
- GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
-
-: player-view ( player -- )
- [ location>> ]
- [ [ location>> ] [ forward>> ] bi v+ ]
- [ up>> ] tri gl-look-at ;
-
-: draw-jamshred ( jamshred width height -- )
- init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;
-
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar jamshred.game jamshred.gl
-jamshred.player jamshred.log kernel math math.constants namespaces
-sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds
-ui.gestures ui.render math.vectors math.geometry.rect ;
-IN: jamshred
-
-TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
-
-: <jamshred-gadget> ( jamshred -- gadget )
- jamshred-gadget construct-gadget swap >>jamshred ;
-
-: default-width ( -- x ) 800 ;
-: default-height ( -- y ) 600 ;
-
-M: jamshred-gadget pref-dim*
- drop default-width default-height 2array ;
-
-M: jamshred-gadget draw-gadget* ( gadget -- )
- [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
-
-: jamshred-loop ( gadget -- )
- dup jamshred>> quit>> [
- drop
- ] [
- [ jamshred>> jamshred-update ]
- [ relayout-1 ]
- [ yield jamshred-loop ] tri
- ] if ;
-
-: fullscreen ( gadget -- )
- find-world t swap set-fullscreen* ;
-
-: no-fullscreen ( gadget -- )
- find-world f swap set-fullscreen* ;
-
-: toggle-fullscreen ( world -- )
- [ fullscreen? not ] keep set-fullscreen* ;
-
-M: jamshred-gadget graft* ( gadget -- )
- [ jamshred-loop ] in-thread drop ;
-
-M: jamshred-gadget ungraft* ( gadget -- )
- jamshred>> t swap (>>quit) ;
-
-: jamshred-restart ( jamshred-gadget -- )
- <jamshred> >>jamshred drop ;
-
-: pix>radians ( n m -- theta )
- / pi 4 * * ; ! 2 / / pi 2 * * ;
-
-: x>radians ( x gadget -- theta )
- #! translate motion of x pixels to an angle
- rect-dim first pix>radians neg ;
-
-: y>radians ( y gadget -- theta )
- #! translate motion of y pixels to an angle
- rect-dim second pix>radians ;
-
-: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
- over jamshred>> >r
- [ first swap x>radians ] 2keep second swap y>radians
- r> mouse-moved ;
-
-: handle-mouse-motion ( jamshred-gadget -- )
- hand-loc get [
- over last-hand-loc>> [
- v- (handle-mouse-motion)
- ] [ 2drop ] if*
- ] 2keep >>last-hand-loc drop ;
-
-: handle-mouse-scroll ( jamshred-gadget -- )
- jamshred>> scroll-direction get
- [ first mouse-scroll-x ]
- [ second mouse-scroll-y ] 2bi ;
-
-: quit ( gadget -- )
- [ no-fullscreen ] [ close-window ] bi ;
-
-jamshred-gadget H{
- { T{ key-down f f "r" } [ jamshred-restart ] }
- { T{ key-down f f " " } [ jamshred>> toggle-running ] }
- { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
- { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
- { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
- { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
- { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
- { T{ key-down f f "q" } [ quit ] }
- { T{ motion } [ handle-mouse-motion ] }
- { T{ mouse-scroll } [ handle-mouse-scroll ] }
-} set-gestures
-
-: jamshred-window ( -- jamshred )
- [ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
-
-MAIN: jamshred-window
+++ /dev/null
-USING: kernel logging ;
-IN: jamshred.log
-
-LOG: (jamshred-log) DEBUG
-
-: with-jamshred-log ( quot -- )
- "jamshred" swap with-logging ;
-
-: jamshred-log ( message -- )
- [ (jamshred-log) ] with-jamshred-log ; ! ugly...
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: jamshred.oint tools.test ;
-IN: jamshred.oint-tests
-
-[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
-[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
-[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
-[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
-[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
-IN: jamshred.oint
-
-! An oint is a point with three linearly independent unit vectors
-! given relative to that point. In jamshred a player's location and
-! direction are given by the player's oint. Similarly, a tunnel
-! segment's location and orientation are given by an oint.
-
-TUPLE: oint location forward up left ;
-C: <oint> oint
-
-: rotation-quaternion ( theta axis -- quaternion )
- swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
-
-: rotate-vector ( q qrecip v -- v )
- v>q swap q* q* q>v ;
-
-: rotate-oint ( oint theta axis -- )
- rotation-quaternion dup qrecip pick
- [ forward>> rotate-vector >>forward ]
- [ up>> rotate-vector >>up ]
- [ left>> rotate-vector >>left ] 3tri drop ;
-
-: left-pivot ( oint theta -- )
- over left>> rotate-oint ;
-
-: up-pivot ( oint theta -- )
- over up>> rotate-oint ;
-
-: forward-pivot ( oint theta -- )
- over forward>> rotate-oint ;
-
-: random-float+- ( n -- m )
- #! find a random float between -n/2 and n/2
- dup 10000 * >fixnum random 10000 / swap 2 / - ;
-
-: random-turn ( oint theta -- )
- 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
-
-: location+ ( v oint -- )
- [ location>> v+ ] [ (>>location) ] bi ;
-
-: go-forward ( distance oint -- )
- [ forward>> n*v ] [ location+ ] bi ;
-
-: distance-vector ( oint oint -- vector )
- [ location>> ] bi@ swap v- ;
-
-: distance ( oint oint -- distance )
- distance-vector norm ;
-
-: scalar-projection ( v1 v2 -- n )
- #! the scalar projection of v1 onto v2
- tuck v. swap norm / ;
-
-: proj-perp ( u v -- w )
- dupd proj v- ;
-
-: perpendicular-distance ( oint oint -- distance )
- tuck distance-vector swap 2dup left>> scalar-projection abs
- -rot up>> scalar-projection abs + ;
-
-:: reflect ( v n -- v' )
- #! bounce v on a surface with normal n
- v v n v. n n v. / 2 * n n*v v- ;
-
-: half-way ( p1 p2 -- p3 )
- over v- 2 v/n v+ ;
-
-: half-way-between-oints ( o1 o2 -- p )
- [ location>> ] bi@ half-way ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors combinators jamshred.log jamshred.oint
-jamshred.sound jamshred.tunnel kernel locals math math.constants
-math.order math.ranges math.vectors math.matrices shuffle
-sequences system float-arrays ;
-IN: jamshred.player
-
-TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
-
-! speeds are in GL units / second
-: default-speed ( -- speed ) 1.0 ;
-: max-speed ( -- speed ) 30.0 ;
-
-: <player> ( name sounds -- player )
- [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
- f f f default-speed player boa ;
-
-: turn-player ( player x-radians y-radians -- )
- >r over r> left-pivot up-pivot ;
-
-: roll-player ( player z-radians -- )
- forward-pivot ;
-
-: to-tunnel-start ( player -- )
- [ tunnel>> first dup location>> ]
- [ tuck (>>location) (>>nearest-segment) ] bi ;
-
-: play-in-tunnel ( player segments -- )
- >>tunnel to-tunnel-start ;
-
-: update-nearest-segment ( player -- )
- [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
- [ (>>nearest-segment) ] tri ;
-
-: update-time ( player -- seconds-passed )
- millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
-
-: moved ( player -- ) millis swap (>>last-move) ;
-
-: speed-range ( -- range )
- max-speed [0,b] ;
-
-: change-player-speed ( inc player -- )
- [ + speed-range clamp-to-range ] change-speed drop ;
-
-: multiply-player-speed ( n player -- )
- [ * speed-range clamp-to-range ] change-speed drop ;
-
-: distance-to-move ( seconds-passed player -- distance )
- speed>> * ;
-
-: bounce ( d-left player -- d-left' player )
- {
- [ dup nearest-segment>> bounce-off-wall ]
- [ sounds>> bang ]
- [ 3/4 swap multiply-player-speed ]
- [ ]
- } cleave ;
-
-:: (distance) ( heading player -- current next location heading )
- player nearest-segment>>
- player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
- player location>> heading ;
-
-: distance-to-heading-segment ( heading player -- distance )
- (distance) distance-to-next-segment ;
-
-: distance-to-heading-segment-area ( heading player -- distance )
- (distance) distance-to-next-segment-area ;
-
-: distance-to-collision ( player -- distance )
- dup nearest-segment>> (distance-to-collision) ;
-
-: from ( player -- radius distance-from-centre )
- [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
- distance-from-centre ;
-
-: distance-from-wall ( player -- distance ) from - ;
-: fraction-from-centre ( player -- fraction ) from swap / ;
-: fraction-from-wall ( player -- fraction )
- fraction-from-centre 1 swap - ;
-
-: update-nearest-segment2 ( heading player -- )
- 2dup distance-to-heading-segment-area 0 <= [
- [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
- [ (>>nearest-segment) ] tri
- ] [
- 2drop
- ] if ;
-
-:: move-player-on-heading ( d-left player distance heading -- d-left' player )
- [let* | d-to-move [ d-left distance min ]
- move-v [ d-to-move heading n*v ] |
- move-v player location+
- heading player update-nearest-segment2
- d-left d-to-move - player ] ;
-
-: move-toward-wall ( d-left player d-to-wall -- d-left' player )
- over [ forward>> ] keep distance-to-heading-segment-area min
- over forward>> move-player-on-heading ;
-
-: ?move-player-freely ( d-left player -- d-left' player )
- over 0 > [
- dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
- move-toward-wall ?move-player-freely
- ] [ drop ] if
- ] when ;
-
-: drag-heading ( player -- heading )
- [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
-
-: drag-player ( d-left player -- d-left' player )
- dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
- [ drag-heading move-player-on-heading ] bi ;
-
-: (move-player) ( d-left player -- d-left' player )
- ?move-player-freely over 0 > [
- ! bounce
- drag-player
- (move-player)
- ] when ;
-
-: move-player ( player -- )
- [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
-
-: update-player ( player -- )
- [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
+++ /dev/null
-USING: accessors io.files kernel openal sequences ;
-IN: jamshred.sound
-
-TUPLE: sounds bang ;
-
-: assign-sound ( source wav-path -- )
- resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
-
-: <sounds> ( -- sounds )
- init-openal 1 gen-sources first sounds boa
- dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
-
-: bang ( sounds -- ) bang>> source-play check-error ;
+++ /dev/null
-A simple 3d tunnel racing game
+++ /dev/null
-applications
-games
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test float-arrays ;
-IN: jamshred.tunnel.tests
-
-[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
- T{ segment f { 1 1 1 } f f f 1 }
- T{ oint f { 0 0 0.25 } }
- nearer-segment segment-number ] unit-test
-
-[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
-[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
-[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
-
-[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
-
-[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
-
-: test-segment-oint ( -- oint )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
-
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
-
-: simplest-straight-ahead ( -- oint segment )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
-[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
-
-: simple-collision-up ( -- oint segment )
- { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
-[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
-[ { 0 1 0 } ]
-[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
-USE: tools.walker
-IN: jamshred.tunnel
-
-: n-segments ( -- n ) 5000 ; inline
-
-TUPLE: segment < oint number color radius ;
-C: <segment> segment
-
-: segment-number++ ( segment -- )
- [ number>> 1+ ] keep (>>number) ;
-
-: random-color ( -- color )
- { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
-
-: tunnel-segment-distance ( -- n ) 0.4 ;
-: random-rotation-angle ( -- theta ) pi 20 / ;
-
-: random-segment ( previous-segment -- segment )
- clone dup random-rotation-angle random-turn
- tunnel-segment-distance over go-forward
- random-color over set-segment-color dup segment-number++ ;
-
-: (random-segments) ( segments n -- segments )
- dup 0 > [
- >r dup peek random-segment over push r> 1- (random-segments)
- ] [ drop ] if ;
-
-: default-segment-radius ( -- r ) 1 ;
-
-: initial-segment ( -- segment )
- F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
- 0 random-color default-segment-radius <segment> ;
-
-: random-segments ( n -- segments )
- initial-segment 1vector swap (random-segments) ;
-
-: simple-segment ( n -- segment )
- [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
- random-color default-segment-radius <segment> ;
-
-: simple-segments ( n -- segments )
- [ simple-segment ] map ;
-
-: <random-tunnel> ( -- segments )
- n-segments random-segments ;
-
-: <straight-tunnel> ( -- segments )
- n-segments simple-segments ;
-
-: sub-tunnel ( from to segments -- segments )
- #! return segments between from and to, after clamping from and to to
- #! valid values
- [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
-
-: nearer-segment ( segment segment oint -- segment )
- #! return whichever of the two segments is nearer to the oint
- >r 2dup r> tuck distance >r distance r> < -rot ? ;
-
-: (find-nearest-segment) ( nearest next oint -- nearest ? )
- #! find the nearest of 'next' and 'nearest' to 'oint', and return
- #! t if the nearest hasn't changed
- pick >r nearer-segment dup r> = ;
-
-: find-nearest-segment ( oint segments -- segment )
- dup first swap rest-slice rot [ (find-nearest-segment) ] curry
- find 2drop ;
-
-: nearest-segment-forward ( segments oint start -- segment )
- rot dup length swap <slice> find-nearest-segment ;
-
-: nearest-segment-backward ( segments oint start -- segment )
- swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
-
-: nearest-segment ( segments oint start-segment -- segment )
- #! find the segment nearest to 'oint', and return it.
- #! start looking at segment 'start-segment'
- segment-number over >r
- [ nearest-segment-forward ] 3keep
- nearest-segment-backward r> nearer-segment ;
-
-: get-segment ( segments n -- segment )
- over sequence-index-range clamp-to-range swap nth ;
-
-: next-segment ( segments current-segment -- segment )
- number>> 1+ get-segment ;
-
-: previous-segment ( segments current-segment -- segment )
- number>> 1- get-segment ;
-
-: heading-segment ( segments current-segment heading -- segment )
- #! the next segment on the given heading
- over forward>> v. 0 <=> {
- { +gt+ [ next-segment ] }
- { +lt+ [ previous-segment ] }
- { +eq+ [ nip ] } ! current segment
- } case ;
-
-:: distance-to-next-segment ( current next location heading -- distance )
- [let | cf [ current forward>> ] |
- cf next location>> v. cf location v. - cf heading v. / ] ;
-
-:: distance-to-next-segment-area ( current next location heading -- distance )
- [let | cf [ current forward>> ]
- h [ next current half-way-between-oints ] |
- cf h v. cf location v. - cf heading v. / ] ;
-
-: vector-to-centre ( seg loc -- v )
- over location>> swap v- swap forward>> proj-perp ;
-
-: distance-from-centre ( seg loc -- distance )
- vector-to-centre norm ;
-
-: wall-normal ( seg oint -- n )
- location>> vector-to-centre normalize ;
-
-: distant ( -- n ) 1000 ;
-
-: max-real ( a b -- c )
- #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
- dup real? [
- over real? [ max ] [ nip ] if
- ] [
- drop dup real? [ drop distant ] unless
- ] if ;
-
-:: collision-coefficient ( v w r -- c )
- v norm 0 = [
- distant
- ] [
- [let* | a [ v dup v. ]
- b [ v w v. 2 * ]
- c [ w dup v. r sq - ] |
- c b a quadratic max-real ]
- ] if ;
-
-: sideways-heading ( oint segment -- v )
- [ forward>> ] bi@ proj-perp ;
-
-: sideways-relative-location ( oint segment -- loc )
- [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
-
-: (distance-to-collision) ( oint segment -- distance )
- [ sideways-heading ] [ sideways-relative-location ]
- [ nip radius>> ] 2tri collision-coefficient ;
-
-: collision-vector ( oint segment -- v )
- dupd (distance-to-collision) swap forward>> n*v ;
-
-: bounce-forward ( segment oint -- )
- [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
-
-: bounce-left ( segment oint -- )
- #! must be done after forward
- [ forward>> vneg ] dip [ left>> swap reflect ]
- [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
-
-: bounce-up ( segment oint -- )
- #! must be done after forward and left!
- nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
-
-: bounce-off-wall ( oint segment -- )
- swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
-
+++ /dev/null
-This is a simple tetris game. To play, open factor (in GUI mode), and run:
-
-"tetris" run
-
-This should open a new window with a running tetris game. The commands are:
-
-left, right arrows: move the current piece left or right
-up arrow: rotate the piece clockwise
-down arrow: lower the piece one row
-space bar: drop the piece
-p: pause/unpause
-n: start a new game
-
-TODO:
-- rotation of pieces when they're on the far right of the board
-- make blocks prettier
+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: kernel tetris.board tetris.piece tools.test arrays
-colors ;
-
-[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test
-[ { { f f } { f f } { f f } } ] [ 2 3 <board> board-rows ] unit-test
-[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
-[ f ] [ 2 3 <board> { 1 1 } board-block ] unit-test
-[ 2 3 <board> { 2 3 } board-block ] must-fail
-red 1array [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test
-[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 2 } block-free? ] unit-test
-[ t ] [ 2 3 <board> dup { 1 1 } red board-set-block { 0 1 } block-free? ] unit-test
-[ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
-[ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
-[ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
-[ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
-[ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
-[ f ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } location-valid? ] unit-test
-[ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
-[ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } over set-piece-location piece-valid? ] unit-test
-[ { { f } { f } } ] [ 1 1 <board> dup add-row board-rows ] unit-test
-[ { { f } } ] [ 1 2 <board> dup { 0 1 } red board-set-block dup remove-full-rows board-rows ] unit-test
-[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red board-set-block dup check-rows drop board-rows ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays tetris.piece math ;
-IN: tetris.board
-
-TUPLE: board width height rows ;
-
-: make-rows ( width height -- rows )
- [ drop f <array> ] with map ;
-
-: <board> ( width height -- board )
- 2dup make-rows board boa ;
-
-#! A block is simply an array of form { x y } where { 0 0 } is the top-left of
-#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board.
-
-: board@block ( board block -- n row )
- [ second swap board-rows nth ] keep first swap ;
-
-: board-set-block ( board block colour -- ) -rot board@block set-nth ;
-
-: board-block ( board block -- colour ) board@block nth ;
-
-: block-free? ( board block -- ? ) board-block not ;
-
-: block-in-bounds? ( board block -- ? )
- [ first swap board-width bounds-check? ] 2keep
- second swap board-height bounds-check? and ;
-
-: location-valid? ( board block -- ? )
- 2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
-
-: piece-valid? ( board piece -- ? )
- piece-blocks [ location-valid? ] with all? ;
-
-: row-not-full? ( row -- ? ) f swap member? ;
-
-: add-row ( board -- )
- dup board-rows over board-width f <array>
- prefix swap set-board-rows ;
-
-: top-up-rows ( board -- )
- dup board-height over board-rows length = [
- drop
- ] [
- dup add-row top-up-rows
- ] if ;
-
-: remove-full-rows ( board -- )
- dup board-rows [ row-not-full? ] filter swap set-board-rows ;
-
-: check-rows ( board -- n )
- #! remove full rows, then add blank ones at the top, returning the number
- #! of rows removed (and added)
- dup remove-full-rows dup board-height over board-rows length - >r top-up-rows r> ;
-
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Tetris" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: kernel tetris.game tetris.board tetris.piece tools.test
-sequences ;
-
-[ t ] [ <default-tetris> dup tetris-current-piece swap tetris-next-piece and t f ? ] unit-test
-[ t ] [ <default-tetris> { 1 1 } can-move? ] unit-test
-[ t ] [ <default-tetris> { 1 1 } tetris-move ] unit-test
-[ 1 ] [ <default-tetris> dup { 1 1 } tetris-move drop tetris-current-piece piece-location second ] unit-test
-[ 1 ] [ <default-tetris> tetris-level ] unit-test
-[ 1 ] [ <default-tetris> 9 over set-tetris-rows tetris-level ] unit-test
-[ 2 ] [ <default-tetris> 10 over set-tetris-rows tetris-level ] unit-test
-[ 0 ] [ 3 0 rows-score ] unit-test
-[ 80 ] [ 1 1 rows-score ] unit-test
-[ 4800 ] [ 3 4 rows-score ] unit-test
-[ 1 ] [ <default-tetris> dup 3 score-rows dup 3 score-rows dup 3 score-rows tetris-level ] unit-test
-[ 2 ] [ <default-tetris> dup 4 score-rows dup 4 score-rows dup 2 score-rows tetris-level ] unit-test
-
+++ /dev/null
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math math.functions tetris.board
-tetris.piece tetris.tetromino lists combinators system ;
-IN: tetris.game
-
-TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
-
-: default-width 10 ; inline
-: default-height 20 ; inline
-
-: <tetris> ( width height -- tetris )
- <board> tetris construct-delegate
- dup board-width <piece-llist> over set-tetris-pieces
- 0 over set-tetris-last-update
- 0 over set-tetris-rows
- 0 over set-tetris-score
- f over set-tetris-paused?
- t over set-tetris-running? ;
-
-: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
-
-: <new-tetris> ( old -- new )
- [ board-width ] keep board-height <tetris> ;
-
-: tetris-board ( tetris -- board ) delegate ;
-
-: tetris-current-piece ( tetris -- piece ) tetris-pieces car ;
-
-: tetris-next-piece ( tetris -- piece ) tetris-pieces cdr car ;
-
-: toggle-pause ( tetris -- )
- dup tetris-paused? not swap set-tetris-paused? ;
-
-: tetris-level ( tetris -- level )
- tetris-rows 1+ 10 / ceiling ;
-
-: tetris-update-interval ( tetris -- interval )
- tetris-level 1- 60 * 1000 swap - ;
-
-: add-block ( tetris block -- )
- over tetris-current-piece tetromino-colour board-set-block ;
-
-: game-over? ( tetris -- ? )
- dup tetris-next-piece piece-valid? not ;
-
-: new-current-piece ( tetris -- )
- dup game-over? [
- f swap set-tetris-running?
- ] [
- dup tetris-pieces cdr swap set-tetris-pieces
- ] if ;
-
-: rows-score ( level n -- score )
- {
- { 0 [ 0 ] }
- { 1 [ 40 ] }
- { 2 [ 100 ] }
- { 3 [ 300 ] }
- { 4 [ 1200 ] }
- } case swap 1+ * ;
-
-: add-score ( tetris score -- )
- over tetris-score + swap set-tetris-score ;
-
-: score-rows ( tetris n -- )
- 2dup >r dup tetris-level r> rows-score add-score
- over tetris-rows + swap set-tetris-rows ;
-
-: lock-piece ( tetris -- )
- [ dup tetris-current-piece piece-blocks [ add-block ] with each ] keep
- dup new-current-piece dup check-rows score-rows ;
-
-: can-rotate? ( tetris -- ? )
- dup tetris-current-piece clone dup 1 rotate-piece piece-valid? ;
-
-: (rotate) ( inc tetris -- )
- dup can-rotate? [ tetris-current-piece swap rotate-piece ] [ 2drop ] if ;
-
-: rotate-left ( tetris -- ) -1 swap (rotate) ;
-
-: rotate-right ( tetris -- ) 1 swap (rotate) ;
-
-: can-move? ( tetris move -- ? )
- >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
-
-: tetris-move ( tetris move -- ? )
- #! moves the piece if possible, returns whether the piece was moved
- 2dup can-move? [
- >r tetris-current-piece r> move-piece t
- ] [
- 2drop f
- ] if ;
-
-: move-left ( tetris -- ) { -1 0 } tetris-move drop ;
-
-: move-right ( tetris -- ) { 1 0 } tetris-move drop ;
-
-: move-down ( tetris -- )
- dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
-
-: move-drop ( tetris -- )
- dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
-
-: update ( tetris -- )
- millis over tetris-last-update -
- over tetris-update-interval > [
- dup move-down
- millis swap set-tetris-last-update
- ] [ drop ] if ;
-
-: maybe-update ( tetris -- )
- dup tetris-paused? over tetris-running? not or [ drop ] [ update ] if ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays math math.vectors namespaces
-opengl opengl.gl ui.render ui.gadgets tetris.game tetris.board
-tetris.piece tetris.tetromino ;
-IN: tetris.gl
-
-#! OpenGL rendering for tetris
-
-: draw-block ( block -- )
- dup { 1 1 } v+ gl-fill-rect ;
-
-: draw-piece-blocks ( piece -- )
- piece-blocks [ draw-block ] each ;
-
-: draw-piece ( piece -- )
- dup tetromino-colour gl-color draw-piece-blocks ;
-
-: draw-next-piece ( piece -- )
- dup tetromino-colour clone 0.2 3 pick set-nth gl-color draw-piece-blocks ;
-
-! TODO: move implementation specific stuff into tetris-board
-: (draw-row) ( x y row -- )
- >r over r> nth dup
- [ gl-color 2array draw-block ] [ 3drop ] if ;
-
-: draw-row ( y row -- )
- dup length -rot [ (draw-row) ] 2curry each ;
-
-: draw-board ( board -- )
- board-rows dup length swap
- [ dupd nth draw-row ] curry each ;
-
-: scale-tetris ( width height tetris -- )
- [ board-width swap ] keep board-height / -rot / swap 1 glScalef ;
-
-: (draw-tetris) ( width height tetris -- )
- #! width and height are in pixels
- GL_MODELVIEW [
- [ scale-tetris ] keep
- dup tetris-board draw-board
- dup tetris-next-piece draw-next-piece
- tetris-current-piece draw-piece
- ] do-matrix ;
-
-: draw-tetris ( width height tetris -- )
- origin get [ (draw-tetris) ] with-translation ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: kernel tetris.tetromino tetris.piece tools.test sequences arrays namespaces ;
-
-! Tests for tetris.tetromino and tetris.piece, since there's not much to test in tetris.tetromino
-
-! these two tests rely on the first rotation of the first tetromino being the
-! 'I' tetromino in its vertical orientation.
-[ 4 ] [ tetrominoes get first tetromino-states first blocks-width ] unit-test
-[ 1 ] [ tetrominoes get first tetromino-states first blocks-height ] unit-test
-
-[ { 0 0 } ] [ random-tetromino <piece> piece-location ] unit-test
-[ 0 ] [ 10 <random-piece> piece-rotation ] unit-test
-
-[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ]
-[ tetrominoes get first <piece> piece-blocks ] unit-test
-
-[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ]
-[ tetrominoes get first <piece> dup 1 rotate-piece piece-blocks ] unit-test
-
-[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ]
-[ tetrominoes get first <piece> dup { 1 1 } move-piece piece-blocks ] unit-test
-
-[ 3 ] [ tetrominoes get second <piece> piece-width ] unit-test
-[ 2 ] [ tetrominoes get second <piece> dup 1 rotate-piece piece-width ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays tetris.tetromino math math.vectors
-sequences quotations lists.lazy ;
-IN: tetris.piece
-
-#! A piece adds state to the tetromino that is the piece's delegate. The
-#! rotation is an index into the tetromino's states array, and the position is
-#! added to the tetromino's blocks to give them their location on the tetris
-#! board. If the location is f then the piece is not yet on the board.
-TUPLE: piece rotation location ;
-
-: <piece> ( tetromino -- piece )
- piece construct-delegate
- 0 over set-piece-rotation
- { 0 0 } over set-piece-location ;
-
-: (piece-blocks) ( piece -- blocks )
- #! rotates the tetromino
- dup piece-rotation swap tetromino-states nth ;
-
-: piece-blocks ( piece -- blocks )
- #! rotates and positions the tetromino
- dup (piece-blocks) swap piece-location [ v+ ] curry map ;
-
-: piece-width ( piece -- width )
- piece-blocks blocks-width ;
-
-: set-start-location ( piece board-width -- )
- 2 /i over piece-width 2 /i - 0 2array swap set-piece-location ;
-
-: <random-piece> ( board-width -- piece )
- random-tetromino <piece> [ swap set-start-location ] keep ;
-
-: <piece-llist> ( board-width -- llist )
- [ [ <random-piece> ] curry ] keep [ <piece-llist> ] curry lazy-cons ;
-
-: modulo ( n m -- n )
- #! -2 7 mod => -2, -2 7 modulo => 5
- tuck mod over + swap mod ;
-
-: rotate-piece ( piece inc -- )
- over piece-rotation + over tetromino-states length modulo swap set-piece-rotation ;
-
-: move-piece ( piece move -- )
- over piece-location v+ swap set-piece-location ;
-
+++ /dev/null
-Graphical Tetris game
+++ /dev/null
-demos
-applications
-games
+++ /dev/null
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels
-ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui
-tetris.game tetris.gl sequences system math math.parser namespaces
-math.geometry.rect ;
-IN: tetris
-
-TUPLE: tetris-gadget tetris alarm ;
-
-: <tetris-gadget> ( tetris -- gadget )
- tetris-gadget construct-gadget
- [ set-tetris-gadget-tetris ] keep ;
-
-M: tetris-gadget pref-dim* drop { 200 400 } ;
-
-: update-status ( gadget -- )
- dup tetris-gadget-tetris [
- "Level: " % dup tetris-level #
- " Score: " % tetris-score #
- ] "" make swap show-status ;
-
-M: tetris-gadget draw-gadget* ( gadget -- )
- [
- dup rect-dim dup first swap second rot tetris-gadget-tetris draw-tetris
- ] keep update-status ;
-
-: new-tetris ( gadget -- )
- dup tetris-gadget-tetris <new-tetris> swap set-tetris-gadget-tetris ;
-
-tetris-gadget H{
- { T{ key-down f f "UP" } [ tetris-gadget-tetris rotate-right ] }
- { T{ key-down f f "d" } [ tetris-gadget-tetris rotate-left ] }
- { T{ key-down f f "f" } [ tetris-gadget-tetris rotate-right ] }
- { T{ key-down f f "e" } [ tetris-gadget-tetris rotate-left ] } ! dvorak d
- { T{ key-down f f "u" } [ tetris-gadget-tetris rotate-right ] } ! dvorak f
- { T{ key-down f f "LEFT" } [ tetris-gadget-tetris move-left ] }
- { T{ key-down f f "RIGHT" } [ tetris-gadget-tetris move-right ] }
- { T{ key-down f f "DOWN" } [ tetris-gadget-tetris move-down ] }
- { T{ key-down f f " " } [ tetris-gadget-tetris move-drop ] }
- { T{ key-down f f "p" } [ tetris-gadget-tetris toggle-pause ] }
- { T{ key-down f f "n" } [ new-tetris ] }
-} set-gestures
-
-: tick ( gadget -- )
- dup tetris-gadget-tetris maybe-update relayout-1 ;
-
-M: tetris-gadget graft* ( gadget -- )
- dup [ tick ] curry 100 milliseconds every
- swap set-tetris-gadget-alarm ;
-
-M: tetris-gadget ungraft* ( gadget -- )
- [ tetris-gadget-alarm cancel-alarm f ] keep set-tetris-gadget-alarm ;
-
-: tetris-window ( -- )
- [
- <default-tetris> <tetris-gadget>
- "Tetris" open-status-window
- ] with-ui ;
-
-MAIN: tetris-window
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays namespaces sequences math math.vectors
-colors random ;
-IN: tetris.tetromino
-
-TUPLE: tetromino states colour ;
-
-C: <tetromino> tetromino
-
-SYMBOL: tetrominoes
-
-{
- [
- { {
- { 0 0 } { 1 0 } { 2 0 } { 3 0 }
- }
- { { 0 0 }
- { 0 1 }
- { 0 2 }
- { 0 3 }
- }
- } cyan
- ] [
- {
- { { 1 0 }
- { 0 1 } { 1 1 } { 2 1 }
- } {
- { 0 0 }
- { 0 1 } { 1 1 }
- { 0 2 }
- } {
- { 0 0 } { 1 0 } { 2 0 }
- { 1 1 }
- } {
- { 1 0 }
- { 0 1 } { 1 1 }
- { 1 2 }
- }
- } purple
- ] [
- { { { 0 0 } { 1 0 }
- { 0 1 } { 1 1 } }
- } yellow
- ] [
- {
- { { 0 0 } { 1 0 } { 2 0 }
- { 0 1 }
- } {
- { 0 0 } { 1 0 }
- { 1 1 }
- { 1 2 }
- } {
- { 2 0 }
- { 0 1 } { 1 1 } { 2 1 }
- } {
- { 0 0 }
- { 0 1 }
- { 0 2 } { 1 2 }
- }
- } orange
- ] [
- {
- { { 0 0 } { 1 0 } { 2 0 }
- { 2 1 }
- } {
- { 1 0 }
- { 1 1 }
- { 0 2 } { 1 2 }
- } {
- { 0 0 }
- { 0 1 } { 1 1 } { 2 1 }
- } {
- { 0 0 } { 1 0 }
- { 0 1 }
- { 0 2 }
- }
- } blue
- ] [
- {
- { { 1 0 } { 2 0 }
- { 0 1 } { 1 1 }
- } {
- { 0 0 }
- { 0 1 } { 1 1 }
- { 1 2 }
- }
- } green
- ] [
- {
- {
- { 0 0 } { 1 0 }
- { 1 1 } { 2 1 }
- } {
- { 1 0 }
- { 0 1 } { 1 1 }
- { 0 2 }
- }
- } red
- ]
-} [ call <tetromino> ] map tetrominoes set-global
-
-: random-tetromino ( -- tetromino )
- tetrominoes get random ;
-
-: blocks-max ( blocks quot -- max )
- map [ 1+ ] map supremum ; inline
-
-: blocks-width ( blocks -- width )
- [ first ] blocks-max ;
-
-: blocks-height ( blocks -- height )
- [ second ] blocks-max ;
-
void factorbug(void)
{
+ if(fep_disabled)
+ {
+ printf("Low level debugger disabled\n");
+ exit(1);
+ }
+
open_console();
printf("Starting low level debugger...\n");
dump stacks. This is useful for builder and
other cases where Factor is run with stdin
redirected to /dev/null */
+ fep_disabled = true;
+
print_datastack();
print_retainstack();
print_callstack();
void factorbug(void);
void dump_zone(F_ZONE *z);
+bool fep_disabled;
+
DECLARE_PRIMITIVE(die);
crash. */
else
{
- fprintf(stderr,"You have triggered a bug in Factor. Please report.\n");
- fprintf(stderr,"early_error: ");
+ printf("You have triggered a bug in Factor. Please report.\n");
+ printf("early_error: ");
print_obj(error);
- fprintf(stderr,"\n");
+ printf("\n");
factorbug();
}
}
#ifndef KERN_PROC_PATHNAME
#define KERN_PROC_PATHNAME 12
#endif
-
-#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
-#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
-
-#ifndef environ
- extern char **environ;
-#endif
#include <sys/syscall.h>
-#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
-#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
-
-#ifndef environ
- extern char **environ;
-#endif
-
int inotify_init(void);
int inotify_add_watch(int fd, const char *name, u32 mask);
int inotify_rm_watch(int fd, u32 wd);
#define DLLEXPORT __attribute__((visibility("default")))
#define FACTOR_OS_STRING "macosx"
#define NULL_DLL "libfactor.dylib"
-#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
-#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
void init_signals(void);
void early_init(void);
DLLEXPORT void c_to_factor_toplevel(CELL quot);
-#ifndef environ
- extern char ***_NSGetEnviron(void);
- #define environ (*_NSGetEnviron())
-#endif
-
INLINE void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
-
-extern char **environ;
+++ /dev/null
-#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
-#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
-
-#ifndef environ
- extern char **environ;
-#endif
+++ /dev/null
-#define UNKNOWN_TYPE_P(file) 1
-#define DIRECTORY_P(file) 0
-
-extern char **environ;
box_boolean(stat(unbox_char_string(),&sb) >= 0);
}
-/* Allocates memory */
-CELL parse_dir_entry(struct dirent *file)
-{
- CELL name = tag_object(from_char_string(file->d_name));
- if(UNKNOWN_TYPE_P(file))
- return name;
- else
- {
- CELL dirp = tag_boolean(DIRECTORY_P(file));
- return allot_array_2(name,dirp);
- }
-}
-
-DEFINE_PRIMITIVE(read_dir)
-{
- DIR* dir = opendir(unbox_char_string());
- GROWABLE_ARRAY(result);
- REGISTER_ROOT(result);
-
- if(dir != NULL)
- {
- struct dirent* file;
-
- while((file = readdir(dir)) != NULL)
- {
- CELL pair = parse_dir_entry(file);
- GROWABLE_ARRAY_ADD(result,pair);
- }
-
- closedir(dir);
- }
-
- UNREGISTER_ROOT(result);
- GROWABLE_ARRAY_TRIM(result);
-
- dpush(result);
-}
-
-DEFINE_PRIMITIVE(os_env)
-{
- char *name = unbox_char_string();
- char *value = getenv(name);
- if(value == NULL)
- dpush(F);
- else
- box_char_string(value);
-}
-
-DEFINE_PRIMITIVE(os_envs)
-{
- GROWABLE_ARRAY(result);
- REGISTER_ROOT(result);
- char **env = environ;
-
- while(*env)
- {
- CELL string = tag_object(from_char_string(*env));
- GROWABLE_ARRAY_ADD(result,string);
- env++;
- }
-
- UNREGISTER_ROOT(result);
- GROWABLE_ARRAY_TRIM(result);
- dpush(result);
-}
-
-DEFINE_PRIMITIVE(set_os_env)
-{
- char *key = unbox_char_string();
- REGISTER_C_STRING(key);
- char *value = unbox_char_string();
- UNREGISTER_C_STRING(key);
- setenv(key, value, 1);
-}
-
-DEFINE_PRIMITIVE(unset_os_env)
-{
- char *key = unbox_char_string();
- unsetenv(key);
-}
-
-DEFINE_PRIMITIVE(set_os_envs)
-{
- F_ARRAY *array = untag_array(dpop());
- CELL size = array_capacity(array);
-
- /* Memory leak */
- char **env = calloc(size + 1,sizeof(CELL));
-
- CELL i;
- for(i = 0; i < size; i++)
- {
- F_STRING *string = untag_string(array_nth(array,i));
- CELL length = to_fixnum(string->length);
-
- char *chars = malloc(length + 1);
- char_string_to_memory(string,chars);
- chars[length] = '\0';
- env[i] = chars;
- }
-
- environ = env;
-}
-
F_SEGMENT *alloc_segment(CELL size)
{
int pagesize = getpagesize();
- EPOCH_OFFSET) / 10000;
}
-DEFINE_PRIMITIVE(os_envs)
-{
- GROWABLE_ARRAY(result);
- REGISTER_ROOT(result);
-
- TCHAR *env = GetEnvironmentStrings();
- TCHAR *finger = env;
-
- for(;;)
- {
- TCHAR *scan = finger;
- while(*scan != '\0')
- scan++;
- if(scan == finger)
- break;
-
- CELL string = tag_object(from_u16_string(finger));
- GROWABLE_ARRAY_ADD(result,string);
-
- finger = scan + 1;
- }
-
- FreeEnvironmentStrings(env);
-
- UNREGISTER_ROOT(result);
- GROWABLE_ARRAY_TRIM(result);
- dpush(result);
-}
-
long exception_handler(PEXCEPTION_POINTERS pe)
{
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
return safe_strdup(full_path);
}
-void find_file_stat(F_CHAR *path)
-{
- // FindFirstFile is the only call that can stat c:\pagefile.sys
- WIN32_FIND_DATA st;
- HANDLE h;
-
- if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
- dpush(F);
- else
- {
- FindClose(h);
- dpush(T);
- }
-}
-
DEFINE_PRIMITIVE(existsp)
{
BY_HANDLE_FILE_INFORMATION bhfi;
CloseHandle(h);
}
-DEFINE_PRIMITIVE(read_dir)
-{
- HANDLE dir;
- WIN32_FIND_DATA find_data;
- F_CHAR *path = unbox_u16_string();
-
- GROWABLE_ARRAY(result);
- REGISTER_ROOT(result);
-
- if(INVALID_HANDLE_VALUE != (dir = FindFirstFile(path, &find_data)))
- {
- do
- {
- CELL name = tag_object(from_u16_string(find_data.cFileName));
- CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
- CELL pair = allot_array_2(name,dirp);
- GROWABLE_ARRAY_ADD(result,pair);
- }
- while (FindNextFile(dir, &find_data));
- FindClose(dir);
- }
-
- UNREGISTER_ROOT(result);
- GROWABLE_ARRAY_TRIM(result);
-
- dpush(result);
-}
-
F_SEGMENT *alloc_segment(CELL size)
{
char *mem;
{
Sleep(msec);
}
-
-DEFINE_PRIMITIVE(os_env)
-{
- F_CHAR *key = unbox_u16_string();
- F_CHAR *value = safe_malloc(MAX_UNICODE_PATH * 2);
- int ret;
- ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH * 2);
- if(ret == 0)
- dpush(F);
- else
- dpush(tag_object(from_u16_string(value)));
- free(value);
-}
-
-DEFINE_PRIMITIVE(set_os_env)
-{
- F_CHAR *key = unbox_u16_string();
- REGISTER_C_STRING(key);
- F_CHAR *value = unbox_u16_string();
- UNREGISTER_C_STRING(key);
- if(!SetEnvironmentVariable(key, value))
- general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
-}
-
-DEFINE_PRIMITIVE(unset_os_env)
-{
- if(!SetEnvironmentVariable(unbox_u16_string(), NULL)
- && GetLastError() != ERROR_ENVVAR_NOT_FOUND)
- general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
-}
-
-DEFINE_PRIMITIVE(set_os_envs)
-{
- not_implemented_error();
-}
#endif
#elif defined(__OpenBSD__)
#define FACTOR_OS_STRING "openbsd"
- #include "os-openbsd.h"
#if defined(FACTOR_X86)
#include "os-openbsd-x86.32.h"
#error "Unsupported Solaris flavor"
#endif
- #include "os-solaris.h"
#else
#error "Unsupported OS"
#endif
primitive_getenv,
primitive_setenv,
primitive_existsp,
- primitive_read_dir,
primitive_gc,
primitive_gc_stats,
primitive_save_image,
primitive_exit,
primitive_data_room,
primitive_code_room,
- primitive_os_env,
primitive_millis,
primitive_modify_code_heap,
primitive_dlopen,
primitive_innermost_stack_frame_scan,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
- primitive_os_envs,
- primitive_set_os_env,
- primitive_unset_os_env,
- primitive_set_os_envs,
primitive_resize_byte_array,
primitive_dll_validp,
primitive_unimplemented,
projects / factor.git / commitdiff