From 32dfcd36ac5213bee3b361348239245ddbf67dd2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 10 Sep 2008 20:19:57 -0700 Subject: [PATCH 001/224] more cocoa 64-bit type fixes --- basis/cocoa/messages/messages.factor | 12 +++---- basis/cocoa/types/types.factor | 54 ++++++++++++++++++---------- basis/ui/cocoa/views/views.factor | 4 +-- 3 files changed, 43 insertions(+), 27 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 7be649416c..ba7034d012 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -108,12 +108,12 @@ H{ { "c" "char" } { "i" "int" } { "s" "short" } - { "l" "long" } + { "l" "int" } { "q" "longlong" } { "C" "uchar" } { "I" "uint" } { "S" "ushort" } - { "L" "ulong" } + { "L" "uint" } { "Q" "ulonglong" } { "f" "float" } { "d" "double" } @@ -133,14 +133,14 @@ objc>alien-types get [ swap ] assoc-map "ptrdiff_t" heap-size { { 4 [ H{ { "NSPoint" "{_NSPoint=ff}" } - { "NSRect" "{_NSRect=ffff}" } + { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" } { "NSSize" "{_NSSize=ff}" } { "NSRange" "{_NSRange=II}" } } ] } { 8 [ H{ - { "NSPoint" "{_NSPoint=dd}" } - { "NSRect" "{_NSRect=dddd}" } - { "NSSize" "{_NSSize=dd}" } + { "NSPoint" "{CGPoint=dd}" } + { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" } + { "NSSize" "{CGSize=dd}" } { "NSRange" "{_NSRange=QQ}" } } ] } } case diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index 6e65bc1a72..acc717a61c 100644 --- a/basis/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -10,25 +10,6 @@ TYPEDEF: ulong NSUInteger { 8 [ "double" ] } } case "CGFloat" typedef >> -C-STRUCT: NSRect - { "CGFloat" "x" } - { "CGFloat" "y" } - { "CGFloat" "w" } - { "CGFloat" "h" } ; - -TYPEDEF: NSRect _NSRect -TYPEDEF: NSRect CGRect - -: ( x y w h -- rect ) - "NSRect" - [ 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" } ; @@ -53,6 +34,41 @@ TYPEDEF: NSPoint CGPoint [ 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 + +: ( x y w h -- rect ) + "NSRect" + [ 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" } ; diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 45ab8ac0ce..772770133d 100755 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -128,8 +128,8 @@ CLASS: { } ! Rendering -{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" } - [ 3drop window relayout-1 ] +{ "drawRect:" "void" { "id" "SEL" "NSRect" } + [ 2drop window relayout-1 ] } ! Events From 6575c068165295b8757c8768e61fd22b385d31a8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 10 Sep 2008 21:28:38 -0700 Subject: [PATCH 002/224] oops--broke the alien>objc-types reverse mapping --- basis/cocoa/messages/messages.factor | 22 +++++++++++++++++----- basis/cocoa/types/types.factor | 7 ++++++- 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index ba7034d012..623bfc961a 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -108,22 +108,34 @@ H{ { "c" "char" } { "i" "int" } { "s" "short" } - { "l" "int" } - { "q" "longlong" } { "C" "uchar" } { "I" "uint" } { "S" "ushort" } - { "L" "uint" } - { "Q" "ulonglong" } { "f" "float" } { "d" "double" } { "B" "bool" } { "v" "void" } { "*" "char*" } + { "?" "unknown_type" } { "@" "id" } { "#" "id" } { ":" "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 diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index acc717a61c..d02865fe43 100644 --- a/basis/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -27,7 +27,7 @@ C-STRUCT: NSSize { "CGFloat" "h" } ; TYPEDEF: NSSize _NSSize -TYPEDEF: NSPoint CGPoint +TYPEDEF: NSSize CGSize : ( w h -- size ) "NSSize" @@ -75,6 +75,11 @@ C-STRUCT: NSRange TYPEDEF: NSRange _NSRange +! The "lL" type encodings refer to 32-bit values even in 64-bit mode +TYPEDEF: int long32 +TYPEDEF: uint long32 +TYPEDEF: void* unknown_type + : ( length location -- size ) "NSRange" [ set-NSRange-length ] keep From 8c8dd51136e5e2c1fa8e99c550766b9e501ddeb1 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 10 Sep 2008 21:40:41 -0700 Subject: [PATCH 003/224] one more cocoa type bug --- basis/cocoa/messages/messages.factor | 22 ++++++++++++++-------- basis/ui/cocoa/views/views.factor | 2 +- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 623bfc961a..1b804c3cf1 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -144,16 +144,22 @@ objc>alien-types get [ swap ] assoc-map ! A hack... "ptrdiff_t" heap-size { { 4 [ H{ - { "NSPoint" "{_NSPoint=ff}" } - { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" } - { "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" "{CGPoint=dd}" } - { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" } - { "NSSize" "{CGSize=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 diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 772770133d..a13d8f86df 100755 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -329,7 +329,7 @@ CLASS: { [ 3drop 0 0 0 0 ] } -{ "conversationIdentifier" "long" { "id" "SEL" } +{ "conversationIdentifier" "NSInteger" { "id" "SEL" } [ drop alien-address ] } From 7eb6ceb08ca0261e130fe6c892d9e916caec6705 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 11 Sep 2008 21:35:52 -0700 Subject: [PATCH 004/224] typo --- basis/cocoa/types/types.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index d02865fe43..a76e74d9aa 100644 --- a/basis/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -77,7 +77,7 @@ TYPEDEF: NSRange _NSRange ! The "lL" type encodings refer to 32-bit values even in 64-bit mode TYPEDEF: int long32 -TYPEDEF: uint long32 +TYPEDEF: uint ulong32 TYPEDEF: void* unknown_type : ( length location -- size ) From f6ac828f4628babb638e309a6ca81fd674e5bca8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 12 Sep 2008 20:01:07 -0700 Subject: [PATCH 005/224] yup, more type bugs --- basis/cocoa/messages/messages.factor | 2 +- basis/cocoa/subclassing/subclassing.factor | 10 +++++---- basis/ui/cocoa/views/views.factor | 26 +++++++++++----------- 3 files changed, 20 insertions(+), 18 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 93de7658ef..3ec42ee65d 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -117,7 +117,7 @@ H{ { "*" "char*" } { "?" "unknown_type" } { "@" "id" } - { "#" "id" } + { "#" "Class" } { ":" "SEL" } } "ptrdiff_t" heap-size { diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index 3f8e709df0..ec15c0b514 100755 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -9,15 +9,17 @@ IN: cocoa.subclassing : init-method ( method -- sel imp types ) first3 swap - [ sel_registerName ] [ execute ] [ ascii string>alien ] - tri* ; + [ sel_registerName ] [ execute ] [ ascii string>alien ] ; + +: 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 diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index a13d8f86df..c6942a8158 100755 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -133,7 +133,7 @@ CLASS: { } ! Events -{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" } +{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" } [ 3drop 1 ] } @@ -251,7 +251,7 @@ CLASS: { ! "rotateWithEvent:" "void" { "id" "SEL" "id" }} -{ "acceptsFirstResponder" "bool" { "id" "SEL" } +{ "acceptsFirstResponder" "char" { "id" "SEL" } [ 2drop 1 ] } @@ -264,26 +264,26 @@ CLASS: { ] } -{ "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 ] } @@ -293,7 +293,7 @@ CLASS: { [ [ nip send-user-input ] ui-try ] } -{ "hasMarkedText" "bool" { "id" "SEL" } +{ "hasMarkedText" "char" { "id" "SEL" } [ 2drop 0 ] } @@ -321,7 +321,7 @@ CLASS: { [ 3drop f ] } -{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" } +{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" } [ 3drop 0 ] } @@ -394,9 +394,9 @@ CLASS: { ] } -{ "windowShouldClose:" "bool" { "id" "SEL" "id" } +{ "windowShouldClose:" "char" { "id" "SEL" "id" } [ - 3drop t + 3drop 1 ] } From 3e0ea36346f4b20e7ceaed1ade630da6a02baea0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 12 Sep 2008 20:18:47 -0700 Subject: [PATCH 006/224] cleanup on aisle 5 --- basis/cocoa/subclassing/subclassing.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index ec15c0b514..fd18c7fa89 100755 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -9,17 +9,20 @@ IN: cocoa.subclassing : init-method ( method -- sel imp types ) first3 swap - [ sel_registerName ] [ execute ] [ ascii string>alien ] ; + [ sel_registerName ] [ execute ] [ ascii string>alien ] + tri* ; : throw-if-false ( YES/NO -- ) - zero? [ "Failed to add method or protocol to class" throw ] when ; + zero? [ "Failed to add method or protocol to class" throw ] + when ; : add-methods ( methods class -- ) swap [ init-method class_addMethod throw-if-false ] with each ; : add-protocols ( protocols class -- ) - swap [ objc-protocol class_addProtocol throw-if-false ] with each ; + swap [ objc-protocol class_addProtocol throw-if-false ] + with each ; : (define-objc-class) ( protocols superclass name imeth -- ) -rot From a4210afd62befe77b98a39e2e3f107a080187376 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 13 Sep 2008 09:32:47 -0700 Subject: [PATCH 007/224] some debugging aids for cocoa libs --- basis/cocoa/messages/messages.factor | 21 ++++++++++++++++----- basis/cocoa/runtime/runtime.factor | 5 ++++- 2 files changed, 20 insertions(+), 6 deletions(-) diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 3ec42ee65d..3d7e1bfd84 100755 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -3,7 +3,7 @@ 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 +words cocoa.runtime io macros memoize debugger fry io.encodings.ascii effects compiler.generator libc libc.private ; IN: cocoa.messages @@ -201,12 +201,23 @@ 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 [ class_copyMethodList ] keep *uint over ] dip + '[ _ void*-nth @ ] each (free) ; inline : register-objc-methods ( class -- ) - 0 [ 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 ; diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 3451ce5e6e..1a741b789f 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/basis/cocoa/runtime/runtime.factor @@ -9,7 +9,7 @@ TYPEDEF: void* id FUNCTION: char* sel_getName ( SEL aSelector ) ; -FUNCTION: bool sel_isMapped ( SEL aSelector ) ; +FUNCTION: char sel_isMapped ( SEL aSelector ) ; FUNCTION: SEL sel_registerName ( char* str ) ; @@ -54,6 +54,8 @@ FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ; 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 ) ; @@ -73,5 +75,6 @@ FUNCTION: void* method_getTypeEncoding ( Method method ) ; 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 ) ; From 46c3f0def1ca86400df0ce7c82f2ed6ee8ef1a49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 20:31:48 -0500 Subject: [PATCH 008/224] Remove unused error class --- basis/random/random.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/random/random.factor b/basis/random/random.factor index 8a69b28171..b5f8ac48b8 100644 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -51,13 +51,12 @@ M: sequence random ( seq -- elt ) [ 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 ; + dup sgn { + { 0 [ ] } + { -1 [ neg random-integer neg ] } + { 1 [ random-integer ] } + } case ; : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; From d5112a0ced6aebdde1cd76e388a1632cb352f1de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 21:30:29 -0500 Subject: [PATCH 009/224] Working on stack frame cleanup --- basis/compiler/generator/generator.factor | 7 +- .../cpu/ppc/architecture/architecture.factor | 27 ++--- basis/cpu/x86/32/32.factor | 106 ++++++++---------- basis/cpu/x86/64/64.factor | 32 +++--- .../cpu/x86/architecture/architecture.factor | 14 ++- 5 files changed, 88 insertions(+), 98 deletions(-) diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 0a9885357e..2b398eaeea 100644 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -296,16 +296,13 @@ M: #return-recursive generate-node : 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 + ; + [ return>> return-size ] [ alien-stack-frame ] bi + ; : set-stack-frame ( n -- ) dup [ frame-required ] when* \ stack-frame set ; diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 80ee1802e1..aab104fa6e 100644 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -44,7 +44,7 @@ IN: cpu.ppc.architecture : xt-save ( n -- i ) 2 cells - ; M: ppc stack-frame ( n -- i ) - local@ factor-area-size + 4 cells align ; + local@ factor-area-size + cell + 4 cells align ; M: temp-reg v>operand drop 11 ; @@ -166,11 +166,13 @@ M: float-regs %load-param-reg >r 1 rot local@ r> LF ; 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* + ; + 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 ( -- ) @@ -197,10 +199,8 @@ M: ppc %unbox-long-long ( n func -- ) 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 ; @@ -218,9 +218,8 @@ M: ppc %box-long-long ( n func -- ) 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@ ( size n -- n ) + [ local@ ] [ stack-frame* factor-area-size - swap - ] ?if ; M: ppc %prepare-box-struct ( size -- ) #! Compute target address for value struct return @@ -231,10 +230,8 @@ 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 + ! Compute destination address and load struct size + [ 3 1 rot ADDI ] [ 4 LI ] bi* ! Call the function "box_value_struct" f %alien-invoke ; @@ -256,10 +253,10 @@ M: ppc %alien-callback ( quot -- ) M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - 3 1 cell temp@ STW ; + 3 11 MR ; M: ppc %alien-indirect ( -- ) - 11 1 cell temp@ LWZ (%call) ; + (%call) ; M: ppc %callback-value ( ctype -- ) ! Save top of data stack diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 50d8025b38..1173b9e68e 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -1,13 +1,12 @@ ! 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. @@ -18,7 +17,6 @@ IN: cpu.x86.32 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 ; @@ -32,15 +30,20 @@ M: x86.32 struct-small-enough? ( size -- ? ) heap-size { 1 2 4 8 } member? os { linux netbsd solaris } member? not and ; +: struct-return@ ( size n -- operand ) + [ next-stack@ ] [ \ stack-frame get swap - 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 } ; @@ -48,14 +51,16 @@ 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 ; @@ -64,7 +69,8 @@ M: float-regs store-return-reg load/store-float-return FSTP ; 16 align ESP swap ADD ; : 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 ; @@ -77,57 +83,40 @@ M: object %load-param-reg 3drop ; 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 c-type heap-size 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 @@ -136,9 +125,9 @@ M: x86.32 %box-large-struct ( n c-type -- ) M: x86.32 %prepare-box-struct ( size -- ) ! Compute target address for value struct return - EAX ESP rot f struct-return@ [+] LEA + EAX swap 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. @@ -207,13 +196,12 @@ M: x86 %unbox-small-struct ( size -- ) } 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 @@ -224,10 +212,10 @@ M: x86.32 %unbox-large-struct ( n c-type -- ) 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 [ @@ -239,7 +227,7 @@ M: x86.32 %alien-callback ( quot -- ) 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 diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 01b8935e39..8c9762630b 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -12,7 +12,6 @@ IN: cpu.x86.64 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 ; @@ -46,7 +45,9 @@ M: stack-params %load-param-reg 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 -- ) [ @@ -121,7 +122,7 @@ M: x86.64 %unbox-large-struct ( n c-type -- ) ! 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 @@ -145,7 +146,7 @@ M: x86.64 %box-long-long ( n func -- ) 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>> { @@ -164,21 +165,22 @@ M: x86.64 %box-small-struct ( c-type -- ) ] with-return-regs ; : struct-return@ ( size n -- n ) - [ ] [ \ stack-frame get swap - ] ?if ; + [ ] [ \ stack-frame get swap - ] ?if stack@ ; M: x86.64 %box-large-struct ( n c-type -- ) ! Struct size is parameter 2 heap-size RSI over MOV ! Compute destination address - swap struct-return@ RDI RSP rot [+] LEA + RDI spin struct-return@ LEA ! Copy the struct from the C stack "box_value_struct" f %alien-invoke ; M: x86.64 %prepare-box-struct ( size -- ) - ! Compute target address for value struct return - RAX RSP rot f struct-return@ [+] LEA - RSP 0 [+] RAX MOV ; + ! Compute target address for value struct return, store it + ! as the first parameter + RAX swap f struct-return@ LEA + 0 stack@ RAX MOV ; M: x86.64 %prepare-var-args RAX RAX XOR ; @@ -192,10 +194,10 @@ M: x86.64 %alien-invoke 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 ; @@ -203,12 +205,14 @@ M: x86.64 %alien-callback ( quot -- ) 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 ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index c97552a649..4770400434 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -10,10 +10,16 @@ IN: cpu.x86.architecture 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* + cell + stack@ ; + : reg-stack ( n reg -- op ) swap cells neg [+] ; M: ds-loc v>operand n>> ds-reg reg-stack ; @@ -32,8 +38,8 @@ M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ; 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 ) @@ -137,8 +143,6 @@ M: x86 small-enough? ( n -- ? ) : %tag-fixnum ( reg -- ) tag-bits get SHL ; -: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ; - M: x86 %return ( -- ) 0 %unwind ; ! Alien intrinsics From cf135e08b382e63c43f44905492ccc1598457556 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 5 Oct 2008 22:00:35 -0500 Subject: [PATCH 010/224] Tweak deploy descriptor to speed up tools.deploy test --- basis/tools/deploy/test/6/deploy.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor index 410bb770be..e7d3764d39 100644 --- a/basis/tools/deploy/test/6/deploy.factor +++ b/basis/tools/deploy/test/6/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-threads? f } - { deploy-ui? f } - { deploy-io 1 } - { deploy-c-types? f } - { deploy-name "tools.deploy.test.6" } - { deploy-compiler? t } { deploy-reflection 1 } { deploy-word-props? f } + { deploy-io 1 } + { deploy-name "tools.deploy.test.6" } + { deploy-math? t } + { deploy-random? f } + { deploy-compiler? t } + { 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 } } From 66ae62638d74f983d923ba08daef139b64be838c Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 5 Oct 2008 22:00:52 -0500 Subject: [PATCH 011/224] Fix Windows deployment --- basis/tools/deploy/shaker/shaker.factor | 2 +- basis/tools/deploy/windows/windows.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 basis/tools/deploy/shaker/shaker.factor mode change 100644 => 100755 basis/tools/deploy/windows/windows.factor diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor old mode 100644 new mode 100755 index 7c02e87209..d9348bedd5 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -321,7 +321,7 @@ IN: tools.deploy.shaker ] [ 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 diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor old mode 100644 new mode 100755 index ce4fee19d7..ad1b3cbd84 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -14,7 +14,7 @@ IN: tools.deploy.windows "resource:freetype6.dll" "resource:zlib1.dll" } swap copy-files-into - ] when ; + ] [ drop ] if ; : create-exe-dir ( vocab bundle-name -- vm ) deploy-ui? get [ From 0cfedcdc8d788064abc544eeea946b41cc8b4fde Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sun, 5 Oct 2008 22:08:13 -0500 Subject: [PATCH 012/224] Fix deploy size regresson --- basis/random/random-docs.factor | 22 +++++++++++----------- basis/random/random.factor | 15 +++------------ 2 files changed, 14 insertions(+), 23 deletions(-) mode change 100644 => 100755 basis/random/random-docs.factor mode change 100644 => 100755 basis/random/random.factor diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor old mode 100644 new mode 100755 index 51656a77dd..18c9ca781c --- a/basis/random/random-docs.factor +++ b/basis/random/random-docs.factor @@ -15,21 +15,18 @@ HELP: random-bytes* { $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 @@ -74,7 +71,10 @@ ARTICLE: "random-protocol" "Random protocol" { $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:" diff --git a/basis/random/random.factor b/basis/random/random.factor old mode 100644 new mode 100755 index b5f8ac48b8..845f8e004f --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -33,10 +33,6 @@ M: f random-32* ( obj -- * ) no-random-number-generator ; random-generator get random-bytes* ] keep head ; -GENERIC: random ( obj -- elt ) - -: random-bits ( n -- r ) 2^ random ; - -M: sequence random ( seq -- elt ) +: random-bits ( n -- r ) 2^ random-integer ; + +: random ( seq -- elt ) [ f ] [ [ length random-integer ] keep nth ] if-empty ; -M: integer random ( integer -- integer' ) - dup sgn { - { 0 [ ] } - { -1 [ neg random-integer neg ] } - { 1 [ random-integer ] } - } case ; - : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; From a5fcb006fbd58d8d0dba442a70495cc33efcc1b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 22:17:56 -0500 Subject: [PATCH 013/224] Clean up x86 stack frame code a bit more --- basis/cpu/x86/architecture/architecture.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 4770400434..ea54ef85af 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -18,7 +18,7 @@ HOOK: stack-reg cpu ( -- reg ) #! 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* + cell + stack@ ; + stack-frame* + stack@ ; : reg-stack ( n reg -- op ) swap cells neg [+] ; @@ -52,20 +52,18 @@ HOOK: prepare-division cpu ( -- ) M: immediate load-literal v>operand swap v>operand MOV ; M: x86 stack-frame ( n -- i ) - 3 cells + 16 align cell - ; + 3 cells + 16 align ; M: x86 %save-word-xt ( -- ) temp-reg v>operand 0 MOV rc-absolute-cell rel-this ; -: factor-area-size ( -- n ) 4 cells ; - M: x86 %prologue ( n -- ) - dup cell + PUSH + dup PUSH temp-reg v>operand PUSH - stack-reg swap 2 cells - SUB ; + stack-reg swap 3 cells - SUB ; M: x86 %epilogue ( n -- ) - stack-reg swap ADD ; + stack-reg swap cell - ADD ; HOOK: %alien-global cpu ( symbol dll register -- ) From b0d57ead863995421f0a259294e3c53e5deed5ad Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Oct 2008 23:09:10 -0500 Subject: [PATCH 014/224] Fix unit test --- basis/random/random-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index c6d88c5525..e686dd7301 100644 --- a/basis/random/random-tests.factor +++ b/basis/random/random-tests.factor @@ -16,4 +16,4 @@ IN: random.tests [ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test -[ 0 ] [ 0 random ] unit-test +[ f ] [ 0 random ] unit-test From 33d775890cfe24d95fc295cfe6da4399b36c25fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Oct 2008 00:20:00 -0500 Subject: [PATCH 015/224] More stack frame refactoring --- basis/compiler/generator/fixup/fixup.factor | 6 ++-- basis/compiler/generator/generator.factor | 31 +++++++++---------- basis/cpu/architecture/architecture.factor | 13 ++++---- .../cpu/ppc/architecture/architecture.factor | 20 ++++++------ basis/cpu/x86/32/32.factor | 16 +++++----- basis/cpu/x86/64/64.factor | 17 +++++----- .../cpu/x86/architecture/architecture.factor | 20 ++++++++---- 7 files changed, 63 insertions(+), 60 deletions(-) diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor index ecc88a7a5e..e8bdc561b7 100644 --- a/basis/compiler/generator/fixup/fixup.factor +++ b/basis/compiler/generator/fixup/fixup.factor @@ -13,7 +13,7 @@ TUPLE: frame-required n ; : 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 ; @@ -37,7 +37,7 @@ M: label fixup* : 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* { @@ -146,7 +146,7 @@ SYMBOL: literal-table : 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 diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 2b398eaeea..22de9d3587 100644 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -299,18 +299,17 @@ M: #return-recursive generate-node dup large-struct? [ heap-size ] [ drop 2 cells ] if ; : alien-stack-frame ( params -- n ) - alien-parameters parameter-sizes drop ; + 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 ; -: alien-invoke-frame ( params -- n ) - [ return>> return-size ] [ alien-stack-frame ] bi + ; - -: set-stack-frame ( n -- ) - dup [ frame-required ] when* \ stack-frame set ; - -: with-stack-frame ( n quot -- ) - swap set-stack-frame +: 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 ) @@ -413,8 +412,8 @@ M: long-long-type flatten-value-type ( type -- types ) #! 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 @@ -473,7 +472,7 @@ M: no-such-symbol compiler-error-type M: #alien-invoke generate-node params>> - dup alien-invoke-frame [ + dup [ end-basic-block %prepare-alien-invoke dup objects>registers @@ -487,7 +486,7 @@ M: #alien-invoke generate-node ! #alien-indirect M: #alien-indirect generate-node params>> - dup alien-invoke-frame [ + dup [ ! Flush registers end-basic-block ! Save registers for GC @@ -553,7 +552,7 @@ TUPLE: callback-context ; : 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 ; @@ -569,7 +568,7 @@ TUPLE: callback-context ; dup xt>> dup [ init-templates %prologue-later - dup alien-stack-frame [ + dup [ [ registers>objects ] [ wrap-callback-quot %alien-callback ] [ %callback-return ] diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 63c52d1025..f22d4a2a90 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -1,8 +1,8 @@ ! 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 @@ -33,10 +33,9 @@ GENERIC# load-literal 1 ( obj vreg -- ) 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 -- ) @@ -117,7 +116,7 @@ HOOK: %box cpu ( n reg-class func -- ) 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 -- ) diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index aab104fa6e..357349193e 100644 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -43,8 +43,8 @@ IN: cpu.ppc.architecture : xt-save ( n -- i ) 2 cells - ; -M: ppc stack-frame ( n -- i ) - local@ factor-area-size + cell + 4 cells align ; +M: ppc stack-frame-size ( n -- i ) + local@ factor-area-size + 4 cells align ; M: temp-reg v>operand drop 11 ; @@ -166,7 +166,7 @@ M: float-regs %load-param-reg >r 1 rot local@ r> LF ; 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* + ; +: 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. @@ -218,20 +218,18 @@ M: ppc %box-long-long ( n func -- ) 4 1 rot cell + local@ LWZ ] when* r> f %alien-invoke ; -: struct-return@ ( size n -- n ) - [ local@ ] [ stack-frame* factor-area-size - swap - ] ?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 + ! If n = f, then we're boxing a returned struct ! Compute destination address and load struct size - [ 3 1 rot ADDI ] [ 4 LI ] bi* + [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi* ! Call the function "box_value_struct" f %alien-invoke ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 1173b9e68e..dc891a8178 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -30,8 +30,8 @@ M: x86.32 struct-small-enough? ( size -- ? ) heap-size { 1 2 4 8 } member? os { linux netbsd solaris } member? not and ; -: struct-return@ ( size n -- operand ) - [ next-stack@ ] [ \ stack-frame get swap - stack@ ] ?if ; +: 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 ; @@ -63,10 +63,10 @@ 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 -- ) [ [ align-sub ] [ call ] bi* ] @@ -113,7 +113,7 @@ M: x86.32 %box-long-long ( n func -- ) M:: x86.32 %box-large-struct ( n c-type -- ) ! Compute destination address - ECX c-type heap-size n struct-return@ LEA + ECX n struct-return@ LEA 8 [ ! Push struct size c-type heap-size PUSH @@ -123,9 +123,9 @@ M:: x86.32 %box-large-struct ( n c-type -- ) "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 swap f struct-return@ LEA + EAX f struct-return@ LEA ! Store it as the first parameter 0 stack@ EAX MOV ; @@ -248,7 +248,7 @@ M: x86.32 %cleanup ( alien-node -- ) { { [ dup abi>> "stdcall" = ] - [ alien-stack-frame ESP swap SUB ] + [ drop ESP stack-frame get params>> SUB ] } { [ dup return>> large-struct? ] [ drop EAX PUSH ] diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8c9762630b..5bcd733eaa 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -164,22 +164,21 @@ M: x86.64 %box-small-struct ( c-type -- ) "box_small_struct" f %alien-invoke ] with-return-regs ; -: struct-return@ ( size n -- n ) - [ ] [ \ stack-frame get swap - ] ?if stack@ ; +: 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 - RDI spin struct-return@ 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 -- ) - ! Compute target address for value struct return, store it - ! as the first parameter - RAX swap f struct-return@ LEA +M: x86.64 %prepare-box-struct ( -- ) + ! Compute target address for value struct return + RAX f struct-return@ LEA + ! Store it as the first parameter 0 stack@ RAX MOV ; M: x86.64 %prepare-var-args RAX RAX XOR ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index ea54ef85af..d10397de3b 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -18,7 +18,7 @@ HOOK: stack-reg cpu ( -- reg ) #! 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* + stack@ ; + stack-frame get total-size>> + stack@ ; : reg-stack ( n reg -- op ) swap cells neg [+] ; @@ -51,19 +51,27 @@ HOOK: prepare-division cpu ( -- ) M: immediate load-literal v>operand swap v>operand MOV ; -M: x86 stack-frame ( n -- i ) - 3 cells + 16 align ; +: align-stack ( n -- n' ) + os macosx? [ 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 ; +: decr-stack-reg ( n -- ) + dup 0 = [ drop ] [ stack-reg swap SUB ] if ; + M: x86 %prologue ( n -- ) dup PUSH temp-reg v>operand PUSH - stack-reg swap 3 cells - SUB ; + 3 cells - decr-stack-reg ; -M: x86 %epilogue ( n -- ) - stack-reg swap cell - ADD ; +: incr-stack-reg ( n -- ) + dup 0 = [ ] [ stack-reg swap ADD ] if ; + +M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; HOOK: %alien-global cpu ( symbol dll register -- ) From 4ca06ae50ff25eb93a5214914645eb1381393969 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Oct 2008 00:20:24 -0500 Subject: [PATCH 016/224] Typo --- basis/cpu/x86/architecture/architecture.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index d10397de3b..417f90c9f9 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -69,7 +69,7 @@ M: x86 %prologue ( n -- ) 3 cells - decr-stack-reg ; : incr-stack-reg ( n -- ) - dup 0 = [ ] [ stack-reg swap ADD ] if ; + dup 0 = [ drop ] [ stack-reg swap ADD ] if ; M: x86 %epilogue ( n -- ) cell - incr-stack-reg ; From 3c2caf948ae4c58a56d211597c7ab4fa9d284bd2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 6 Oct 2008 00:33:47 -0500 Subject: [PATCH 017/224] 16-align stack on x86-64 --- basis/cpu/x86/architecture/architecture.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index 417f90c9f9..01256fb4c5 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -52,7 +52,7 @@ HOOK: prepare-division cpu ( -- ) M: immediate load-literal v>operand swap v>operand MOV ; : align-stack ( n -- n' ) - os macosx? [ 16 align ] when ; + os macosx? cpu x86.64? or [ 16 align ] when ; M: x86 stack-frame-size ( n -- i ) 3 cells + align-stack ; From d142b3283772fa54998f4f4c6c709a51d45f6503 Mon Sep 17 00:00:00 2001 From: erg Date: Mon, 6 Oct 2008 14:54:27 -0500 Subject: [PATCH 018/224] cleaner irc.messages --- extra/irc/messages/messages.factor | 168 +++++++++++++++++------------ 1 file changed, 98 insertions(+), 70 deletions(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 882cec5c8d..14c8633f6f 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -4,7 +4,6 @@ USING: kernel fry splitting ascii calendar accessors combinators qualified 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 ; @@ -17,75 +16,99 @@ TUPLE: nick < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; -TUPLE: nick-in-use < irc-message name ; +TUPLE: nick-in-use < irc-message asterisk name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name mode parameter ; TUPLE: names-reply < irc-message who channel ; TUPLE: unhandled < irc-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 ; > ( 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 ; +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) ( params irc-message -- ) +GENERIC# >>command-parameters 1 ( irc-message 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 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" ; server-line drop "not implemented yet" ; : 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 ; From e42a2d8825a7a280a11610ca9910de643576654d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 15:01:01 -0500 Subject: [PATCH 019/224] clean up constructor --- extra/irc/client/client.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index d40c7d400d..463e35f415 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -19,9 +19,16 @@ C: irc-profile TUPLE: irc-client profile stream in-messages out-messages chats is-running nick connect reconnect-time is-ready ; + : ( profile -- irc-client ) - [ f H{ } clone f ] keep nickname>> - [ latin1 ] 15 seconds f irc-client boa ; + irc-client new + swap >>profile + >>in-messages + >>out-messages + H{ } clone >>chats + dup profile>> nickname>> >>nick + [ latin1 ] >>connect + 15 seconds >>reconnect-time ; TUPLE: irc-chat in-messages client ; TUPLE: irc-server-chat < irc-chat ; From 03043a7cfdba7ee943c5adadd210e3cbb83ca1e7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 15:25:17 -0500 Subject: [PATCH 020/224] remove slot --- extra/irc/messages/messages.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 14c8633f6f..32533c102a 100755 --- a/extra/irc/messages/messages.factor +++ b/extra/irc/messages/messages.factor @@ -16,7 +16,7 @@ TUPLE: nick < irc-message ; TUPLE: privmsg < irc-message name ; TUPLE: kick < irc-message channel who ; TUPLE: roomlist < irc-message channel names ; -TUPLE: nick-in-use < irc-message asterisk name ; +TUPLE: nick-in-use < irc-message name ; TUPLE: notice < irc-message type ; TUPLE: mode < irc-message name mode parameter ; TUPLE: names-reply < irc-message who channel ; From a0a17646c5e4f4b16be73556570336d6dfc346fd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 15:56:54 -0500 Subject: [PATCH 021/224] dettach -> detach (spelling), fix docs --- extra/irc/client/client-docs.factor | 10 +++++----- extra/irc/client/client.factor | 2 +- extra/irc/ui/ui.factor | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor index 1b9204c4f1..6d4fae9b83 100644 --- a/extra/irc/client/client-docs.factor +++ b/extra/irc/client/client-docs.factor @@ -19,8 +19,8 @@ HELP: attach-chat "Chatting with irc channels/users/etc" { $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" @@ -49,7 +49,7 @@ ARTICLE: "irc.client" "IRC Client" { $subsection connect-irc } { $subsection terminate-irc } { $subsection attach-chat } -{ $subsection dettach-chat } +{ $subsection detach-chat } { $subsection hear } { $subsection speak } { $heading "IRC messages" } @@ -72,7 +72,7 @@ ARTICLE: "irc.client" "IRC Client" { $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." } } @@ -97,4 +97,4 @@ ARTICLE: "irc.client" "IRC Client" } ; -ABOUT: "irc.client" \ No newline at end of file +ABOUT: "irc.client" diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor index 463e35f415..ce7a6e5373 100755 --- a/extra/irc/client/client.factor +++ b/extra/irc/client/client.factor @@ -362,7 +362,7 @@ PRIVATE> : 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 -- ) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 50dc9378a2..e854d285b7 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -186,7 +186,7 @@ M: irc-tab graft* [ chat>> ] [ window>> client>> ] bi attach-chat ; M: irc-tab ungraft* - chat>> dettach-chat ; + chat>> detach-chat ; TUPLE: irc-channel-tab < irc-tab userlist ; From e0d6aadc8e7c8af2819907f4156f9dd7db7528fc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:17:14 -0500 Subject: [PATCH 022/224] complete file-info across *bsd, linux --- basis/io/unix/files/files.factor | 71 +++++++++++++++------- basis/io/unix/files/freebsd/freebsd.factor | 17 ++++++ basis/io/unix/files/freebsd/tags.txt | 1 + basis/io/unix/files/macosx/macosx.factor | 16 +++++ basis/io/unix/files/macosx/tags.txt | 1 + basis/io/unix/files/netbsd/netbsd.factor | 17 ++++++ basis/io/unix/files/netbsd/tags.txt | 1 + basis/io/unix/files/openbsd/openbsd.factor | 17 ++++++ basis/io/unix/files/openbsd/tags.txt | 1 + basis/io/unix/files/unique/unique.factor | 2 + 10 files changed, 123 insertions(+), 21 deletions(-) create mode 100644 basis/io/unix/files/freebsd/freebsd.factor create mode 100644 basis/io/unix/files/freebsd/tags.txt create mode 100644 basis/io/unix/files/macosx/macosx.factor create mode 100644 basis/io/unix/files/macosx/tags.txt create mode 100644 basis/io/unix/files/netbsd/netbsd.factor create mode 100644 basis/io/unix/files/netbsd/tags.txt create mode 100644 basis/io/unix/files/openbsd/openbsd.factor create mode 100644 basis/io/unix/files/openbsd/tags.txt diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index c6eda50855..4319b6c8de 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -4,7 +4,7 @@ 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 ; IN: io.unix.files @@ -74,26 +74,14 @@ M: unix copy-file ( from to -- ) [ swap file-info permissions>> chmod io-error ] 2bi ; -: stat>type ( stat -- type ) - stat-st_mode S_IFMT bitand { - { S_IFREG [ +regular-file+ ] } - { S_IFDIR [ +directory+ ] } - { S_IFCHR [ +character-device+ ] } - { S_IFBLK [ +block-device+ ] } - { S_IFIFO [ +fifo+ ] } - { S_IFLNK [ +symbolic-link+ ] } - { S_IFSOCK [ +socket+ ] } - [ drop +unknown+ ] - } case ; +HOOK: stat>file-info os ( stat -- file-info ) -: 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 ; +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 ; @@ -105,4 +93,45 @@ M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; M: unix read-link ( path -- path' ) - normalize-path read-symbolic-link ; \ No newline at end of file + 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_ctim timespec>unix-time >>created ] + [ stat-st_mtim timespec>unix-time >>modified ] + [ stat-st_atim 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+ ] } + { S_IFCHR [ +character-device+ ] } + { S_IFBLK [ +block-device+ ] } + { S_IFIFO [ +fifo+ ] } + { S_IFLNK [ +symbolic-link+ ] } + { S_IFSOCK [ +socket+ ] } + [ drop +unknown+ ] + } case ; + +! Linux has no extra fields in its stat struct +os { + { macosx [ "io.unix.files.macosx" require ] } + { freebsd [ "io.unix.files.freebsd" require ] } + { netbsd [ "io.unix.files.netbsd" require ] } + { openbsd [ "io.unix.files.openbsd" require ] } +} case diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor new file mode 100644 index 0000000000..14d15bc93d --- /dev/null +++ b/basis/io/unix/files/freebsd/freebsd.factor @@ -0,0 +1,17 @@ +! 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 ; +IN: io.unix.files.freebsd + +TUPLE: freebsd-file-info < unix-file-info birth-time flags gen ; + +M: freebsd new-file-info ( -- class ) freebsd-file-info new ; + +M: freebsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ stat-st_birthtimepsec timespec>timestamp >>birth-time ] + } cleave ; diff --git a/basis/io/unix/files/freebsd/tags.txt b/basis/io/unix/files/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/macosx/macosx.factor b/basis/io/unix/files/macosx/macosx.factor new file mode 100644 index 0000000000..4173123e45 --- /dev/null +++ b/basis/io/unix/files/macosx/macosx.factor @@ -0,0 +1,16 @@ +! 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 ; +IN: io.unix.files.macosx + +TUPLE: macosx-file-info < unix-file-info flags gen ; + +M: macosx new-file-info ( -- class ) macosx-file-info new ; + +M: macosx stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + } cleave ; diff --git a/basis/io/unix/files/macosx/tags.txt b/basis/io/unix/files/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor new file mode 100644 index 0000000000..c61304c128 --- /dev/null +++ b/basis/io/unix/files/netbsd/netbsd.factor @@ -0,0 +1,17 @@ +! 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 ; +IN: io.unix.files.netbsd + +TUPLE: netbsd-file-info < unix-file-info birth-time flags gen ; + +M: netbsd new-file-info ( -- class ) netbsd-file-info new ; + +M: netbsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ stat-st_birthtim timespec>timestamp >>birth-time ] + } cleave ; diff --git a/basis/io/unix/files/netbsd/tags.txt b/basis/io/unix/files/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor new file mode 100644 index 0000000000..e1473eed4d --- /dev/null +++ b/basis/io/unix/files/openbsd/openbsd.factor @@ -0,0 +1,17 @@ +! 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 ; +IN: io.unix.files.openbsd + +TUPLE: openbsd-file-info < unix-file-info birth-time flags gen ; + +M: openbsd new-file-info ( -- class ) openbsd-file-info new ; + +M: openbsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ stat-st_birthtim timespec>timestamp >>birth-time ] + } cleave ; diff --git a/basis/io/unix/files/openbsd/tags.txt b/basis/io/unix/files/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/unix/files/unique/unique.factor b/basis/io/unix/files/unique/unique.factor index 95e321fd93..e47ac6a2e3 100644 --- a/basis/io/unix/files/unique/unique.factor +++ b/basis/io/unix/files/unique/unique.factor @@ -1,3 +1,5 @@ +! 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 From b168d75a46747ccc64f45dc18ee02b0f6d6c1825 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:17:49 -0500 Subject: [PATCH 023/224] add timespec>timestamp word --- basis/calendar/calendar.factor | 9 ++++++++- basis/structs/structs.factor | 10 ++++++++++ basis/unix/time/time.factor | 12 ------------ 3 files changed, 18 insertions(+), 13 deletions(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 31c835aada..8a27a46aa2 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -402,9 +402,16 @@ PRIVATE> : time-since-midnight ( timestamp -- duration ) dup midnight time- ; +: since-1970 ( time -- timestamp ) + unix-1970 time+ >local-time ; + : timeval>unix-time ( timeval -- timestamp ) [ timeval-sec seconds ] [ timeval-usec microseconds ] bi - time+ unix-1970 time+ >local-time ; + time+ since-1970 ; + +: timespec>unix-time ( timeval -- timestamp ) + [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi + time+ since-1970 ; M: timestamp sleep-until timestamp>millis sleep-until ; diff --git a/basis/structs/structs.factor b/basis/structs/structs.factor index f54917dc47..51ac517af3 100644 --- a/basis/structs/structs.factor +++ b/basis/structs/structs.factor @@ -10,3 +10,13 @@ C-STRUCT: timeval "timeval" [ set-timeval-usec ] keep [ set-timeval-sec ] keep ; + +C-STRUCT: timespec + { "time_t" "sec" } + { "long" "nsec" } ; + +: make-timespec ( ms -- timespec ) + 1000 /mod 1000000 * + "timespec" + [ set-timespec-nsec ] keep + [ set-timespec-sec ] keep ; diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index 4fbb20dca0..26b42ddfe7 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -1,6 +1,4 @@ - USING: kernel alien.syntax alien.c-types math ; - IN: unix.time TYPEDEF: uint time_t @@ -18,16 +16,6 @@ C-STRUCT: tm { "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" - [ 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 ) ; From 9459eaab4b81c1a9f060393c2cef594b72873523 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:28:11 -0500 Subject: [PATCH 024/224] all platforms support the file-info structure --- core/io/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1634b7a3f1..bc84aa5d21 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -153,7 +153,7 @@ PRIVATE> "." 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 ) From 0294308c4c40e3ed49f446b1e45e5e1370bd008e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:28:42 -0500 Subject: [PATCH 025/224] work on windows file-info --- basis/io/windows/files/files.factor | 41 ++++++++++++++++++----------- 1 file changed, 25 insertions(+), 16 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 40e7e17402..f4bb3c71dc 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -147,18 +147,18 @@ SYMBOLS: +read-only+ +hidden+ +system+ 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 >>mode ] + [ 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" [ @@ -168,23 +168,32 @@ SYMBOLS: +read-only+ +hidden+ +system+ ] 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 >>mode ] + [ + 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 ) [ From 847205432fe1d234f028aa6f2527d8713f17c4de Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:34:58 -0500 Subject: [PATCH 026/224] fix load error --- basis/structs/structs.factor | 2 +- basis/unix/time/time.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/structs/structs.factor b/basis/structs/structs.factor index 51ac517af3..6aef757eb4 100644 --- a/basis/structs/structs.factor +++ b/basis/structs/structs.factor @@ -1,4 +1,4 @@ -USING: alien.c-types alien.syntax kernel math ; +USING: alien.c-types alien.syntax kernel math unix.types ; IN: structs C-STRUCT: timeval diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index 26b42ddfe7..67611ae193 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -1,8 +1,8 @@ -USING: kernel alien.syntax alien.c-types math ; +! 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 -TYPEDEF: uint time_t - C-STRUCT: tm { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) { "int" "min" } ! Minutes: 0-59 From 1d25db2a6e6c7ad968cafb1228b7486ec20c2ec0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:54:50 -0500 Subject: [PATCH 027/224] empty case for linux --- basis/io/unix/files/files.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 4319b6c8de..fafc56154b 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -134,4 +134,5 @@ os { { freebsd [ "io.unix.files.freebsd" require ] } { netbsd [ "io.unix.files.netbsd" require ] } { openbsd [ "io.unix.files.openbsd" require ] } + { linux [ ] } } case From 9f6a7bfd87723f7a294687b0c1917c84f57a302a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:56:12 -0500 Subject: [PATCH 028/224] typo --- basis/io/unix/files/freebsd/freebsd.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor index 14d15bc93d..42857d1132 100644 --- a/basis/io/unix/files/freebsd/freebsd.factor +++ b/basis/io/unix/files/freebsd/freebsd.factor @@ -13,5 +13,5 @@ M: freebsd stat>file-info ( stat -- file-info ) { [ stat-st_flags >>flags ] [ stat-st_gen >>gen ] - [ stat-st_birthtimepsec timespec>timestamp >>birth-time ] + [ stat-st_birthtimespec timespec>timestamp >>birth-time ] } cleave ; From f949f6ee1a678f81e8354ddbe3530ba9dc770618 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 17:59:20 -0500 Subject: [PATCH 029/224] move basis/structs to calendar.unix --- basis/calendar/unix/unix.factor | 24 ++++++++++++++++++++++-- basis/structs/authors.txt | 1 - basis/structs/structs.factor | 22 ---------------------- basis/structs/summary.txt | 1 - 4 files changed, 22 insertions(+), 26 deletions(-) delete mode 100755 basis/structs/authors.txt delete mode 100644 basis/structs/structs.factor delete mode 100644 basis/structs/summary.txt diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 1da554e0f1..e811abcab8 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,7 +1,27 @@ -USING: alien alien.c-types arrays calendar kernel structs -math unix.time namespaces system ; +USING: alien alien.c-types alien.syntax arrays calendar +kernel structs math unix.time namespaces system ; IN: calendar.unix +C-STRUCT: timeval + { "long" "sec" } + { "long" "usec" } ; + +: make-timeval ( ms -- timeval ) + 1000 /mod 1000 * + "timeval" + [ set-timeval-usec ] keep + [ set-timeval-sec ] keep ; + +C-STRUCT: timespec + { "time_t" "sec" } + { "long" "nsec" } ; + +: make-timespec ( ms -- timespec ) + 1000 /mod 1000000 * + "timespec" + [ set-timespec-nsec ] keep + [ set-timespec-sec ] keep ; + : get-time ( -- alien ) f time localtime ; diff --git a/basis/structs/authors.txt b/basis/structs/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/structs/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/structs/structs.factor b/basis/structs/structs.factor deleted file mode 100644 index 6aef757eb4..0000000000 --- a/basis/structs/structs.factor +++ /dev/null @@ -1,22 +0,0 @@ -USING: alien.c-types alien.syntax kernel math unix.types ; -IN: structs - -C-STRUCT: timeval - { "long" "sec" } - { "long" "usec" } ; - -: make-timeval ( ms -- timeval ) - 1000 /mod 1000 * - "timeval" - [ set-timeval-usec ] keep - [ set-timeval-sec ] keep ; - -C-STRUCT: timespec - { "time_t" "sec" } - { "long" "nsec" } ; - -: make-timespec ( ms -- timespec ) - 1000 /mod 1000000 * - "timespec" - [ set-timespec-nsec ] keep - [ set-timespec-sec ] keep ; diff --git a/basis/structs/summary.txt b/basis/structs/summary.txt deleted file mode 100644 index 86d6ad349e..0000000000 --- a/basis/structs/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Cross-platform C structs From 5e57f68814b87acf25e2ccc89477b3eacd46b213 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 18:01:53 -0500 Subject: [PATCH 030/224] use calendar.unix --- basis/io/unix/files/freebsd/freebsd.factor | 2 +- basis/io/unix/files/netbsd/netbsd.factor | 2 +- basis/io/unix/files/openbsd/openbsd.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor index 42857d1132..e6fff4dfe0 100644 --- a/basis/io/unix/files/freebsd/freebsd.factor +++ b/basis/io/unix/files/freebsd/freebsd.factor @@ -1,7 +1,7 @@ ! 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.stat accessors combinators calendar.unix ; IN: io.unix.files.freebsd TUPLE: freebsd-file-info < unix-file-info birth-time flags gen ; diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor index c61304c128..6a41e6e18a 100644 --- a/basis/io/unix/files/netbsd/netbsd.factor +++ b/basis/io/unix/files/netbsd/netbsd.factor @@ -1,7 +1,7 @@ ! 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.stat accessors combinators calendar.unix ; IN: io.unix.files.netbsd TUPLE: netbsd-file-info < unix-file-info birth-time flags gen ; diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor index e1473eed4d..5723827481 100644 --- a/basis/io/unix/files/openbsd/openbsd.factor +++ b/basis/io/unix/files/openbsd/openbsd.factor @@ -1,7 +1,7 @@ ! 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.stat accessors combinators calendar.unix ; IN: io.unix.files.openbsd TUPLE: openbsd-file-info < unix-file-info birth-time flags gen ; From c4fdad4df6e30fe5a88e1d36245795dc4401d50e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 18:02:07 -0500 Subject: [PATCH 031/224] move structs around AGAIN --- basis/calendar/unix/unix.factor | 10 +--------- basis/unix/unix.factor | 11 ++++++++++- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index e811abcab8..4a1b7d49ef 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,21 +1,13 @@ USING: alien alien.c-types alien.syntax arrays calendar -kernel structs math unix.time namespaces system ; +kernel structs math unix unix.time namespaces system ; IN: calendar.unix -C-STRUCT: timeval - { "long" "sec" } - { "long" "usec" } ; - : make-timeval ( ms -- timeval ) 1000 /mod 1000 * "timeval" [ set-timeval-usec ] keep [ set-timeval-sec ] keep ; -C-STRUCT: timespec - { "time_t" "sec" } - { "long" "nsec" } ; - : make-timespec ( ms -- timespec ) 1000 /mod 1000000 * "timespec" diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 4c572a6be0..8ccc14f44d 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -1,6 +1,6 @@ ! 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 @@ -29,6 +29,15 @@ C-STRUCT: group { "int" "gr_gid" } { "char**" "gr_mem" } ; +C-STRUCT: timeval + { "long" "sec" } + { "long" "usec" } ; + +C-STRUCT: timespec + { "time_t" "sec" } + { "long" "nsec" } ; + + LIBRARY: factor FUNCTION: void clear_err_no ( ) ; From 0ba6d93626a1283b7d63b6981830b726af15f6cd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 18:02:52 -0500 Subject: [PATCH 032/224] remove using --- basis/calendar/calendar.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 8a27a46aa2..719f0f6e9f 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -2,8 +2,7 @@ ! 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 ) From 4734b62dd8d1086a89c5df09cab91b0fab6a6c10 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 18:03:56 -0500 Subject: [PATCH 033/224] things in the wrong place still, probably will have some using errors now.. --- basis/calendar/calendar.factor | 8 -------- basis/calendar/unix/unix.factor | 8 ++++++++ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 719f0f6e9f..d5824768f4 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -404,14 +404,6 @@ PRIVATE> : since-1970 ( time -- timestamp ) unix-1970 time+ >local-time ; -: timeval>unix-time ( timeval -- timestamp ) - [ timeval-sec seconds ] [ timeval-usec microseconds ] bi - time+ since-1970 ; - -: timespec>unix-time ( timeval -- timestamp ) - [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi - time+ since-1970 ; - M: timestamp sleep-until timestamp>millis sleep-until ; M: duration sleep hence sleep-until ; diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 4a1b7d49ef..679cc69fad 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -14,6 +14,14 @@ IN: calendar.unix [ set-timespec-nsec ] keep [ set-timespec-sec ] keep ; +: timeval>unix-time ( timeval -- timestamp ) + [ timeval-sec seconds ] [ timeval-usec microseconds ] bi + time+ since-1970 ; + +: timespec>unix-time ( timeval -- timestamp ) + [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi + time+ since-1970 ; + : get-time ( -- alien ) f time localtime ; From dd56cd4a4fc39ea9089fff5abd49552110c62dff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 18:07:40 -0500 Subject: [PATCH 034/224] fix typo --- basis/io/windows/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index f4bb3c71dc..fdb75c72f0 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -154,7 +154,7 @@ SYMBOLS: +read-only+ +hidden+ +system+ [ WIN32_FIND_DATA-nFileSizeLow ] [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size ] - [ WIN32_FIND_DATA-dwFileAttributes >>mode ] + [ 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 ] @@ -175,7 +175,7 @@ SYMBOLS: +read-only+ +hidden+ +system+ [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size ] - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>mode ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ] [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp >>created From 4eb3f734839ccb02ce5fb0004ec53d39dd0eeee5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 18:18:33 -0500 Subject: [PATCH 035/224] moving structs around --- basis/calendar/unix/unix.factor | 4 +++- basis/unix/time/time.factor | 8 ++++++++ basis/unix/unix.factor | 9 --------- 3 files changed, 11 insertions(+), 10 deletions(-) diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index 679cc69fad..fcdfcc8a67 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,5 +1,7 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax arrays calendar -kernel structs math unix unix.time namespaces system ; +kernel math unix unix.time namespaces system ; IN: calendar.unix : make-timeval ( ms -- timeval ) diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index 67611ae193..b6471e9892 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -3,6 +3,14 @@ USING: kernel alien.syntax alien.c-types math unix.types ; IN: unix.time +C-STRUCT: timeval + { "long" "sec" } + { "long" "usec" } ; + +C-STRUCT: timespec + { "time_t" "sec" } + { "long" "nsec" } ; + C-STRUCT: tm { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) { "int" "min" } ! Minutes: 0-59 diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 8ccc14f44d..a68274f09b 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -29,15 +29,6 @@ C-STRUCT: group { "int" "gr_gid" } { "char**" "gr_mem" } ; -C-STRUCT: timeval - { "long" "sec" } - { "long" "usec" } ; - -C-STRUCT: timespec - { "time_t" "sec" } - { "long" "nsec" } ; - - LIBRARY: factor FUNCTION: void clear_err_no ( ) ; From f1205587a1b52e92047d59f96cfaa014f337ea12 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 19 Sep 2008 18:33:28 -0500 Subject: [PATCH 036/224] fix error from having tuple and generic with same name. annoying... --- basis/io/windows/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index fdb75c72f0..dbe16f0a6e 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -147,7 +147,7 @@ SYMBOLS: +read-only+ +hidden+ +system+ FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) - [ file-info new ] dip + [ \ file-info new ] dip { [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ] [ @@ -168,7 +168,7 @@ SYMBOLS: +read-only+ +hidden+ +system+ ] keep ; : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info ) - [ file-info new ] dip + [ \ file-info new ] dip { [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ] [ From 2c1f6ee3dd37c8ef92b6df2ad34928d55b8984cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 19 Sep 2008 22:06:28 -0500 Subject: [PATCH 037/224] apply p1dzkl's patch to let the windows ui cascade new windows instead of putting them all on top of each other. thanks! --- basis/ui/windows/windows.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 345c73bcb9..3e600d2e3c 100644 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -420,15 +420,25 @@ M: windows-ui-backend do-events 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" 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 From 75780d183be071133c14d014ba8ce1cc24b0f4a9 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Wed, 1 Oct 2008 10:57:15 +1000 Subject: [PATCH 038/224] Using inheritance instead of delegation in digraphs --- {unmaintained => extra}/digraphs/authors.txt | 0 .../digraphs/digraphs-tests.factor | 6 ++++-- {unmaintained => extra}/digraphs/digraphs.factor | 11 ++++++----- {unmaintained => extra}/digraphs/summary.txt | 0 {unmaintained => extra}/digraphs/tags.txt | 0 5 files changed, 10 insertions(+), 7 deletions(-) rename {unmaintained => extra}/digraphs/authors.txt (100%) rename {unmaintained => extra}/digraphs/digraphs-tests.factor (72%) rename {unmaintained => extra}/digraphs/digraphs.factor (87%) rename {unmaintained => extra}/digraphs/summary.txt (100%) rename {unmaintained => extra}/digraphs/tags.txt (100%) diff --git a/unmaintained/digraphs/authors.txt b/extra/digraphs/authors.txt similarity index 100% rename from unmaintained/digraphs/authors.txt rename to extra/digraphs/authors.txt diff --git a/unmaintained/digraphs/digraphs-tests.factor b/extra/digraphs/digraphs-tests.factor similarity index 72% rename from unmaintained/digraphs/digraphs-tests.factor rename to extra/digraphs/digraphs-tests.factor index b113c18ca7..64589c1a99 100644 --- a/unmaintained/digraphs/digraphs-tests.factor +++ b/extra/digraphs/digraphs-tests.factor @@ -3,7 +3,9 @@ IN: digraphs.tests : test-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 ; + { { "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 diff --git a/unmaintained/digraphs/digraphs.factor b/extra/digraphs/digraphs.factor similarity index 87% rename from unmaintained/digraphs/digraphs.factor rename to extra/digraphs/digraphs.factor index 7d56c96034..5ccc0d5a60 100755 --- a/unmaintained/digraphs/digraphs.factor +++ b/extra/digraphs/digraphs.factor @@ -1,19 +1,20 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel sequences vectors ; +USING: accessors assocs hashtables hashtables.private kernel sequences vectors ; IN: digraphs -TUPLE: digraph ; -TUPLE: vertex value edges ; +TUPLE: digraph < hashtable ; : ( -- digraph ) - digraph new H{ } clone over set-delegate ; + 0 digraph new [ reset-hash ] keep ; + +TUPLE: vertex value edges ; : ( value -- vertex ) V{ } clone vertex boa ; : add-vertex ( key value digraph -- ) - >r swap r> set-at ; + [ swap ] dip set-at ; : children ( key digraph -- seq ) at edges>> ; diff --git a/unmaintained/digraphs/summary.txt b/extra/digraphs/summary.txt similarity index 100% rename from unmaintained/digraphs/summary.txt rename to extra/digraphs/summary.txt diff --git a/unmaintained/digraphs/tags.txt b/extra/digraphs/tags.txt similarity index 100% rename from unmaintained/digraphs/tags.txt rename to extra/digraphs/tags.txt From dacd2dfc1c51b3fc894fe28f24bd887c9aea1568 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 30 Sep 2008 18:42:32 -0700 Subject: [PATCH 039/224] add capability verification and fix shader param error in spheres --- extra/spheres/spheres.factor | 35 +++++++++++++++++++---------------- 1 file changed, 19 insertions(+), 16 deletions(-) diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 84621f8e18..0b7f1f95bb 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,6 +1,6 @@ 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 ; IN: spheres STRING: plane-vertex-shader @@ -162,6 +162,8 @@ M: spheres-gadget distance-step ( gadget -- dz ) 3array check-gl-program ; M: spheres-gadget graft* ( gadget -- ) + "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 @@ -182,14 +184,15 @@ M: spheres-gadget ungraft* ( gadget -- ) 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 @@ -197,12 +200,12 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) 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 ] [ @@ -271,7 +274,7 @@ M: spheres-gadget draw-gadget* ( gadget -- ) [ 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 ] From ded8ae641e9b4d968fcabf057cebfda2e888d5e7 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 2 Oct 2008 11:12:46 +1000 Subject: [PATCH 040/224] Fixed tetris and moved it from unmaintained to extra --- {unmaintained => extra}/tetris/README.txt | 1 + {unmaintained => extra}/tetris/authors.txt | 0 .../tetris/board/authors.txt | 0 extra/tetris/board/board-tests.factor | 23 ++++ .../tetris/board/board.factor | 33 +++-- {unmaintained => extra}/tetris/deploy.factor | 0 .../tetris/game/authors.txt | 0 extra/tetris/game/game-tests.factor | 16 +++ extra/tetris/game/game.factor | 114 ++++++++++++++++++ {unmaintained => extra}/tetris/gl/authors.txt | 0 {unmaintained => extra}/tetris/gl/gl.factor | 29 ++--- .../tetris/piece/authors.txt | 0 extra/tetris/piece/piece-tests.factor | 23 ++++ extra/tetris/piece/piece.factor | 50 ++++++++ {unmaintained => extra}/tetris/summary.txt | 0 {unmaintained => extra}/tetris/tags.txt | 0 extra/tetris/tetris.factor | 56 +++++++++ .../tetris/tetromino/authors.txt | 0 .../tetris/tetromino/tetromino.factor | 2 +- unmaintained/tetris/board/board-tests.factor | 24 ---- unmaintained/tetris/game/game-tests.factor | 16 --- unmaintained/tetris/game/game.factor | 113 ----------------- unmaintained/tetris/piece/piece-tests.factor | 23 ---- unmaintained/tetris/piece/piece.factor | 47 -------- unmaintained/tetris/tetris.factor | 61 ---------- 25 files changed, 315 insertions(+), 316 deletions(-) rename {unmaintained => extra}/tetris/README.txt (91%) rename {unmaintained => extra}/tetris/authors.txt (100%) rename {unmaintained => extra}/tetris/board/authors.txt (100%) create mode 100644 extra/tetris/board/board-tests.factor rename {unmaintained => extra}/tetris/board/board.factor (51%) rename {unmaintained => extra}/tetris/deploy.factor (100%) rename {unmaintained => extra}/tetris/game/authors.txt (100%) create mode 100644 extra/tetris/game/game-tests.factor create mode 100644 extra/tetris/game/game.factor rename {unmaintained => extra}/tetris/gl/authors.txt (100%) rename {unmaintained => extra}/tetris/gl/gl.factor (51%) rename {unmaintained => extra}/tetris/piece/authors.txt (100%) create mode 100644 extra/tetris/piece/piece-tests.factor create mode 100644 extra/tetris/piece/piece.factor rename {unmaintained => extra}/tetris/summary.txt (100%) rename {unmaintained => extra}/tetris/tags.txt (100%) create mode 100644 extra/tetris/tetris.factor rename {unmaintained => extra}/tetris/tetromino/authors.txt (100%) rename {unmaintained => extra}/tetris/tetromino/tetromino.factor (97%) delete mode 100644 unmaintained/tetris/board/board-tests.factor delete mode 100644 unmaintained/tetris/game/game-tests.factor delete mode 100644 unmaintained/tetris/game/game.factor delete mode 100644 unmaintained/tetris/piece/piece-tests.factor delete mode 100644 unmaintained/tetris/piece/piece.factor delete mode 100644 unmaintained/tetris/tetris.factor diff --git a/unmaintained/tetris/README.txt b/extra/tetris/README.txt similarity index 91% rename from unmaintained/tetris/README.txt rename to extra/tetris/README.txt index bd34dc3c16..e8f81fc831 100644 --- a/unmaintained/tetris/README.txt +++ b/extra/tetris/README.txt @@ -14,3 +14,4 @@ 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 diff --git a/unmaintained/tetris/authors.txt b/extra/tetris/authors.txt similarity index 100% rename from unmaintained/tetris/authors.txt rename to extra/tetris/authors.txt diff --git a/unmaintained/tetris/board/authors.txt b/extra/tetris/board/authors.txt similarity index 100% rename from unmaintained/tetris/board/authors.txt rename to extra/tetris/board/authors.txt diff --git a/extra/tetris/board/board-tests.factor b/extra/tetris/board/board-tests.factor new file mode 100644 index 0000000000..518b5544e9 --- /dev/null +++ b/extra/tetris/board/board-tests.factor @@ -0,0 +1,23 @@ +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 rows>> ] unit-test +[ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test +[ f ] [ 2 3 { 1 1 } block ] unit-test +[ 2 3 { 2 3 } block ] must-fail +red 1array [ 2 3 dup { 1 1 } red set-block { 1 1 } block ] unit-test +[ t ] [ 2 3 { 1 1 } block-free? ] unit-test +[ f ] [ 2 3 dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } red set-block { 0 1 } block-free? ] unit-test +[ t ] [ 2 3 { 0 0 } block-in-bounds? ] unit-test +[ f ] [ 2 3 { -1 0 } block-in-bounds? ] unit-test +[ t ] [ 2 3 { 1 2 } block-in-bounds? ] unit-test +[ f ] [ 2 3 { 2 2 } block-in-bounds? ] unit-test +[ t ] [ 2 3 { 1 1 } location-valid? ] unit-test +[ f ] [ 2 3 dup { 1 1 } red set-block { 1 1 } location-valid? ] unit-test +[ t ] [ 10 10 10 piece-valid? ] unit-test +[ f ] [ 2 3 10 { 1 2 } >>location piece-valid? ] unit-test +[ { { f } { f } } ] [ 1 1 add-row rows>> ] unit-test +[ { { f } } ] [ 1 2 dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test +[ { { f } { f } } ] [ 1 2 dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test diff --git a/unmaintained/tetris/board/board.factor b/extra/tetris/board/board.factor similarity index 51% rename from unmaintained/tetris/board/board.factor rename to extra/tetris/board/board.factor index 3e4548078c..1f12dcabe6 100644 --- a/unmaintained/tetris/board/board.factor +++ b/extra/tetris/board/board.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2006, 2007 Alex Chapman +! Copyright (C) 2006, 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences arrays tetris.piece math ; +USING: accessors arrays kernel math sequences tetris.piece ; IN: tetris.board -TUPLE: board width height rows ; +TUPLE: board { width integer } { height integer } rows ; : make-rows ( width height -- rows ) [ drop f ] with map ; @@ -15,17 +15,17 @@ TUPLE: board width height rows ; #! 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 ; + [ second swap rows>> nth ] keep first swap ; -: board-set-block ( board block colour -- ) -rot board@block set-nth ; +: set-block ( board block colour -- ) -rot board@block set-nth ; -: board-block ( board block -- colour ) board@block nth ; +: block ( board block -- colour ) board@block nth ; -: block-free? ( board block -- ? ) board-block not ; +: block-free? ( board block -- ? ) block not ; : block-in-bounds? ( board block -- ? ) - [ first swap board-width bounds-check? ] 2keep - second swap board-height bounds-check? and ; + [ 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 ; @@ -35,22 +35,21 @@ TUPLE: board width height rows ; : row-not-full? ( row -- ? ) f swap member? ; -: add-row ( board -- ) - dup board-rows over board-width f - prefix swap set-board-rows ; +: add-row ( board -- board ) + dup rows>> over width>> f prefix >>rows ; : top-up-rows ( board -- ) - dup board-height over board-rows length = [ + dup height>> over rows>> length = [ drop ] [ - dup add-row top-up-rows + add-row top-up-rows ] if ; -: remove-full-rows ( board -- ) - dup board-rows [ row-not-full? ] filter swap set-board-rows ; +: 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) - dup remove-full-rows dup board-height over board-rows length - >r top-up-rows r> ; + remove-full-rows dup height>> over rows>> length - swap top-up-rows ; diff --git a/unmaintained/tetris/deploy.factor b/extra/tetris/deploy.factor similarity index 100% rename from unmaintained/tetris/deploy.factor rename to extra/tetris/deploy.factor diff --git a/unmaintained/tetris/game/authors.txt b/extra/tetris/game/authors.txt similarity index 100% rename from unmaintained/tetris/game/authors.txt rename to extra/tetris/game/authors.txt diff --git a/extra/tetris/game/game-tests.factor b/extra/tetris/game/game-tests.factor new file mode 100644 index 0000000000..047c20d053 --- /dev/null +++ b/extra/tetris/game/game-tests.factor @@ -0,0 +1,16 @@ +USING: accessors kernel tetris.game tetris.board tetris.piece tools.test +sequences ; + +[ t ] [ [ current-piece ] [ next-piece ] bi and t f ? ] unit-test +[ t ] [ { 1 1 } can-move? ] unit-test +[ t ] [ { 1 1 } tetris-move ] unit-test +[ 1 ] [ dup { 1 1 } tetris-move drop current-piece location>> second ] unit-test +[ 1 ] [ level>> ] unit-test +[ 1 ] [ 9 >>rows level>> ] unit-test +[ 2 ] [ 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 ] [ dup 3 score-rows dup 3 score-rows dup 3 score-rows level>> ] unit-test +[ 2 ] [ dup 4 score-rows dup 4 score-rows dup 2 score-rows level>> ] unit-test + diff --git a/extra/tetris/game/game.factor b/extra/tetris/game/game.factor new file mode 100644 index 0000000000..30622c9e38 --- /dev/null +++ b/extra/tetris/game/game.factor @@ -0,0 +1,114 @@ +! 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 + +: ( width height -- tetris ) + dupd swap + tetris new swap >>pieces swap >>board ; + +: ( -- tetris ) default-width default-height ; + +: ( old -- new ) + board>> [ width>> ] [ height>> ] bi ; + +: 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 ; diff --git a/unmaintained/tetris/gl/authors.txt b/extra/tetris/gl/authors.txt similarity index 100% rename from unmaintained/tetris/gl/authors.txt rename to extra/tetris/gl/authors.txt diff --git a/unmaintained/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor similarity index 51% rename from unmaintained/tetris/gl/gl.factor rename to extra/tetris/gl/gl.factor index e425c4766f..d47f027293 100644 --- a/unmaintained/tetris/gl/gl.factor +++ b/extra/tetris/gl/gl.factor @@ -1,8 +1,6 @@ -! Copyright (C) 2006, 2007 Alex Chapman +! Copyright (C) 2006, 2007, 2008 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 ; +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 @@ -14,33 +12,36 @@ IN: tetris.gl piece-blocks [ draw-block ] each ; : draw-piece ( piece -- ) - dup tetromino-colour gl-color draw-piece-blocks ; + dup tetromino>> colour>> set-color draw-piece-blocks ; : draw-next-piece ( piece -- ) - dup tetromino-colour clone 0.2 3 pick set-nth gl-color draw-piece-blocks ; + 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 - [ gl-color 2array draw-block ] [ 3drop ] if ; + [ set-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 + 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 ; +: 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 [ - [ scale-tetris ] keep - dup tetris-board draw-board - dup tetris-next-piece draw-next-piece - tetris-current-piece draw-piece + { + [ board>> scale-board ] + [ board>> draw-board ] + [ next-piece draw-next-piece ] + [ current-piece draw-piece ] + } cleave ] do-matrix ; : draw-tetris ( width height tetris -- ) diff --git a/unmaintained/tetris/piece/authors.txt b/extra/tetris/piece/authors.txt similarity index 100% rename from unmaintained/tetris/piece/authors.txt rename to extra/tetris/piece/authors.txt diff --git a/extra/tetris/piece/piece-tests.factor b/extra/tetris/piece/piece-tests.factor new file mode 100644 index 0000000000..05e4faa68f --- /dev/null +++ b/extra/tetris/piece/piece-tests.factor @@ -0,0 +1,23 @@ +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 location>> ] unit-test +[ 0 ] [ 10 rotation>> ] unit-test + +[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ] +[ tetrominoes get first piece-blocks ] unit-test + +[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ] +[ tetrominoes get first 1 rotate-piece piece-blocks ] unit-test + +[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ] +[ tetrominoes get first { 1 1 } move-piece piece-blocks ] unit-test + +[ 3 ] [ tetrominoes get second piece-width ] unit-test +[ 2 ] [ tetrominoes get second 1 rotate-piece piece-width ] unit-test diff --git a/extra/tetris/piece/piece.factor b/extra/tetris/piece/piece.factor new file mode 100644 index 0000000000..2ebbfc07d6 --- /dev/null +++ b/extra/tetris/piece/piece.factor @@ -0,0 +1,50 @@ +! 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 } } ; + +: ( 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 ; + +: ( board-width -- piece ) + random-tetromino swap set-start-location ; + +: ( board-width -- llist ) + [ [ ] curry ] keep [ ] 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 ; diff --git a/unmaintained/tetris/summary.txt b/extra/tetris/summary.txt similarity index 100% rename from unmaintained/tetris/summary.txt rename to extra/tetris/summary.txt diff --git a/unmaintained/tetris/tags.txt b/extra/tetris/tags.txt similarity index 100% rename from unmaintained/tetris/tags.txt rename to extra/tetris/tags.txt diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor new file mode 100644 index 0000000000..b200c4d735 --- /dev/null +++ b/extra/tetris/tetris.factor @@ -0,0 +1,56 @@ +! 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 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 ) + [ ] 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 ( -- ) + [ + + "Tetris" open-status-window + ] with-ui ; + +MAIN: tetris-window diff --git a/unmaintained/tetris/tetromino/authors.txt b/extra/tetris/tetromino/authors.txt similarity index 100% rename from unmaintained/tetris/tetromino/authors.txt rename to extra/tetris/tetromino/authors.txt diff --git a/unmaintained/tetris/tetromino/tetromino.factor b/extra/tetris/tetromino/tetromino.factor similarity index 97% rename from unmaintained/tetris/tetromino/tetromino.factor rename to extra/tetris/tetromino/tetromino.factor index 957f808aae..7e6b2ecf34 100644 --- a/unmaintained/tetris/tetromino/tetromino.factor +++ b/extra/tetris/tetromino/tetromino.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Alex Chapman +! 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 ; diff --git a/unmaintained/tetris/board/board-tests.factor b/unmaintained/tetris/board/board-tests.factor deleted file mode 100644 index bd8789c4d6..0000000000 --- a/unmaintained/tetris/board/board-tests.factor +++ /dev/null @@ -1,24 +0,0 @@ -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-rows ] unit-test -[ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test -[ f ] [ 2 3 { 1 1 } board-block ] unit-test -[ 2 3 { 2 3 } board-block ] must-fail -red 1array [ 2 3 dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test -[ t ] [ 2 3 { 1 1 } block-free? ] unit-test -[ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test -[ t ] [ 2 3 dup { 1 1 } red board-set-block { 1 2 } block-free? ] unit-test -[ t ] [ 2 3 dup { 1 1 } red board-set-block { 0 1 } block-free? ] unit-test -[ t ] [ 2 3 { 0 0 } block-in-bounds? ] unit-test -[ f ] [ 2 3 { -1 0 } block-in-bounds? ] unit-test -[ t ] [ 2 3 { 1 2 } block-in-bounds? ] unit-test -[ f ] [ 2 3 { 2 2 } block-in-bounds? ] unit-test -[ t ] [ 2 3 { 1 1 } location-valid? ] unit-test -[ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } location-valid? ] unit-test -[ t ] [ 10 10 10 piece-valid? ] unit-test -[ f ] [ 2 3 10 { 1 2 } over set-piece-location piece-valid? ] unit-test -[ { { f } { f } } ] [ 1 1 dup add-row board-rows ] unit-test -[ { { f } } ] [ 1 2 dup { 0 1 } red board-set-block dup remove-full-rows board-rows ] unit-test -[ { { f } { f } } ] [ 1 2 dup { 0 1 } red board-set-block dup check-rows drop board-rows ] unit-test diff --git a/unmaintained/tetris/game/game-tests.factor b/unmaintained/tetris/game/game-tests.factor deleted file mode 100644 index e5af54803d..0000000000 --- a/unmaintained/tetris/game/game-tests.factor +++ /dev/null @@ -1,16 +0,0 @@ -USING: kernel tetris.game tetris.board tetris.piece tools.test -sequences ; - -[ t ] [ dup tetris-current-piece swap tetris-next-piece and t f ? ] unit-test -[ t ] [ { 1 1 } can-move? ] unit-test -[ t ] [ { 1 1 } tetris-move ] unit-test -[ 1 ] [ dup { 1 1 } tetris-move drop tetris-current-piece piece-location second ] unit-test -[ 1 ] [ tetris-level ] unit-test -[ 1 ] [ 9 over set-tetris-rows tetris-level ] unit-test -[ 2 ] [ 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 ] [ dup 3 score-rows dup 3 score-rows dup 3 score-rows tetris-level ] unit-test -[ 2 ] [ dup 4 score-rows dup 4 score-rows dup 2 score-rows tetris-level ] unit-test - diff --git a/unmaintained/tetris/game/game.factor b/unmaintained/tetris/game/game.factor deleted file mode 100644 index 90df619ff7..0000000000 --- a/unmaintained/tetris/game/game.factor +++ /dev/null @@ -1,113 +0,0 @@ -! 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 - -: ( width height -- tetris ) - tetris construct-delegate - dup board-width 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? ; - -: ( -- tetris ) default-width default-height ; - -: ( old -- new ) - [ board-width ] keep board-height ; - -: 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 ; diff --git a/unmaintained/tetris/piece/piece-tests.factor b/unmaintained/tetris/piece/piece-tests.factor deleted file mode 100644 index d4d19fe822..0000000000 --- a/unmaintained/tetris/piece/piece-tests.factor +++ /dev/null @@ -1,23 +0,0 @@ -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-location ] unit-test -[ 0 ] [ 10 piece-rotation ] unit-test - -[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ] -[ tetrominoes get first piece-blocks ] unit-test - -[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ] -[ tetrominoes get first dup 1 rotate-piece piece-blocks ] unit-test - -[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ] -[ tetrominoes get first dup { 1 1 } move-piece piece-blocks ] unit-test - -[ 3 ] [ tetrominoes get second piece-width ] unit-test -[ 2 ] [ tetrominoes get second dup 1 rotate-piece piece-width ] unit-test diff --git a/unmaintained/tetris/piece/piece.factor b/unmaintained/tetris/piece/piece.factor deleted file mode 100644 index 55215dbf6a..0000000000 --- a/unmaintained/tetris/piece/piece.factor +++ /dev/null @@ -1,47 +0,0 @@ -! 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 ; - -: ( 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 ; - -: ( board-width -- piece ) - random-tetromino [ swap set-start-location ] keep ; - -: ( board-width -- llist ) - [ [ ] curry ] keep [ ] 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 ; - diff --git a/unmaintained/tetris/tetris.factor b/unmaintained/tetris/tetris.factor deleted file mode 100644 index d01cec3790..0000000000 --- a/unmaintained/tetris/tetris.factor +++ /dev/null @@ -1,61 +0,0 @@ -! 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 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 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 ( -- ) - [ - - "Tetris" open-status-window - ] with-ui ; - -MAIN: tetris-window From 2c634cd4abd2a6ad393f6ea3e6a98ec04202dc9e Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Thu, 2 Oct 2008 14:27:39 +1000 Subject: [PATCH 041/224] Moving Jamshred from unmaintained. It's *almost* working. --- {unmaintained => extra}/jamshred/authors.txt | 0 .../jamshred/deploy.factor | 0 .../jamshred/game/authors.txt | 0 .../jamshred/game/game.factor | 0 .../jamshred/gl/authors.txt | 0 {unmaintained => extra}/jamshred/gl/gl.factor | 13 ++++----- .../jamshred/jamshred.factor | 13 ++++----- .../jamshred/log/log.factor | 0 .../jamshred/oint/authors.txt | 0 .../jamshred/oint/oint-tests.factor | 0 .../jamshred/oint/oint.factor | 2 +- .../jamshred/player/authors.txt | 0 .../jamshred/player/player.factor | 5 +--- .../jamshred/sound/bang.wav | Bin .../jamshred/sound/sound.factor | 0 {unmaintained => extra}/jamshred/summary.txt | 0 {unmaintained => extra}/jamshred/tags.txt | 0 .../jamshred/tunnel/authors.txt | 0 .../jamshred/tunnel/tunnel-tests.factor | 26 +++++++++--------- .../jamshred/tunnel/tunnel.factor | 4 +-- 20 files changed, 27 insertions(+), 36 deletions(-) rename {unmaintained => extra}/jamshred/authors.txt (100%) rename {unmaintained => extra}/jamshred/deploy.factor (100%) rename {unmaintained => extra}/jamshred/game/authors.txt (100%) rename {unmaintained => extra}/jamshred/game/game.factor (100%) rename {unmaintained => extra}/jamshred/gl/authors.txt (100%) rename {unmaintained => extra}/jamshred/gl/gl.factor (86%) rename {unmaintained => extra}/jamshred/jamshred.factor (85%) rename {unmaintained => extra}/jamshred/log/log.factor (100%) rename {unmaintained => extra}/jamshred/oint/authors.txt (100%) rename {unmaintained => extra}/jamshred/oint/oint-tests.factor (100%) rename {unmaintained => extra}/jamshred/oint/oint.factor (98%) rename {unmaintained => extra}/jamshred/player/authors.txt (100%) rename {unmaintained => extra}/jamshred/player/player.factor (94%) rename {unmaintained => extra}/jamshred/sound/bang.wav (100%) rename {unmaintained => extra}/jamshred/sound/sound.factor (100%) rename {unmaintained => extra}/jamshred/summary.txt (100%) rename {unmaintained => extra}/jamshred/tags.txt (100%) rename {unmaintained => extra}/jamshred/tunnel/authors.txt (100%) rename {unmaintained => extra}/jamshred/tunnel/tunnel-tests.factor (69%) rename {unmaintained => extra}/jamshred/tunnel/tunnel.factor (98%) diff --git a/unmaintained/jamshred/authors.txt b/extra/jamshred/authors.txt similarity index 100% rename from unmaintained/jamshred/authors.txt rename to extra/jamshred/authors.txt diff --git a/unmaintained/jamshred/deploy.factor b/extra/jamshred/deploy.factor similarity index 100% rename from unmaintained/jamshred/deploy.factor rename to extra/jamshred/deploy.factor diff --git a/unmaintained/jamshred/game/authors.txt b/extra/jamshred/game/authors.txt similarity index 100% rename from unmaintained/jamshred/game/authors.txt rename to extra/jamshred/game/authors.txt diff --git a/unmaintained/jamshred/game/game.factor b/extra/jamshred/game/game.factor similarity index 100% rename from unmaintained/jamshred/game/game.factor rename to extra/jamshred/game/game.factor diff --git a/unmaintained/jamshred/gl/authors.txt b/extra/jamshred/gl/authors.txt similarity index 100% rename from unmaintained/jamshred/gl/authors.txt rename to extra/jamshred/gl/authors.txt diff --git a/unmaintained/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor similarity index 86% rename from unmaintained/jamshred/gl/gl.factor rename to extra/jamshred/gl/gl.factor index 52caaa10c9..69af7ab986 100644 --- a/unmaintained/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -1,9 +1,6 @@ -! Copyright (C) 2007 Alex Chapman +! Copyright (C) 2007, 2008 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 ; +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 @@ -45,7 +42,7 @@ IN: jamshred.gl #! 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 + over color>> gl-color segment-vertex-and-normal gl-normal gl-vertex ; : draw-vertex-pair ( theta next-segment segment -- ) @@ -61,8 +58,8 @@ IN: jamshred.gl 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 ; + dup nearest-segment>> number>> dup n-segments-behind - + swap n-segments-ahead + rot tunnel>> sub-tunnel ; : draw-tunnel ( player -- ) segments-to-render draw-segments ; diff --git a/unmaintained/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor similarity index 85% rename from unmaintained/jamshred/jamshred.factor rename to extra/jamshred/jamshred.factor index d9a0f84b53..aa9c164b8f 100755 --- a/unmaintained/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,15 +1,12 @@ ! 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 ; +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 jamshred last-hand-loc alarm ; +TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ; : ( jamshred -- gadget ) - jamshred-gadget construct-gadget swap >>jamshred ; + jamshred-gadget new-gadget swap >>jamshred ; : default-width ( -- x ) 800 ; : default-height ( -- y ) 600 ; @@ -91,7 +88,7 @@ jamshred-gadget H{ { T{ mouse-scroll } [ handle-mouse-scroll ] } } set-gestures -: jamshred-window ( -- jamshred ) - [ dup "Jamshred" open-window ] with-ui ; +: jamshred-window ( -- gadget ) + [ dup "Jamshred" open-window ] with-ui ; MAIN: jamshred-window diff --git a/unmaintained/jamshred/log/log.factor b/extra/jamshred/log/log.factor similarity index 100% rename from unmaintained/jamshred/log/log.factor rename to extra/jamshred/log/log.factor diff --git a/unmaintained/jamshred/oint/authors.txt b/extra/jamshred/oint/authors.txt similarity index 100% rename from unmaintained/jamshred/oint/authors.txt rename to extra/jamshred/oint/authors.txt diff --git a/unmaintained/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor similarity index 100% rename from unmaintained/jamshred/oint/oint-tests.factor rename to extra/jamshred/oint/oint-tests.factor diff --git a/unmaintained/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor similarity index 98% rename from unmaintained/jamshred/oint/oint.factor rename to extra/jamshred/oint/oint.factor index 7a37646a6d..808e92a1f9 100644 --- a/unmaintained/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Alex Chapman +! 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 diff --git a/unmaintained/jamshred/player/authors.txt b/extra/jamshred/player/authors.txt similarity index 100% rename from unmaintained/jamshred/player/authors.txt rename to extra/jamshred/player/authors.txt diff --git a/unmaintained/jamshred/player/player.factor b/extra/jamshred/player/player.factor similarity index 94% rename from unmaintained/jamshred/player/player.factor rename to extra/jamshred/player/player.factor index 48ea847db1..418847673b 100644 --- a/unmaintained/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,9 +1,6 @@ ! 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 ; +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 system ; IN: jamshred.player TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; diff --git a/unmaintained/jamshred/sound/bang.wav b/extra/jamshred/sound/bang.wav similarity index 100% rename from unmaintained/jamshred/sound/bang.wav rename to extra/jamshred/sound/bang.wav diff --git a/unmaintained/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor similarity index 100% rename from unmaintained/jamshred/sound/sound.factor rename to extra/jamshred/sound/sound.factor diff --git a/unmaintained/jamshred/summary.txt b/extra/jamshred/summary.txt similarity index 100% rename from unmaintained/jamshred/summary.txt rename to extra/jamshred/summary.txt diff --git a/unmaintained/jamshred/tags.txt b/extra/jamshred/tags.txt similarity index 100% rename from unmaintained/jamshred/tags.txt rename to extra/jamshred/tags.txt diff --git a/unmaintained/jamshred/tunnel/authors.txt b/extra/jamshred/tunnel/authors.txt similarity index 100% rename from unmaintained/jamshred/tunnel/authors.txt rename to extra/jamshred/tunnel/authors.txt diff --git a/unmaintained/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor similarity index 69% rename from unmaintained/jamshred/tunnel/tunnel-tests.factor rename to extra/jamshred/tunnel/tunnel-tests.factor index 97077bdd67..9486713f55 100644 --- a/unmaintained/jamshred/tunnel/tunnel-tests.factor +++ b/extra/jamshred/tunnel/tunnel-tests.factor @@ -1,20 +1,20 @@ -! Copyright (C) 2007 Alex Chapman +! Copyright (C) 2007, 2008 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 ; +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 segment-number ] unit-test + nearer-segment number>> ] unit-test -[ 0 ] [ T{ oint f { 0 0 0 } } find-nearest-segment segment-number ] unit-test -[ 1 ] [ T{ oint f { 0 0 -1 } } find-nearest-segment segment-number ] unit-test -[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } find-nearest-segment segment-number ] unit-test +[ 0 ] [ T{ oint f { 0 0 0 } } find-nearest-segment number>> ] unit-test +[ 1 ] [ T{ oint f { 0 0 -1 } } find-nearest-segment number>> ] unit-test +[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } find-nearest-segment number>> ] unit-test -[ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test +[ 3 ] [ T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test -[ F{ 0 0 0 } ] [ T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test +[ F{ 0 0 0 } ] [ 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 } ; @@ -32,14 +32,14 @@ IN: jamshred.tunnel.tests { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } initial-segment ; -[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test -[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test +[ { 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 } 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 } ] +[ { 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 diff --git a/unmaintained/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor similarity index 98% rename from unmaintained/jamshred/tunnel/tunnel.factor rename to extra/jamshred/tunnel/tunnel.factor index 99c396bebd..8d2cc8e766 100755 --- a/unmaintained/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -21,7 +21,7 @@ C: segment : 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-color >>color dup segment-number++ ; : (random-segments) ( segments n -- segments ) dup 0 > [ @@ -77,7 +77,7 @@ C: 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 + number>> over >r [ nearest-segment-forward ] 3keep nearest-segment-backward r> nearer-segment ; From 3399a579d03f412cf57627aed56f0c195a2d1d4a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 4 Oct 2008 16:33:51 -0700 Subject: [PATCH 042/224] call find-gl-context to ensure context is set during graft/ungraft in GL demos --- extra/bunny/bunny.factor | 5 ++++- extra/spheres/spheres.factor | 4 +++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index ed89f2a809..d0625e464f 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,6 +1,7 @@ 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 ; @@ -18,6 +19,7 @@ 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>> >>geom dup @@ -29,6 +31,7 @@ M: bunny-gadget graft* ( gadget -- ) drop ; M: bunny-gadget ungraft* ( gadget -- ) + dup find-gl-context [ geom>> [ dispose ] when* ] [ draw-seq>> [ [ dispose ] when* ] each ] bi ; diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 0b7f1f95bb..f119956db6 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,6 +1,6 @@ USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers opengl multiline ui.gadgets accessors sequences ui.render ui math locals -arrays generalizations combinators opengl.capabilities ; +arrays generalizations combinators opengl.capabilities ui.gadgets.worlds ; IN: spheres STRING: plane-vertex-shader @@ -162,6 +162,7 @@ M: spheres-gadget distance-step ( gadget -- dz ) 3array 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 @@ -173,6 +174,7 @@ M: spheres-gadget graft* ( gadget -- ) drop ; M: spheres-gadget ungraft* ( gadget -- ) + dup find-gl-context { [ reflection-framebuffer>> [ delete-framebuffer ] when* ] [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] From 7c9d7f476ab00f9c028d24115b088fadf182343a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 18:28:10 -0500 Subject: [PATCH 043/224] windows needs timeval struct too --- basis/windows/winsock/winsock.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 3c4230e21e..4ca07ce850 100644 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -1,8 +1,8 @@ ! 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 @@ -138,6 +138,10 @@ C-STRUCT: addrinfo { "sockaddr*" "addr" } { "addrinfo*" "next" } ; +C-STRUCT: timeval + { "long" "sec" } + { "long" "usec" } ; + : hostent-addr ( hostent -- addr ) hostent-addr-list *void* ; ! *uint ; LIBRARY: winsock @@ -440,4 +444,3 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi : init-winsock ( -- ) HEX: 0202 WSAStartup winsock-return-check ; - From 8e315944b41e5bb4d8403742e8340abb6278699f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 19:01:41 -0500 Subject: [PATCH 044/224] fix --- basis/io/unix/backend/backend.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor index 0e9139f431..5bb0b82555 100644 --- a/basis/io/unix/backend/backend.factor +++ b/basis/io/unix/backend/backend.factor @@ -1,11 +1,11 @@ ! 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 From 69b3306f4b47daefab7edd0018598cf9e3649f05 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 19:13:33 -0500 Subject: [PATCH 045/224] fix using --- basis/io/unix/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index fafc56154b..f0dc028d74 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -4,7 +4,7 @@ USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system -io.files.private destructors vocabs.loader ; +io.files.private destructors vocabs.loader calendar.unix ; IN: io.unix.files From 114e81590cf9367ea4f33c13eb74e4be464a7564 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 20:52:32 -0500 Subject: [PATCH 046/224] renamed timestamp>unix-time --- basis/io/unix/files/freebsd/freebsd.factor | 2 +- basis/io/unix/files/netbsd/netbsd.factor | 2 +- basis/io/unix/files/openbsd/openbsd.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor index e6fff4dfe0..26cfe48bb1 100644 --- a/basis/io/unix/files/freebsd/freebsd.factor +++ b/basis/io/unix/files/freebsd/freebsd.factor @@ -13,5 +13,5 @@ M: freebsd stat>file-info ( stat -- file-info ) { [ stat-st_flags >>flags ] [ stat-st_gen >>gen ] - [ stat-st_birthtimespec timespec>timestamp >>birth-time ] + [ stat-st_birthtimespec timespec>unix-time >>birth-time ] } cleave ; diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor index 6a41e6e18a..c5f52cc100 100644 --- a/basis/io/unix/files/netbsd/netbsd.factor +++ b/basis/io/unix/files/netbsd/netbsd.factor @@ -13,5 +13,5 @@ M: netbsd stat>file-info ( stat -- file-info ) { [ stat-st_flags >>flags ] [ stat-st_gen >>gen ] - [ stat-st_birthtim timespec>timestamp >>birth-time ] + [ stat-st_birthtim timespec>unix-time >>birth-time ] } cleave ; diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor index 5723827481..58833e7c97 100644 --- a/basis/io/unix/files/openbsd/openbsd.factor +++ b/basis/io/unix/files/openbsd/openbsd.factor @@ -13,5 +13,5 @@ M: openbsd stat>file-info ( stat -- file-info ) { [ stat-st_flags >>flags ] [ stat-st_gen >>gen ] - [ stat-st_birthtim timespec>timestamp >>birth-time ] + [ stat-st_birthtim timespec>unix-time >>birth-time ] } cleave ; From 1f1a62fcdd2a8969a375a0b7ec7c70fd66c013f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 21:02:10 -0500 Subject: [PATCH 047/224] fix using --- basis/io/unix/select/select.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/unix/select/select.factor b/basis/io/unix/select/select.factor index f0547da10e..8638ae7be5 100644 --- a/basis/io/unix/select/select.factor +++ b/basis/io/unix/select/select.factor @@ -2,7 +2,7 @@ ! 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 ; +accessors math.order locals unix.time ; IN: io.unix.select TUPLE: select-mx < mx read-fdset write-fdset ; From 9751a38fa73f7b1f48293f8c77c6a6eaa3b5a8a0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 21:04:30 -0500 Subject: [PATCH 048/224] since-1970 docs --- basis/calendar/calendar-docs.factor | 6 ++++++ basis/calendar/calendar.factor | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index f1cdafb476..64c74a494a 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -512,6 +512,12 @@ HELP: time-since-midnight { $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 } diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index d5824768f4..c002760748 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -401,7 +401,7 @@ PRIVATE> : time-since-midnight ( timestamp -- duration ) dup midnight time- ; -: since-1970 ( time -- timestamp ) +: since-1970 ( duration -- timestamp ) unix-1970 time+ >local-time ; M: timestamp sleep-until timestamp>millis sleep-until ; From 1d5b86f23c2c6820946a07f64ff2c79272df50f2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 21:16:15 -0500 Subject: [PATCH 049/224] factor is hard. let's go shopping! --- basis/io/unix/select/select.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/unix/select/select.factor b/basis/io/unix/select/select.factor index 8638ae7be5..f2a802a859 100644 --- a/basis/io/unix/select/select.factor +++ b/basis/io/unix/select/select.factor @@ -1,7 +1,7 @@ ! 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 +bit-arrays sequences assocs unix math namespaces accessors math.order locals unix.time ; IN: io.unix.select From ff64bafae24efebaaf7ee9c943ccd5126458c5b8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 21:17:51 -0500 Subject: [PATCH 050/224] dont use structs --- basis/io/unix/epoll/epoll.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/unix/epoll/epoll.factor b/basis/io/unix/epoll/epoll.factor index 406a7fcb50..05a9bcfa8d 100644 --- a/basis/io/unix/epoll/epoll.factor +++ b/basis/io/unix/epoll/epoll.factor @@ -2,7 +2,7 @@ ! 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 ; From 0e81d4c82c4130a829a4703c68ee6e75ac078325 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 21:41:06 -0500 Subject: [PATCH 051/224] last using patch, i think i got it --- basis/calendar/unix/unix.factor | 12 ------------ basis/unix/time/time.factor | 12 ++++++++++++ 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index fcdfcc8a67..d5b66ffc1a 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -4,18 +4,6 @@ USING: alien alien.c-types alien.syntax arrays calendar kernel math unix unix.time namespaces system ; IN: calendar.unix -: make-timeval ( ms -- timeval ) - 1000 /mod 1000 * - "timeval" - [ set-timeval-usec ] keep - [ set-timeval-sec ] keep ; - -: make-timespec ( ms -- timespec ) - 1000 /mod 1000000 * - "timespec" - [ set-timespec-nsec ] keep - [ set-timespec-sec ] keep ; - : timeval>unix-time ( timeval -- timestamp ) [ timeval-sec seconds ] [ timeval-usec microseconds ] bi time+ since-1970 ; diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index b6471e9892..c664aa3bfb 100644 --- a/basis/unix/time/time.factor +++ b/basis/unix/time/time.factor @@ -11,6 +11,18 @@ C-STRUCT: timespec { "time_t" "sec" } { "long" "nsec" } ; +: make-timeval ( ms -- timeval ) + 1000 /mod 1000 * + "timeval" + [ set-timeval-usec ] keep + [ set-timeval-sec ] keep ; + +: make-timespec ( ms -- timespec ) + 1000 /mod 1000000 * + "timespec" + [ set-timespec-nsec ] keep + [ set-timespec-sec ] keep ; + C-STRUCT: tm { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) { "int" "min" } ! Minutes: 0-59 From 312f399003e7e51bc5e6df57770c3bba87b061d0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 22:51:06 -0500 Subject: [PATCH 052/224] found stat64 for macosx, so there's a unix-file-info and a bsd-file-info only --- basis/io/unix/files/files.factor | 14 +++++++------- basis/io/unix/files/freebsd/freebsd.factor | 17 ----------------- basis/io/unix/files/freebsd/tags.txt | 1 - basis/io/unix/files/macosx/macosx.factor | 16 ---------------- basis/io/unix/files/macosx/tags.txt | 1 - basis/io/unix/files/netbsd/netbsd.factor | 17 ----------------- basis/io/unix/files/netbsd/tags.txt | 1 - basis/io/unix/files/openbsd/openbsd.factor | 17 ----------------- basis/io/unix/files/openbsd/tags.txt | 1 - basis/unix/stat/freebsd/32/32.factor | 8 ++++---- basis/unix/stat/freebsd/64/64.factor | 6 +++--- basis/unix/stat/linux/32/32.factor | 8 ++++---- basis/unix/stat/linux/64/64.factor | 6 +++--- basis/unix/stat/macosx/macosx.factor | 15 +++++++-------- basis/unix/stat/netbsd/32/32.factor | 8 ++++---- basis/unix/stat/netbsd/64/64.factor | 8 ++++---- basis/unix/stat/openbsd/openbsd.factor | 8 ++++---- 17 files changed, 40 insertions(+), 112 deletions(-) delete mode 100644 basis/io/unix/files/freebsd/freebsd.factor delete mode 100644 basis/io/unix/files/freebsd/tags.txt delete mode 100644 basis/io/unix/files/macosx/macosx.factor delete mode 100644 basis/io/unix/files/macosx/tags.txt delete mode 100644 basis/io/unix/files/netbsd/netbsd.factor delete mode 100644 basis/io/unix/files/netbsd/tags.txt delete mode 100644 basis/io/unix/files/openbsd/openbsd.factor delete mode 100644 basis/io/unix/files/openbsd/tags.txt diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index f0dc028d74..6ddb74f4a3 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -103,9 +103,9 @@ M: unix stat>file-info ( stat -- file-info ) [ stat>type >>type ] [ stat-st_size >>size ] [ stat-st_mode >>permissions ] - [ stat-st_ctim timespec>unix-time >>created ] - [ stat-st_mtim timespec>unix-time >>modified ] - [ stat-st_atim timespec>unix-time >>accessed ] + [ 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 ] @@ -130,9 +130,9 @@ M: unix stat>type ( stat -- type ) ! Linux has no extra fields in its stat struct os { - { macosx [ "io.unix.files.macosx" require ] } - { freebsd [ "io.unix.files.freebsd" require ] } - { netbsd [ "io.unix.files.netbsd" require ] } - { openbsd [ "io.unix.files.openbsd" require ] } + { 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 diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor deleted file mode 100644 index 26cfe48bb1..0000000000 --- a/basis/io/unix/files/freebsd/freebsd.factor +++ /dev/null @@ -1,17 +0,0 @@ -! 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.freebsd - -TUPLE: freebsd-file-info < unix-file-info birth-time flags gen ; - -M: freebsd new-file-info ( -- class ) freebsd-file-info new ; - -M: freebsd 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 ; diff --git a/basis/io/unix/files/freebsd/tags.txt b/basis/io/unix/files/freebsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/freebsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/macosx/macosx.factor b/basis/io/unix/files/macosx/macosx.factor deleted file mode 100644 index 4173123e45..0000000000 --- a/basis/io/unix/files/macosx/macosx.factor +++ /dev/null @@ -1,16 +0,0 @@ -! 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 ; -IN: io.unix.files.macosx - -TUPLE: macosx-file-info < unix-file-info flags gen ; - -M: macosx new-file-info ( -- class ) macosx-file-info new ; - -M: macosx stat>file-info ( stat -- file-info ) - [ call-next-method ] keep - { - [ stat-st_flags >>flags ] - [ stat-st_gen >>gen ] - } cleave ; diff --git a/basis/io/unix/files/macosx/tags.txt b/basis/io/unix/files/macosx/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/macosx/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor deleted file mode 100644 index c5f52cc100..0000000000 --- a/basis/io/unix/files/netbsd/netbsd.factor +++ /dev/null @@ -1,17 +0,0 @@ -! 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.netbsd - -TUPLE: netbsd-file-info < unix-file-info birth-time flags gen ; - -M: netbsd new-file-info ( -- class ) netbsd-file-info new ; - -M: netbsd stat>file-info ( stat -- file-info ) - [ call-next-method ] keep - { - [ stat-st_flags >>flags ] - [ stat-st_gen >>gen ] - [ stat-st_birthtim timespec>unix-time >>birth-time ] - } cleave ; diff --git a/basis/io/unix/files/netbsd/tags.txt b/basis/io/unix/files/netbsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/netbsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor deleted file mode 100644 index 58833e7c97..0000000000 --- a/basis/io/unix/files/openbsd/openbsd.factor +++ /dev/null @@ -1,17 +0,0 @@ -! 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.openbsd - -TUPLE: openbsd-file-info < unix-file-info birth-time flags gen ; - -M: openbsd new-file-info ( -- class ) openbsd-file-info new ; - -M: openbsd stat>file-info ( stat -- file-info ) - [ call-next-method ] keep - { - [ stat-st_flags >>flags ] - [ stat-st_gen >>gen ] - [ stat-st_birthtim timespec>unix-time >>birth-time ] - } cleave ; diff --git a/basis/io/unix/files/openbsd/tags.txt b/basis/io/unix/files/openbsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/openbsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/unix/stat/freebsd/32/32.factor b/basis/unix/stat/freebsd/32/32.factor index a81fc4f02e..3692dea0c0 100644 --- a/basis/unix/stat/freebsd/32/32.factor +++ b/basis/unix/stat/freebsd/32/32.factor @@ -12,9 +12,9 @@ C-STRUCT: stat { "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" } @@ -27,4 +27,4 @@ C-STRUCT: stat { "__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 ) ; diff --git a/basis/unix/stat/freebsd/64/64.factor b/basis/unix/stat/freebsd/64/64.factor index 75d51cd6ae..73ba676701 100644 --- a/basis/unix/stat/freebsd/64/64.factor +++ b/basis/unix/stat/freebsd/64/64.factor @@ -12,9 +12,9 @@ C-STRUCT: stat { "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" } diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor index ed53fab86b..3f6c6ba0e0 100644 --- a/basis/unix/stat/linux/32/32.factor +++ b/basis/unix/stat/linux/32/32.factor @@ -18,9 +18,9 @@ C-STRUCT: stat { "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" } ; @@ -30,4 +30,4 @@ 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 ; diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index a374551385..088ab8d339 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -17,9 +17,9 @@ C-STRUCT: stat { "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" } ; diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index 4d84e38399..65e02b7986 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -1,21 +1,21 @@ - USING: kernel alien.syntax math ; - 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" } + { "ino_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" } @@ -25,9 +25,8 @@ C-STRUCT: stat { "__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 ; diff --git a/basis/unix/stat/netbsd/32/32.factor b/basis/unix/stat/netbsd/32/32.factor index 55f5108c70..d6a60ba5c8 100644 --- a/basis/unix/stat/netbsd/32/32.factor +++ b/basis/unix/stat/netbsd/32/32.factor @@ -11,10 +11,10 @@ C-STRUCT: stat { "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" } diff --git a/basis/unix/stat/netbsd/64/64.factor b/basis/unix/stat/netbsd/64/64.factor index 163695b524..1a1f97507c 100644 --- a/basis/unix/stat/netbsd/64/64.factor +++ b/basis/unix/stat/netbsd/64/64.factor @@ -11,16 +11,16 @@ C-STRUCT: stat { "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 ) ; diff --git a/basis/unix/stat/openbsd/openbsd.factor b/basis/unix/stat/openbsd/openbsd.factor index decfb0dbb1..f76d4c6e18 100644 --- a/basis/unix/stat/openbsd/openbsd.factor +++ b/basis/unix/stat/openbsd/openbsd.factor @@ -12,16 +12,16 @@ C-STRUCT: stat { "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 ) ; From 39160d66e3f086a60341c9b6ff8bde8364c79143 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 6 Oct 2008 23:02:06 -0500 Subject: [PATCH 053/224] add files --- basis/io/unix/files/bsd/bsd.factor | 17 +++++++++++++++++ basis/io/unix/files/bsd/tags.txt | 1 + 2 files changed, 18 insertions(+) create mode 100644 basis/io/unix/files/bsd/bsd.factor create mode 100644 basis/io/unix/files/bsd/tags.txt diff --git a/basis/io/unix/files/bsd/bsd.factor b/basis/io/unix/files/bsd/bsd.factor new file mode 100644 index 0000000000..18e713af2f --- /dev/null +++ b/basis/io/unix/files/bsd/bsd.factor @@ -0,0 +1,17 @@ +! 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 ; diff --git a/basis/io/unix/files/bsd/tags.txt b/basis/io/unix/files/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/unix/files/bsd/tags.txt @@ -0,0 +1 @@ +unportable From 7c05a777baf2b152185ce6289c9c1570d5429c2c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Oct 2008 01:27:18 -0500 Subject: [PATCH 054/224] Add unportable tag and other meta-data to core-foundation subvocabs --- basis/core-foundation/run-loop/authors.txt | 1 + basis/core-foundation/run-loop/summary.txt | 1 + basis/core-foundation/run-loop/thread/authors.txt | 1 + basis/core-foundation/run-loop/thread/summary.txt | 1 + basis/core-foundation/run-loop/thread/tags.txt | 1 + 5 files changed, 5 insertions(+) create mode 100644 basis/core-foundation/run-loop/authors.txt create mode 100644 basis/core-foundation/run-loop/summary.txt create mode 100644 basis/core-foundation/run-loop/thread/authors.txt create mode 100644 basis/core-foundation/run-loop/thread/summary.txt create mode 100644 basis/core-foundation/run-loop/thread/tags.txt diff --git a/basis/core-foundation/run-loop/authors.txt b/basis/core-foundation/run-loop/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/core-foundation/run-loop/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/core-foundation/run-loop/summary.txt b/basis/core-foundation/run-loop/summary.txt new file mode 100644 index 0000000000..ae92138528 --- /dev/null +++ b/basis/core-foundation/run-loop/summary.txt @@ -0,0 +1 @@ +CoreFoundation run loop integration diff --git a/basis/core-foundation/run-loop/thread/authors.txt b/basis/core-foundation/run-loop/thread/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/core-foundation/run-loop/thread/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/core-foundation/run-loop/thread/summary.txt b/basis/core-foundation/run-loop/thread/summary.txt new file mode 100644 index 0000000000..e5818b3d78 --- /dev/null +++ b/basis/core-foundation/run-loop/thread/summary.txt @@ -0,0 +1 @@ +Vocabulary with init hook for running CoreFoundation event loop diff --git a/basis/core-foundation/run-loop/thread/tags.txt b/basis/core-foundation/run-loop/thread/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/core-foundation/run-loop/thread/tags.txt @@ -0,0 +1 @@ +unportable From bc5f19b919a9d13aa3434dfb54296a80aac8d2df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 07:24:10 -0500 Subject: [PATCH 055/224] fix typo --- basis/db/db-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 0acd1f0245..16a8228fca 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -172,7 +172,7 @@ HELP: sql-row-typed 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 From d656509e24b82612ff1edc12d09657e0c510723e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 07:43:49 -0500 Subject: [PATCH 056/224] fix mac stat --- basis/unix/stat/macosx/macosx.factor | 2 +- basis/unix/stat/stat.factor | 44 ++++++++------------------- basis/unix/types/macosx/macosx.factor | 1 + 3 files changed, 14 insertions(+), 33 deletions(-) diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index 65e02b7986..b2574b474d 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -8,7 +8,7 @@ C-STRUCT: stat { "dev_t" "st_dev" } { "mode_t" "st_mode" } { "nlink_t" "st_nlink" } - { "ino_t" "st_ino" } + { "ino64_t" "st_ino" } { "uid_t" "st_uid" } { "gid_t" "st_gid" } { "dev_t" "st_rdev" } diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index 2bc60105b4..062ad7e1bb 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -1,12 +1,8 @@ - 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. @@ -18,54 +14,38 @@ IN: unix.stat : 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_ISUID OCT: 0004000 ; inline +: S_ISGID OCT: 0002000 ; inline +: S_ISVTX OCT: 0001000 ; inline : 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 - { +<< 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" dup >r - [ stat ] unix-system-call drop - r> ; + "stat" [ + [ stat ] unix-system-call drop + ] keep ; : link-status ( pathname -- stat ) - "stat" dup >r - [ lstat ] unix-system-call drop - r> ; + "stat" [ + [ lstat ] unix-system-call drop + ] keep ; diff --git a/basis/unix/types/macosx/macosx.factor b/basis/unix/types/macosx/macosx.factor index 8f9c5082df..156e756641 100644 --- a/basis/unix/types/macosx/macosx.factor +++ b/basis/unix/types/macosx/macosx.factor @@ -22,6 +22,7 @@ TYPEDEF: __uint32_t uid_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 From 5cc44e8ad84dd1fc4b0459816e1ec443566e32f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 13:15:29 -0500 Subject: [PATCH 057/224] move passwd struct from macosx to bsd --- basis/unix/bsd/bsd.factor | 13 +++++++++++++ basis/unix/bsd/macosx/macosx.factor | 13 ------------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index 6934d5b8dc..7bbf2b4fdf 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -48,6 +48,19 @@ C-STRUCT: sockaddr-un { "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 diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index 6582d29687..9b4dd1c53b 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -13,19 +13,6 @@ C-STRUCT: addrinfo { "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" } ; - : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline From 9e807a88c6ce3b461b71cdabbd81fb514325233e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 13:16:18 -0500 Subject: [PATCH 058/224] ffi work --- basis/unix/unix.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index a68274f09b..facfa4b9d4 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -9,6 +9,7 @@ IN: unix TYPEDEF: uint in_addr_t TYPEDEF: uint socklen_t +TYPEDEF: int int32_t : PROT_NONE 0 ; inline : PROT_READ 1 ; inline @@ -78,6 +79,8 @@ MACRO:: unix-system-call ( quot -- ) 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 ) ; @@ -91,6 +94,7 @@ FUNCTION: int dup2 ( int oldd, int newd ) ; : _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 ) ; @@ -108,6 +112,8 @@ FUNCTION: gid_t getgid ; 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 ) ; From 6a5dd26c52ff727b72a1dde8d9558bc9ea7e493c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Oct 2008 16:13:29 -0500 Subject: [PATCH 059/224] Working on new codegen again --- unfinished/compiler/alien/alien.factor | 21 +-------- unfinished/compiler/backend/backend.factor | 5 +-- .../compiler/cfg/builder/builder.factor | 44 ++++++++++++++----- unfinished/compiler/cfg/cfg.factor | 2 +- .../cfg/instructions/instructions.factor | 18 +++++--- .../cfg/stack-frame/stack-frame.factor | 38 +++++++++------- unfinished/compiler/cfg/stacks/stacks.factor | 2 +- .../compiler/cfg/templates/templates.factor | 11 ++--- unfinished/compiler/codegen/codegen.factor | 17 ++++--- 9 files changed, 86 insertions(+), 72 deletions(-) diff --git a/unfinished/compiler/alien/alien.factor b/unfinished/compiler/alien/alien.factor index 1d63a06057..e414d6e29b 100644 --- a/unfinished/compiler/alien/alien.factor +++ b/unfinished/compiler/alien/alien.factor @@ -1,15 +1,11 @@ ! 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>> @@ -31,16 +27,3 @@ IN: compiler.alien [ 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 + ; diff --git a/unfinished/compiler/backend/backend.factor b/unfinished/compiler/backend/backend.factor index 2efd22610e..2a516c6ec4 100644 --- a/unfinished/compiler/backend/backend.factor +++ b/unfinished/compiler/backend/backend.factor @@ -33,10 +33,7 @@ GENERIC# load-literal 1 ( obj reg -- ) 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 -- ) diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor index ff1ddd9747..c8add3ca09 100755 --- a/unfinished/compiler/cfg/builder/builder.factor +++ b/unfinished/compiler/cfg/builder/builder.factor @@ -2,7 +2,7 @@ ! 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 @@ -107,7 +107,7 @@ SYMBOL: +if-intrinsics+ : 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 ; @@ -235,7 +235,7 @@ M: #dispatch emit-node (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 -- ) @@ -306,21 +306,41 @@ M: #return-recursive emit-node 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 ; + +: ( 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>> ##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 diff --git a/unfinished/compiler/cfg/cfg.factor b/unfinished/compiler/cfg/cfg.factor index 140d406c4c..e32ad47890 100644 --- a/unfinished/compiler/cfg/cfg.factor +++ b/unfinished/compiler/cfg/cfg.factor @@ -19,7 +19,7 @@ successors ; V{ } clone >>instructions V{ } clone >>successors ; -TUPLE: mr instructions word label frame-size spill-counts ; +TUPLE: mr instructions word label ; : ( instructions word label -- mr ) mr new diff --git a/unfinished/compiler/cfg/instructions/instructions.factor b/unfinished/compiler/cfg/instructions/instructions.factor index 9bb576dcb3..3014587edd 100644 --- a/unfinished/compiler/cfg/instructions/instructions.factor +++ b/unfinished/compiler/cfg/instructions/instructions.factor @@ -17,12 +17,19 @@ INSN: ##replace src loc ; 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 @@ -87,7 +94,6 @@ M: ##intrinsic uses-vregs intrinsic-uses-vregs ; ! Instructions used by CFG IR only. INSN: ##prologue ; INSN: ##epilogue ; -INSN: ##frame-required n ; INSN: ##branch ; INSN: ##branch-f < ##cond-branch ; @@ -100,8 +106,8 @@ M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ; 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 ; diff --git a/unfinished/compiler/cfg/stack-frame/stack-frame.factor b/unfinished/compiler/cfg/stack-frame/stack-frame.factor index 56282cfb09..6ec34d37c2 100644 --- a/unfinished/compiler/cfg/stack-frame/stack-frame.factor +++ b/unfinished/compiler/cfg/stack-frame/stack-frame.factor @@ -7,40 +7,47 @@ IN: compiler.cfg.stack-frame 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-frame-size* ( insn -- ) +GENERIC: compute-stack-frame* ( insn -- ) -M: ##frame-required compute-frame-size* +: max-stack-frame ( frame1 frame2 -- frame3 ) + { + [ [ size>> ] bi@ max ] + [ [ params>> ] bi@ max ] + [ [ return>> ] bi@ max ] + [ [ total-size>> ] bi@ max ] + } cleave + stack-frame boa ; + +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* , ; @@ -51,9 +58,8 @@ 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 ; diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/unfinished/compiler/cfg/stacks/stacks.factor index 39cd942bb2..56be18c107 100755 --- a/unfinished/compiler/cfg/stacks/stacks.factor +++ b/unfinished/compiler/cfg/stacks/stacks.factor @@ -312,7 +312,7 @@ M: loc lazy-store finalize-contents finalize-heights fresh-objects get [ - empty? [ 0 ##frame-required ##gc ] unless + empty? [ ##simple-stack-frame ##gc ] unless ] [ delete-all ] bi ; : init-phantoms ( -- ) diff --git a/unfinished/compiler/cfg/templates/templates.factor b/unfinished/compiler/cfg/templates/templates.factor index 12a56704d0..72e092ad68 100644 --- a/unfinished/compiler/cfg/templates/templates.factor +++ b/unfinished/compiler/cfg/templates/templates.factor @@ -28,13 +28,10 @@ TUPLE: template input output scratch clobber gc ; : 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 ) [ diff --git a/unfinished/compiler/codegen/codegen.factor b/unfinished/compiler/codegen/codegen.factor index 15ebd691bf..fe6b45e88a 100644 --- a/unfinished/compiler/codegen/codegen.factor +++ b/unfinished/compiler/codegen/codegen.factor @@ -10,7 +10,8 @@ compiler.backend compiler.codegen.fixup compiler.cfg compiler.cfg.instructions -compiler.cfg.registers ; +compiler.cfg.registers +compiler.cfg.builder ; IN: compiler.codegen GENERIC: generate-insn ( insn -- ) @@ -71,10 +72,14 @@ M: _label generate-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 ; @@ -276,8 +281,8 @@ M: long-long-type flatten-value-type ( type -- types ) #! 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 @@ -413,7 +418,7 @@ TUPLE: callback-context ; : callback-unwind ( params -- n ) { - { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } + { [ dup abi>> "stdcall" = ] [ size>> ] } { [ dup return>> large-struct? ] [ drop 4 ] } [ drop 0 ] } cond ; From a10fd92a33df1c2a17ec5a5414114f225679dc8c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 17:18:49 -0500 Subject: [PATCH 060/224] fix lambda-macro reset-word bug --- basis/locals/locals.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 05ea3cb524..bbcc8a6745 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -421,7 +421,7 @@ M: lambda-macro definition "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 ; From 9940031cda88a6a872f3842f31afb7128b6c873a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 17:47:20 -0500 Subject: [PATCH 061/224] removed dead code in unmaintained/io --- unmaintained/io/io.factor | 8 -- unmaintained/io/os-unix.factor | 213 --------------------------------- 2 files changed, 221 deletions(-) delete mode 100644 unmaintained/io/io.factor diff --git a/unmaintained/io/io.factor b/unmaintained/io/io.factor deleted file mode 100644 index 24151d96c6..0000000000 --- a/unmaintained/io/io.factor +++ /dev/null @@ -1,8 +0,0 @@ -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 ; - diff --git a/unmaintained/io/os-unix.factor b/unmaintained/io/os-unix.factor index 7ae47cda3d..280908b406 100644 --- a/unmaintained/io/os-unix.factor +++ b/unmaintained/io/os-unix.factor @@ -11,219 +11,6 @@ IN: libs-io : 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 ; - -: ( path -- stream ) open-append ; - -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" [ stat io-error ] keep ; - -: make-timeval-array ( array -- byte-array ) - [ length "timeval" ] 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 { From 9228d367a14d3003d67b079b1301bb7c2d708542 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 19:23:35 -0500 Subject: [PATCH 062/224] ffi structs and typedefs --- basis/unix/bsd/macosx/macosx.factor | 15 ++++++++++ basis/unix/bsd/netbsd/netbsd.factor | 45 ++++++++++++++++++++++++++++- basis/unix/stat/stat.factor | 24 +++++++-------- basis/unix/types/types.factor | 23 +++++++++++++++ basis/unix/unix.factor | 4 --- 5 files changed, 94 insertions(+), 17 deletions(-) diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index 9b4dd1c53b..ed2bdecf61 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -117,3 +117,18 @@ C-STRUCT: addrinfo : ETIME 101 ; inline : EOPNOTSUPP 102 ; inline : ENOPOLICY 103 ; inline + +: _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" } ; diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index e646f87116..6bae953938 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax alien.c-types math ; IN: unix : FD_SETSIZE 256 ; inline @@ -111,3 +111,46 @@ C-STRUCT: addrinfo : 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 + +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" } ; diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index 062ad7e1bb..139f1b1983 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -15,18 +15,18 @@ IN: unix.stat : S_IFSOCK OCT: 140000 ; inline ! Socket. ! File Access Permissions -: S_ISUID OCT: 0004000 ; inline -: S_ISGID OCT: 0002000 ; inline -: S_ISVTX OCT: 0001000 ; inline -: S_IRUSR OCT: 0000400 ; inline ! r owner -: S_IWUSR OCT: 0000200 ; inline ! w owner -: S_IXUSR OCT: 0000100 ; inline ! x owner -: S_IRGRP OCT: 0000040 ; inline ! r group -: S_IWGRP OCT: 0000020 ; inline ! w group -: S_IXGRP OCT: 0000010 ; inline ! x group -: S_IROTH OCT: 0000004 ; inline ! r other -: S_IWOTH OCT: 0000002 ; inline ! w other -: S_IXOTH OCT: 0000001 ; inline ! x other +: UID OCT: 0004000 ; inline +: GID OCT: 0002000 ; inline +: STICKY OCT: 0001000 ; inline +: USER-READ OCT: 0000400 ; inline ! r owner +: USER-WRITE OCT: 0000200 ; inline ! w owner +: USER-EXECUTE OCT: 0000100 ; inline ! x owner +: GROUP-READ OCT: 0000040 ; inline ! r group +: GROUP-WRITE OCT: 0000020 ; inline ! w group +: GROUP-EXECUTE OCT: 0000010 ; inline ! x group +: OTHER-READ OCT: 0000004 ; inline ! r other +: OTHER-WRITE OCT: 0000002 ; inline ! w other +: OTHER-EXECUTE OCT: 0000001 ; inline ! x other FUNCTION: int chmod ( char* path, mode_t mode ) ; FUNCTION: int fchmod ( int fd, mode_t mode ) ; diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 0ac2fa608e..69d07a07f1 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -3,6 +3,29 @@ system ; IN: unix.types TYPEDEF: void* caddr_t +TYPEDEF: uint in_addr_t +TYPEDEF: uint socklen_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: 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 + os { { linux [ "unix.types.linux" require ] } diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index facfa4b9d4..960115d1a6 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -7,10 +7,6 @@ stack-checker macros locals generalizations unix.types debugger io prettyprint ; IN: unix -TYPEDEF: uint in_addr_t -TYPEDEF: uint socklen_t -TYPEDEF: int int32_t - : PROT_NONE 0 ; inline : PROT_READ 1 ; inline : PROT_WRITE 2 ; inline From 5916fcea75cc23f62cd0c6868803d315cdabafe0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 19:25:05 -0500 Subject: [PATCH 063/224] initial comit of groups, users, and utmpx --- basis/unix/groups/authors.txt | 1 + basis/unix/groups/groups.factor | 123 ++++++++++++++++++++ basis/unix/groups/tags.txt | 1 + basis/unix/users/authors.txt | 1 + basis/unix/users/bsd/authors.txt | 1 + basis/unix/users/bsd/bsd.factor | 19 +++ basis/unix/users/bsd/tags.txt | 1 + basis/unix/users/tags.txt | 1 + basis/unix/users/users.factor | 114 ++++++++++++++++++ basis/unix/utmpx/authors.txt | 1 + basis/unix/utmpx/macosx/authors.txt | 1 + basis/unix/utmpx/macosx/macosx-tests.factor | 4 + basis/unix/utmpx/macosx/macosx.factor | 6 + basis/unix/utmpx/macosx/tags.txt | 1 + basis/unix/utmpx/netbsd/authors.txt | 1 + basis/unix/utmpx/netbsd/netbsd-tests.factor | 4 + basis/unix/utmpx/netbsd/netbsd.factor | 22 ++++ basis/unix/utmpx/netbsd/tags.txt | 1 + basis/unix/utmpx/tags.txt | 1 + basis/unix/utmpx/utmpx.factor | 66 +++++++++++ 20 files changed, 370 insertions(+) create mode 100644 basis/unix/groups/authors.txt create mode 100644 basis/unix/groups/groups.factor create mode 100644 basis/unix/groups/tags.txt create mode 100644 basis/unix/users/authors.txt create mode 100644 basis/unix/users/bsd/authors.txt create mode 100644 basis/unix/users/bsd/bsd.factor create mode 100644 basis/unix/users/bsd/tags.txt create mode 100644 basis/unix/users/tags.txt create mode 100644 basis/unix/users/users.factor create mode 100644 basis/unix/utmpx/authors.txt create mode 100644 basis/unix/utmpx/macosx/authors.txt create mode 100644 basis/unix/utmpx/macosx/macosx-tests.factor create mode 100644 basis/unix/utmpx/macosx/macosx.factor create mode 100644 basis/unix/utmpx/macosx/tags.txt create mode 100644 basis/unix/utmpx/netbsd/authors.txt create mode 100644 basis/unix/utmpx/netbsd/netbsd-tests.factor create mode 100644 basis/unix/utmpx/netbsd/netbsd.factor create mode 100644 basis/unix/utmpx/netbsd/tags.txt create mode 100644 basis/unix/utmpx/tags.txt create mode 100644 basis/unix/utmpx/utmpx.factor diff --git a/basis/unix/groups/authors.txt b/basis/unix/groups/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/unix/groups/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor new file mode 100644 index 0000000000..5a33bfe072 --- /dev/null +++ b/basis/unix/groups/groups.factor @@ -0,0 +1,123 @@ +! 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 ; +IN: unix.groups + +QUALIFIED: grouping + +TUPLE: group id name passwd members ; + +SYMBOL: group-cache + +GENERIC: group-struct ( obj -- group ) + +string + [ alien-address "char**" heap-size + ] dip + ] [ ] produce nip ; + +: (group-struct) ( id -- group-struct id group-struct byte-array length void* ) + "group" tuck 1024 + [ ] keep f ; + +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 ; + +groups ( byte-array n -- groups ) + [ 4 grouping:group ] dip head-slice [ *uint group-name ] map ; + +PRIVATE> + +: user-groups ( string -- seq ) + #! first group is -1337, legacy unix code + -1337 NGROUPS_MAX [ 4 * ] keep + [ getgrouplist io-error ] 2keep + [ 4 tail-slice ] [ *int 1- ] bi* >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 + + + +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) ; diff --git a/basis/unix/groups/tags.txt b/basis/unix/groups/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/groups/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/users/authors.txt b/basis/unix/users/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/unix/users/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/unix/users/bsd/authors.txt b/basis/unix/users/bsd/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/unix/users/bsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/unix/users/bsd/bsd.factor b/basis/unix/users/bsd/bsd.factor new file mode 100644 index 0000000000..b3778ced70 --- /dev/null +++ b/basis/unix/users/bsd/bsd.factor @@ -0,0 +1,19 @@ +! 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 ; diff --git a/basis/unix/users/bsd/tags.txt b/basis/unix/users/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/users/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/users/tags.txt b/basis/unix/users/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/users/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor new file mode 100644 index 0000000000..184312e0ce --- /dev/null +++ b/basis/unix/users/users.factor @@ -0,0 +1,114 @@ +! 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 ) + +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>> ; + +: username-id ( string -- id ) + user-passwd username>> ; + +: real-username-id ( -- string ) + getuid ; inline + +: real-username ( -- string ) + real-username-id username ; inline + +: effective-username-id ( -- string ) + geteuid username ; inline + +: effective-username ( -- string ) + effective-username-id username ; inline + +GENERIC: set-real-username ( string/id -- ) + +GENERIC: set-effective-username ( string/id -- ) + +: with-real-username ( string/id quot -- ) + '[ _ set-real-username @ ] + real-username-id '[ _ set-real-username ] + [ ] cleanup ; inline + +: with-effective-username ( string/id quot -- ) + '[ _ set-effective-username @ ] + effective-username-id '[ _ set-effective-username ] + [ ] cleanup ; inline + + + +M: string set-real-username ( string -- ) + username-id (set-real-username) ; + +M: integer set-real-username ( id -- ) + (set-real-username) ; + +M: integer set-effective-username ( id -- ) + (set-effective-username) ; + +M: string set-effective-username ( string -- ) + username-id (set-effective-username) ; + +os { + { [ dup bsd? ] [ drop "unix.users.bsd" require ] } + { [ dup linux? ] [ drop ] } +} cond diff --git a/basis/unix/utmpx/authors.txt b/basis/unix/utmpx/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/unix/utmpx/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/unix/utmpx/macosx/authors.txt b/basis/unix/utmpx/macosx/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/utmpx/macosx/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/utmpx/macosx/macosx-tests.factor b/basis/unix/utmpx/macosx/macosx-tests.factor new file mode 100644 index 0000000000..b0aa97dbca --- /dev/null +++ b/basis/unix/utmpx/macosx/macosx-tests.factor @@ -0,0 +1,4 @@ +! 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 diff --git a/basis/unix/utmpx/macosx/macosx.factor b/basis/unix/utmpx/macosx/macosx.factor new file mode 100644 index 0000000000..92a0d9e3a4 --- /dev/null +++ b/basis/unix/utmpx/macosx/macosx.factor @@ -0,0 +1,6 @@ +! 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 diff --git a/basis/unix/utmpx/macosx/tags.txt b/basis/unix/utmpx/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/utmpx/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/utmpx/netbsd/authors.txt b/basis/unix/utmpx/netbsd/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/utmpx/netbsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/utmpx/netbsd/netbsd-tests.factor b/basis/unix/utmpx/netbsd/netbsd-tests.factor new file mode 100644 index 0000000000..5bd0e4622f --- /dev/null +++ b/basis/unix/utmpx/netbsd/netbsd-tests.factor @@ -0,0 +1,4 @@ +! 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 diff --git a/basis/unix/utmpx/netbsd/netbsd.factor b/basis/unix/utmpx/netbsd/netbsd.factor new file mode 100644 index 0000000000..40fce746b1 --- /dev/null +++ b/basis/unix/utmpx/netbsd/netbsd.factor @@ -0,0 +1,22 @@ +! 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 ; diff --git a/basis/unix/utmpx/netbsd/tags.txt b/basis/unix/utmpx/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/utmpx/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/utmpx/tags.txt b/basis/unix/utmpx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/utmpx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/utmpx/utmpx.factor b/basis/unix/utmpx/utmpx.factor new file mode 100644 index 0000000000..e1756daa00 --- /dev/null +++ b/basis/unix/utmpx/utmpx.factor @@ -0,0 +1,66 @@ +! 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 From 5afbade0a54a6dd5f753ffd413d8b0436e85630f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 19:25:22 -0500 Subject: [PATCH 064/224] setting permissions, file times --- basis/io/unix/files/files.factor | 102 ++++++++++++++++++++++++++++++- 1 file changed, 99 insertions(+), 3 deletions(-) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 6ddb74f4a3..ba8f51da4c 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -1,11 +1,11 @@ -! 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 vocabs.loader calendar.unix ; - +io.files.private destructors vocabs.loader calendar.unix +unix.stat alien.c-types arrays unix.users unix.groups ; IN: io.unix.files M: unix cwd ( -- path ) @@ -136,3 +136,99 @@ os { { freebsd [ "io.unix.files.bsd" require ] } { linux [ ] } } case + + + +: set-uid? ( path -- ? ) UID file-mode? ; +: set-gid? ( path -- ? ) GID file-mode? ; +: set-sticky? ( path -- ? ) STICKY file-mode? ; +: user-read? ( path -- ? ) USER-READ file-mode? ; +: user-write? ( path -- ? ) USER-WRITE file-mode? ; +: user-execute? ( path -- ? ) USER-EXECUTE file-mode? ; +: group-read? ( path -- ? ) GROUP-READ file-mode? ; +: group-write? ( path -- ? ) GROUP-WRITE file-mode? ; +: group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ; +: other-read? ( path -- ? ) OTHER-READ file-mode? ; +: other-write? ( path -- ? ) OTHER-WRITE file-mode? ; +: 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 octal-n -- ) + [ normalize-path ] dip chmod io-error ; + + ] 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-write-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-username ( path string/id -- ) + +GENERIC: set-file-group ( path string/id -- ) + +M: integer set-file-username ( path uid -- ) + f set-file-ids ; + +M: string set-file-username ( path string -- ) + username-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-uid ( path -- uid ) normalize-path file-info uid>> ; + +: file-user-name ( path -- string ) file-uid username ; + +: file-gid ( path -- gid ) normalize-path file-info gid>> ; + +: file-group ( path -- string ) file-gid group-name ; From fb23eca0d93df5689faa5e7f57f094d2eef5ffdd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:03:55 -0500 Subject: [PATCH 065/224] move file flags to io.unix.files, change some word names for consistency --- basis/io/unix/files/files.factor | 39 +++++++++++++++++++++++++------- basis/unix/stat/stat.factor | 14 ------------ 2 files changed, 31 insertions(+), 22 deletions(-) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index ba8f51da4c..49510f9841 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -150,9 +150,25 @@ os { PRIVATE> -: set-uid? ( path -- ? ) UID file-mode? ; -: set-gid? ( path -- ? ) GID file-mode? ; -: set-sticky? ( path -- ? ) STICKY file-mode? ; +: UID OCT: 0004000 ; inline +: GID OCT: 0002000 ; inline +: STICKY OCT: 0001000 ; inline +: USER-ALL OCT: 0000700 ; inline +: USER-READ OCT: 0000400 ; inline +: USER-WRITE OCT: 0000200 ; inline +: USER-EXECUTE OCT: 0000100 ; inline +: GROUP-ALL OCT: 0000070 ; inline +: GROUP-READ OCT: 0000040 ; inline +: GROUP-WRITE OCT: 0000020 ; inline +: GROUP-EXECUTE OCT: 0000010 ; inline +: OTHER-ALL OCT: 0000007 ; inline +: OTHER-READ OCT: 0000004 ; inline +: OTHER-WRITE OCT: 0000002 ; inline +: OTHER-EXECUTE OCT: 0000001 ; inline + +: uid? ( path -- ? ) UID file-mode? ; +: gid? ( path -- ? ) GID file-mode? ; +: sticky? ( path -- ? ) STICKY file-mode? ; : user-read? ( path -- ? ) USER-READ file-mode? ; : user-write? ( path -- ? ) USER-WRITE file-mode? ; : user-execute? ( path -- ? ) USER-EXECUTE file-mode? ; @@ -176,9 +192,12 @@ PRIVATE> : set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ; : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ; -: set-file-permissions ( path octal-n -- ) +: set-file-permissions ( path n -- ) [ normalize-path ] dip chmod io-error ; +: file-permissions ( path -- n ) + normalize-path file-info permissions>> ; + > ; +: file-username-id ( path -- uid ) + normalize-path file-info uid>> ; -: file-user-name ( path -- string ) file-uid username ; +: file-username ( path -- string ) + file-username-id username ; -: file-gid ( path -- gid ) normalize-path file-info gid>> ; +: file-group-id ( path -- gid ) + normalize-path file-info gid>> ; -: file-group ( path -- string ) file-gid group-name ; +: file-group-name ( path -- string ) + file-group-id group-name ; diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index 139f1b1983..46fe7d98f9 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -14,20 +14,6 @@ IN: unix.stat : S_IFLNK OCT: 120000 ; inline ! Symbolic link. : S_IFSOCK OCT: 140000 ; inline ! Socket. -! File Access Permissions -: UID OCT: 0004000 ; inline -: GID OCT: 0002000 ; inline -: STICKY OCT: 0001000 ; inline -: USER-READ OCT: 0000400 ; inline ! r owner -: USER-WRITE OCT: 0000200 ; inline ! w owner -: USER-EXECUTE OCT: 0000100 ; inline ! x owner -: GROUP-READ OCT: 0000040 ; inline ! r group -: GROUP-WRITE OCT: 0000020 ; inline ! w group -: GROUP-EXECUTE OCT: 0000010 ; inline ! x group -: OTHER-READ OCT: 0000004 ; inline ! r other -: OTHER-WRITE OCT: 0000002 ; inline ! w other -: OTHER-EXECUTE 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 ) ; From 0f891e002bd3801434a7c300af55409d29e1ae60 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:04:23 -0500 Subject: [PATCH 066/224] add io.unix.files docs --- basis/io/unix/files/files-docs.factor | 277 ++++++++++++++++++++++++++ 1 file changed, 277 insertions(+) create mode 100644 basis/io/unix/files/files-docs.factor diff --git a/basis/io/unix/files/files-docs.factor b/basis/io/unix/files/files-docs.factor new file mode 100644 index 0000000000..7b4ce10b86 --- /dev/null +++ b/basis/io/unix/files/files-docs.factor @@ -0,0 +1,277 @@ +! 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-username-id +{ $values + { "path" "a pathname string" } + { "uid" integer } } +{ $description "Returns the user id for a given file." } ; + +HELP: group-execute? +{ $values + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file." } ; + +HELP: group-read? +{ $values + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file." } ; + +HELP: group-write? +{ $values + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file." } ; + +HELP: other-execute? +{ $values + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file." } ; + +HELP: other-read? +{ $values + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file." } ; + +HELP: other-write? +{ $values + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file." } ; + +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-username +{ $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-write-time +{ $values + { "path" "a pathname string" } { "timestamp" timestamp } } +{ $description "Sets a file's last 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 + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file." } ; + +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 + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "sticky" } " bit of a file is set." } ; + +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 + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "uid" } " bit of a file is set." } ; + +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 + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file." } ; + +HELP: user-read? +{ $values + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file." } ; + +HELP: user-write? +{ $values + { "path" "a pathname string" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file." } ; + +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 write time:" +{ $subsection set-file-write-time } ; + + +ARTICLE: "unix-file-ids" "Unix file user and group ids" +"Reading file user data:" +{ $subsection file-username-id } +{ $subsection file-username } +"Setting file user data:" +{ $subsection set-file-username } +"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" From 65b891a687cd0558b53cd6ee14d4b835c1e0dcd5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:05:00 -0500 Subject: [PATCH 067/224] document unix.users --- basis/unix/users/users-docs.factor | 120 +++++++++++++++++++++++++++++ basis/unix/users/users.factor | 4 +- 2 files changed, 122 insertions(+), 2 deletions(-) create mode 100644 basis/unix/users/users-docs.factor diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor new file mode 100644 index 0000000000..caa938f047 --- /dev/null +++ b/basis/unix/users/users-docs.factor @@ -0,0 +1,120 @@ +! 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-username-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-username-id +{ $values + + { "id" integer } } +{ $description "The real user id of the current user." } ; + +HELP: set-effective-username +{ $values + { "string/id" "a string or a user id" } } +{ $description "Sets the current effective username." } ; + +HELP: set-real-username +{ $values + { "string/id" "a string or a user id" } } +{ $description "Sets the current real username." } ; + +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: username-id +{ $values + { "string" string } + { "id" integer } } +{ $description "Returns the user id associated with the username." } ; + +HELP: with-effective-username +{ $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-username +{ $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-username-id set-real-username + effective-username effective-username-id + set-effective-username +} 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-username-id } +{ $subsection set-real-username } +"Effective user:" +{ $subsection effective-username } +{ $subsection effective-username-id } +{ $subsection set-effective-username } +"Combinators to change users:" +{ $subsection with-real-username } +{ $subsection with-effective-username } ; + +ABOUT: "unix.users" diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 184312e0ce..1b2e414a88 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -60,13 +60,13 @@ M: string user-passwd ( string -- passwd/f ) : username-id ( string -- id ) user-passwd username>> ; -: real-username-id ( -- string ) +: real-username-id ( -- id ) getuid ; inline : real-username ( -- string ) real-username-id username ; inline -: effective-username-id ( -- string ) +: effective-username-id ( -- id ) geteuid username ; inline : effective-username ( -- string ) From 1ba5b448d7654b737d9c19bfa7e4457c53ae91ec Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:05:16 -0500 Subject: [PATCH 068/224] document unix.groups --- basis/unix/groups/groups-docs.factor | 108 +++++++++++++++++++++++++++ basis/unix/groups/groups.factor | 17 ++++- 2 files changed, 121 insertions(+), 4 deletions(-) create mode 100644 basis/unix/groups/groups-docs.factor diff --git a/basis/unix/groups/groups-docs.factor b/basis/unix/groups/groups-docs.factor new file mode 100644 index 0000000000..ef2631ae3f --- /dev/null +++ b/basis/unix/groups/groups-docs.factor @@ -0,0 +1,108 @@ +! 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" diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 5a33bfe072..7f3aa9ae98 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -3,7 +3,8 @@ 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 ; +accessors math.parser fry assocs namespaces continuations +unix.users ; IN: unix.groups QUALIFIED: grouping @@ -61,14 +62,22 @@ PRIVATE> : >groups ( byte-array n -- groups ) [ 4 grouping:group ] dip head-slice [ *uint group-name ] map ; -PRIVATE> - -: user-groups ( string -- seq ) +: (user-groups) ( string -- seq ) #! first group is -1337, legacy unix code -1337 NGROUPS_MAX [ 4 * ] keep [ 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 ; From e7e0e7ad695ead652cd4fb68589411e6081cc208 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:13:25 -0500 Subject: [PATCH 069/224] fix bugs in unix.users found by adding unit tests. oops --- basis/unix/users/users.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 1b2e414a88..9545a2c5c6 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -58,7 +58,7 @@ M: string user-passwd ( string -- passwd/f ) user-passwd username>> ; : username-id ( string -- id ) - user-passwd username>> ; + user-passwd uid>> ; : real-username-id ( -- id ) getuid ; inline @@ -67,7 +67,7 @@ M: string user-passwd ( string -- passwd/f ) real-username-id username ; inline : effective-username-id ( -- id ) - geteuid username ; inline + geteuid ; inline : effective-username ( -- string ) effective-username-id username ; inline From f026177e2730d95e07afa95b282bea77d3970862 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:22:53 -0500 Subject: [PATCH 070/224] add users tests, fix naming inconsistencies --- basis/unix/users/users-docs.factor | 36 +++++++++++----------- basis/unix/users/users-tests.factor | 24 +++++++++++++++ basis/unix/users/users.factor | 46 ++++++++++++++--------------- 3 files changed, 65 insertions(+), 41 deletions(-) create mode 100644 basis/unix/users/users-tests.factor diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor index caa938f047..f8586ffc35 100644 --- a/basis/unix/users/users-docs.factor +++ b/basis/unix/users/users-docs.factor @@ -15,7 +15,7 @@ HELP: effective-username { "string" string } } { $description "Returns the effective username for the current user." } ; -HELP: effective-username-id +HELP: effective-user-id { $values { "id" integer } } @@ -45,21 +45,21 @@ HELP: real-username { "string" string } } { $description "The real username of the current user." } ; -HELP: real-username-id +HELP: real-user-id { $values { "id" integer } } { $description "The real user id of the current user." } ; -HELP: set-effective-username +HELP: set-effective-user { $values { "string/id" "a string or a user id" } } -{ $description "Sets the current effective username." } ; +{ $description "Sets the current effective user given a username or a user id." } ; -HELP: set-real-username +HELP: set-real-user { $values { "string/id" "a string or a user id" } } -{ $description "Sets the current real username." } ; +{ $description "Sets the current real user given a username or a user id." } ; HELP: user-passwd { $values @@ -73,13 +73,13 @@ HELP: username { "string" string } } { $description "Returns the username associated with the user id." } ; -HELP: username-id +HELP: user-id { $values { "string" string } { "id" integer } } { $description "Returns the user id associated with the username." } ; -HELP: with-effective-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." } ; @@ -89,15 +89,15 @@ HELP: with-passwd-cache { "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-username +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-username-id set-real-username - effective-username effective-username-id - set-effective-username + real-username real-user-id set-real-user + effective-username effective-user-id + set-effective-user } related-words ARTICLE: "unix.users" "unix.users" @@ -107,14 +107,14 @@ ARTICLE: "unix.users" "unix.users" "Returning a passwd tuple:" "Real user:" { $subsection real-username } -{ $subsection real-username-id } -{ $subsection set-real-username } +{ $subsection real-user-id } +{ $subsection set-real-user } "Effective user:" { $subsection effective-username } -{ $subsection effective-username-id } -{ $subsection set-effective-username } +{ $subsection effective-user-id } +{ $subsection set-effective-user } "Combinators to change users:" -{ $subsection with-real-username } -{ $subsection with-effective-username } ; +{ $subsection with-real-user } +{ $subsection with-effective-user } ; ABOUT: "unix.users" diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor new file mode 100644 index 0000000000..a85c322aca --- /dev/null +++ b/basis/unix/users/users-tests.factor @@ -0,0 +1,24 @@ +! 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 diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 9545a2c5c6..eac771160b 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -57,56 +57,56 @@ M: string user-passwd ( string -- passwd/f ) : username ( id -- string ) user-passwd username>> ; -: username-id ( string -- id ) +: user-id ( string -- id ) user-passwd uid>> ; -: real-username-id ( -- id ) +: real-user-id ( -- id ) getuid ; inline : real-username ( -- string ) - real-username-id username ; inline + real-user-id username ; inline -: effective-username-id ( -- id ) +: effective-user-id ( -- id ) geteuid ; inline : effective-username ( -- string ) - effective-username-id username ; inline + effective-user-id username ; inline -GENERIC: set-real-username ( string/id -- ) +GENERIC: set-real-user ( string/id -- ) -GENERIC: set-effective-username ( string/id -- ) +GENERIC: set-effective-user ( string/id -- ) -: with-real-username ( string/id quot -- ) - '[ _ set-real-username @ ] - real-username-id '[ _ set-real-username ] +: with-real-user ( string/id quot -- ) + '[ _ set-real-user @ ] + real-user-id '[ _ set-real-user ] [ ] cleanup ; inline -: with-effective-username ( string/id quot -- ) - '[ _ set-effective-username @ ] - effective-username-id '[ _ set-effective-username ] +: with-effective-user ( string/id quot -- ) + '[ _ set-effective-user @ ] + effective-user-id '[ _ set-effective-user ] [ ] cleanup ; inline -M: string set-real-username ( string -- ) - username-id (set-real-username) ; +M: string set-real-user ( string -- ) + user-id (set-real-user) ; -M: integer set-real-username ( id -- ) - (set-real-username) ; +M: integer set-real-user ( id -- ) + (set-real-user) ; -M: integer set-effective-username ( id -- ) - (set-effective-username) ; +M: integer set-effective-user ( id -- ) + (set-effective-user) ; -M: string set-effective-username ( string -- ) - username-id (set-effective-username) ; +M: string set-effective-user ( string -- ) + user-id (set-effective-user) ; os { { [ dup bsd? ] [ drop "unix.users.bsd" require ] } From e0ad27401e3f874fda887adbfa003b29e0e9bafb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:23:23 -0500 Subject: [PATCH 071/224] add groups tests --- basis/unix/groups/groups-tests.factor | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 basis/unix/groups/groups-tests.factor diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor new file mode 100644 index 0000000000..0fdd6ff08d --- /dev/null +++ b/basis/unix/groups/groups-tests.factor @@ -0,0 +1,24 @@ +! 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 From 402126d0389fa528e3098e2f47b4defa51ec6828 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:26:43 -0500 Subject: [PATCH 072/224] fix spacing --- basis/unix/groups/groups-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 0fdd6ff08d..9e7122fc34 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test unix.groups kernel strings math ; +USING: tools.test unix.groups kernel strings math ; IN: unix.groups.tests From e464941d5281481fd48affaab0dd4836b8537eb0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:18:50 -0500 Subject: [PATCH 073/224] rename words for consistency, update docs, add unit tests --- basis/io/unix/files/files-docs.factor | 16 ++-- basis/io/unix/files/files-tests.factor | 110 ++++++++++++++++++++++++- basis/io/unix/files/files.factor | 16 ++-- 3 files changed, 125 insertions(+), 17 deletions(-) diff --git a/basis/io/unix/files/files-docs.factor b/basis/io/unix/files/files-docs.factor index 7b4ce10b86..5b5e257c5e 100644 --- a/basis/io/unix/files/files-docs.factor +++ b/basis/io/unix/files/files-docs.factor @@ -28,7 +28,7 @@ HELP: file-username { "string" string } } { $description "Returns the username for a given file." } ; -HELP: file-username-id +HELP: file-user-id { $values { "path" "a pathname string" } { "uid" integer } } @@ -107,15 +107,15 @@ HELP: set-file-times { "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-username +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-write-time +HELP: set-file-modified-time { $values { "path" "a pathname string" } { "timestamp" timestamp } } -{ $description "Sets a file's last write timestamp." } ; +{ $description "Sets a file's last modified timestamp, or write timestamp." } ; HELP: set-gid { $values @@ -251,16 +251,16 @@ ARTICLE: "unix-file-timestamps" "Unix file timestamps" { $subsection set-file-times } "Setting just the last access time:" { $subsection set-file-access-time } -"Setting just the last write time:" -{ $subsection set-file-write-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-username-id } +{ $subsection file-user-id } { $subsection file-username } "Setting file user data:" -{ $subsection set-file-username } +{ $subsection set-file-user } "Reading file group data:" { $subsection file-group-id } { $subsection file-group-name } diff --git a/basis/io/unix/files/files-tests.factor b/basis/io/unix/files/files-tests.factor index 040b191d27..28c25c0964 100644 --- a/basis/io/unix/files/files-tests.factor +++ b/basis/io/unix/files/files-tests.factor @@ -1,4 +1,6 @@ -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 @@ -27,3 +29,109 @@ IN: io.unix.files.tests [ "/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 + +[ t ] +[ test-file f set-other-write perms OCT: 774 = ] unit-test + +[ t ] +[ test-file f set-other-read perms OCT: 770 = ] unit-test + +[ t ] +[ test-file f set-group-execute perms OCT: 760 = ] unit-test + +[ t ] +[ test-file f set-group-write perms OCT: 740 = ] unit-test + +[ t ] +[ test-file f set-group-read perms OCT: 700 = ] unit-test + +[ t ] +[ test-file f set-user-execute perms OCT: 600 = ] unit-test + +[ t ] +[ test-file f set-user-write perms OCT: 400 = ] unit-test + +[ t ] +[ test-file f set-user-read perms OCT: 000 = ] 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* = +] unit-test + +[ t ] +[ + test-file now + [ set-file-modified-time ] 2keep + [ file-info modified>> ] + [ [ truncate >integer ] change-second ] 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 diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 49510f9841..40ef9ad859 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -144,7 +144,7 @@ os { : chmod-set-bit ( path mask ? -- ) [ dup stat-mode ] 2dip - [ set-bit ] [ clear-bit ] if chmod io-error ; + [ bitor ] [ unmask ] if chmod io-error ; : file-mode? ( path mask -- ? ) [ stat-mode ] dip mask? ; @@ -220,22 +220,22 @@ PRIVATE> : set-file-access-time ( path timestamp -- ) f 2array set-file-times ; -: set-file-write-time ( path timestamp -- ) +: 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-username ( path string/id -- ) +GENERIC: set-file-user ( path string/id -- ) GENERIC: set-file-group ( path string/id -- ) -M: integer set-file-username ( path uid -- ) +M: integer set-file-user ( path uid -- ) f set-file-ids ; -M: string set-file-username ( path string -- ) - username-id 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 ; @@ -244,11 +244,11 @@ M: string set-file-group ( path string -- ) group-id f swap set-file-ids ; -: file-username-id ( path -- uid ) +: file-user-id ( path -- uid ) normalize-path file-info uid>> ; : file-username ( path -- string ) - file-username-id username ; + file-user-id username ; : file-group-id ( path -- gid ) normalize-path file-info gid>> ; From 5b86d3a51e5b3cc4e3b2428359ca8e07acfe99c9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:40:19 -0500 Subject: [PATCH 074/224] mac bootstrap --- basis/unix/bsd/macosx/macosx.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index ed2bdecf61..c41ae6df7d 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax unix.time ; IN: unix : FD_SETSIZE 1024 ; inline From a78636024ca2eec808e8a97562d113ebddde25b8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:57:53 -0500 Subject: [PATCH 075/224] don't define structs in the same file as the constants --- basis/unix/bsd/netbsd/structs/structs.factor | 29 ++++++++++++++++++++ basis/unix/bsd/netbsd/structs/tags.txt | 1 + 2 files changed, 30 insertions(+) create mode 100644 basis/unix/bsd/netbsd/structs/structs.factor create mode 100644 basis/unix/bsd/netbsd/structs/tags.txt diff --git a/basis/unix/bsd/netbsd/structs/structs.factor b/basis/unix/bsd/netbsd/structs/structs.factor new file mode 100644 index 0000000000..f1a5ed09c0 --- /dev/null +++ b/basis/unix/bsd/netbsd/structs/structs.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax vocabs.loader ; +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" } ; + diff --git a/basis/unix/bsd/netbsd/structs/tags.txt b/basis/unix/bsd/netbsd/structs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/bsd/netbsd/structs/tags.txt @@ -0,0 +1 @@ +unportable From 8627a30b6c4be00f34f3497c874693e01c0fcf97 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:58:16 -0500 Subject: [PATCH 076/224] remove old structs --- basis/unix/bsd/netbsd/netbsd.factor | 24 +----------------------- 1 file changed, 1 insertion(+), 23 deletions(-) diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index 6bae953938..c82259d48a 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -131,26 +131,4 @@ TYPEDEF: __uint8_t sa_family_t : _SS_PAD2SIZE ( -- n ) _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline -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" } ; +"unix.bsd.netbsd.structs" require From 967a8375ec93c310b7306494759435ce3a781e00 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:59:05 -0500 Subject: [PATCH 077/224] fix using --- basis/unix/bsd/netbsd/netbsd.factor | 2 +- basis/unix/bsd/netbsd/structs/structs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index c82259d48a..ca42b7840c 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax alien.c-types math ; +USING: alien.syntax alien.c-types math vocabs.loader ; IN: unix : FD_SETSIZE 256 ; inline diff --git a/basis/unix/bsd/netbsd/structs/structs.factor b/basis/unix/bsd/netbsd/structs/structs.factor index f1a5ed09c0..ced6f6df5d 100644 --- a/basis/unix/bsd/netbsd/structs/structs.factor +++ b/basis/unix/bsd/netbsd/structs/structs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax vocabs.loader ; +USING: alien.syntax ; IN: unix C-STRUCT: sockaddr_storage From b7095ff39ff5eafb0a2e149ffebb909bcb6fb18c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 15:14:08 -0500 Subject: [PATCH 078/224] fix using --- basis/unix/bsd/netbsd/structs/structs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/bsd/netbsd/structs/structs.factor b/basis/unix/bsd/netbsd/structs/structs.factor index ced6f6df5d..dba7590a93 100644 --- a/basis/unix/bsd/netbsd/structs/structs.factor +++ b/basis/unix/bsd/netbsd/structs/structs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax unix.time ; IN: unix C-STRUCT: sockaddr_storage From 031ebe98b1565f5cc9adbefb278d2bcdb4258531 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 15:57:47 -0500 Subject: [PATCH 079/224] largert group buffer, openbsd apparently keeps the microseconds in their file timestamps. fix unit tests for this --- basis/io/unix/files/files-tests.factor | 4 ++-- basis/unix/groups/groups.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/unix/files/files-tests.factor b/basis/io/unix/files/files-tests.factor index 28c25c0964..5a24c1314a 100644 --- a/basis/io/unix/files/files-tests.factor +++ b/basis/io/unix/files/files-tests.factor @@ -92,7 +92,7 @@ prepare-test-file test-file now [ set-file-access-time ] 2keep [ file-info accessed>> ] - [ [ truncate >integer ] change-second ] bi* = + [ [ [ truncate >integer ] change-second ] bi@ ] bi* = ] unit-test [ t ] @@ -100,7 +100,7 @@ prepare-test-file test-file now [ set-file-modified-time ] 2keep [ file-info modified>> ] - [ [ truncate >integer ] change-second ] bi* = + [ [ [ truncate >integer ] change-second ] bi@ ] bi* = ] unit-test [ t ] diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 7f3aa9ae98..c3af9cc83d 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -26,7 +26,7 @@ GENERIC: group-struct ( obj -- group ) ] [ ] produce nip ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) - "group" tuck 1024 + "group" tuck 4096 [ ] keep f ; M: integer group-struct ( id -- group ) From ea69c8996fe9f20f304b8b00af034c15f9f66773 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 19:06:19 -0500 Subject: [PATCH 080/224] use ERROR:, inline database combinator examples --- basis/db/db-docs.factor | 4 ++-- basis/db/sqlite/sqlite.factor | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 16a8228fca..7c84e6205e 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -285,7 +285,7 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators" { $code <" USING: db.sqlite db io.files ; : with-sqlite-db ( quot -- ) - "my-database.db" temp-file swap with-db ;"> } + "my-database.db" temp-file swap with-db ; inline"> } "PostgreSQL example combinator:" { $code <" USING: db.postgresql db ; @@ -296,7 +296,7 @@ USING: db.sqlite db io.files ; "erg" >>username "secrets?" >>password "factor-test" >>database - swap with-db ;"> + swap with-db ; inline"> } ; ABOUT: "db" diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 8580b9012c..4aa41483d8 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -87,9 +87,11 @@ M: sqlite-statement bind-tuple ( tuple 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 ; From d2dd7288b3a09fc2c9daae82725b6495bfcd4f3c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Oct 2008 23:43:37 -0500 Subject: [PATCH 081/224] Fix parser bug with multi-line tuple literals --- core/classes/tuple/parser/parser-tests.factor | 13 +++++++++++++ core/classes/tuple/parser/parser.factor | 1 + 2 files changed, 14 insertions(+) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 17376a594f..6b9a953ab9 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -96,3 +96,16 @@ TUPLE: syntax-test bar baz ; [ 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 diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index dd78b4ba3e..7888635641 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -86,6 +86,7 @@ ERROR: bad-literal-tuple ; : parse-tuple-literal ( -- tuple ) scan-word scan { + { f [ unexpected-eof ] } { "f" [ \ } parse-until boa>tuple ] } { "{" [ parse-slot-values assoc>tuple ] } { "}" [ new ] } From 6130aeb88f9a926786ab1419e8a4deebd8d7033b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Oct 2008 00:13:04 -0500 Subject: [PATCH 082/224] Fix fep looping --- vm/debug.c | 8 ++++++++ vm/debug.h | 2 ++ vm/errors.c | 6 +++--- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/vm/debug.c b/vm/debug.c index b374aceb9f..0869d6a885 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -325,6 +325,12 @@ void find_code_references(CELL look_for_) void factorbug(void) { + if(fep_disabled) + { + printf("Low level debugger disabled\n"); + exit(1); + } + open_console(); printf("Starting low level debugger...\n"); @@ -366,6 +372,8 @@ void factorbug(void) 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(); diff --git a/vm/debug.h b/vm/debug.h index 2ca6f8944c..547fdba436 100755 --- a/vm/debug.h +++ b/vm/debug.h @@ -4,4 +4,6 @@ void dump_generations(void); void factorbug(void); void dump_zone(F_ZONE *z); +bool fep_disabled; + DECLARE_PRIMITIVE(die); diff --git a/vm/errors.c b/vm/errors.c index f2147041a2..7a23e3e53f 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -57,10 +57,10 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) 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(); } } From bb6b99868607ada1b51a025238b7eae5843fc050 Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 9 Oct 2008 14:04:33 -0500 Subject: [PATCH 083/224] Fix alien-indirect on ppc --- basis/cpu/ppc/architecture/architecture.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 357349193e..117ab51fe2 100644 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -96,9 +96,9 @@ M: ppc %epilogue ( n -- ) 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 ; @@ -117,7 +117,7 @@ M: ppc %dispatch ( -- ) "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" } } } @@ -244,17 +244,17 @@ M: ppc %prepare-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 11 MR ; + 13 3 MR ; M: ppc %alien-indirect ( -- ) - (%call) ; + 13 (%call) ; M: ppc %callback-value ( ctype -- ) ! Save top of data stack From 7b9a3b61c35c78ba40794a5fac792934fc712293 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Oct 2008 14:07:11 -0500 Subject: [PATCH 084/224] partial fix for db, going to make it use dispose* soon --- basis/db/db.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/db/db.factor b/basis/db/db.factor index bf23005bc2..a124914a35 100644 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -6,6 +6,7 @@ tools.walker accessors combinators fry ; IN: db TUPLE: db + disposed handle insert-statements update-statements @@ -24,12 +25,10 @@ HOOK: db-close db ( handle -- ) : 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 + handle>> db-close ] with-variable ; TUPLE: result-set sql in-params out-params handle n max ; From 83f1634219f2a281a27d138466aa007313e6b89d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Oct 2008 15:42:23 -0500 Subject: [PATCH 085/224] clean up dispose a bit --- basis/db/db.factor | 6 +++--- basis/db/postgresql/postgresql.factor | 4 ++-- basis/db/sqlite/sqlite.factor | 1 - 3 files changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/db/db.factor b/basis/db/db.factor index a124914a35..3ee0fe3d09 100644 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -6,7 +6,6 @@ tools.walker accessors combinators fry ; IN: db TUPLE: db - disposed handle insert-statements update-statements @@ -23,12 +22,13 @@ HOOK: db-close db ( handle -- ) : dispose-statements ( assoc -- ) values dispose-each ; -: db-dispose ( db -- ) +M: db dispose ( db -- ) dup db [ [ dispose-statements H{ } clone ] change-insert-statements [ dispose-statements H{ } clone ] change-update-statements [ dispose-statements H{ } clone ] change-delete-statements - handle>> db-close + [ db-close f ] change-handle + drop ] with-variable ; TUPLE: result-set sql in-params out-params handle n max ; diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 08df25c13a..f9c9ea73ec 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -30,8 +30,8 @@ M: postgresql-db db-open ( db -- db ) [ 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 ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 4aa41483d8..216f324bbf 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -19,7 +19,6 @@ M: sqlite-db db-open ( db -- db ) dup path>> sqlite-open >>handle ; M: sqlite-db db-close ( handle -- ) sqlite-close ; -M: sqlite-db dispose ( db -- ) db-dispose ; TUPLE: sqlite-statement < statement ; From ace2ce2ce7a069f60239b346af0e4abc108dd88e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Oct 2008 16:40:19 -0500 Subject: [PATCH 086/224] remove old word --- basis/db/db-docs.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 7c84e6205e..52dc389fe6 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -26,10 +26,6 @@ HELP: dispose-statements { $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." } ; From 620f4e96a3338a4b61a6696979703afac7ac68a8 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Fri, 10 Oct 2008 16:48:07 +1100 Subject: [PATCH 087/224] Jamshred is working again, hopefully even less buggy than ever! --- extra/jamshred/game/game.factor | 2 +- extra/jamshred/gl/gl.factor | 3 ++- extra/jamshred/jamshred.factor | 4 ++-- extra/jamshred/player/player.factor | 28 ++++++++++++++++++++-------- extra/jamshred/sound/sound.factor | 2 ++ extra/jamshred/tunnel/tunnel.factor | 4 ++-- 6 files changed, 29 insertions(+), 14 deletions(-) diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index 938605ce9f..9cb5bc7c3a 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Alex Chapman +! 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 diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index 69af7ab986..6c553147a1 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -41,8 +41,9 @@ IN: jamshred.gl : 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>> gl-color segment-vertex-and-normal + over color>> set-color segment-vertex-and-normal gl-normal gl-vertex ; : draw-vertex-pair ( theta next-segment segment -- ) diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index aa9c164b8f..2357742fde 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -23,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) ] [ [ jamshred>> jamshred-update ] [ relayout-1 ] - [ yield jamshred-loop ] tri + [ 10 sleep yield jamshred-loop ] tri ] if ; : fullscreen ( gadget -- ) @@ -36,7 +36,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- ) [ fullscreen? not ] keep set-fullscreen* ; M: jamshred-gadget graft* ( gadget -- ) - [ jamshred-loop ] in-thread drop ; + [ jamshred-loop ] curry in-thread ; M: jamshred-gadget ungraft* ( gadget -- ) jamshred>> t swap (>>quit) ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 418847673b..72f26a2c79 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,9 +1,15 @@ ! 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 system ; +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 sounds tunnel nearest-segment last-move speed ; +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 ; @@ -11,7 +17,7 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : ( 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 ; + f f 0 default-speed player boa ; : turn-player ( player x-radians y-radians -- ) >r over r> left-pivot up-pivot ; @@ -69,6 +75,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; : 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 ; @@ -93,14 +102,17 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ; 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 ; +: 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 > [ - dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2 - move-toward-wall ?move-player-freely + ! 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 ; diff --git a/extra/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor index fd1b1127bd..c19c67671f 100644 --- a/extra/jamshred/sound/sound.factor +++ b/extra/jamshred/sound/sound.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Alex Chapman +! See http://factorcode.org/license.txt for BSD license. USING: accessors io.files kernel openal sequences ; IN: jamshred.sound diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 8d2cc8e766..7082acec47 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,6 +1,6 @@ ! 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 ; +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 @@ -13,7 +13,7 @@ C: segment [ number>> 1+ ] keep (>>number) ; : random-color ( -- color ) - { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ; + { 100 100 100 } [ random 100 / >float ] map first3 1.0 ; : tunnel-segment-distance ( -- n ) 0.4 ; : random-rotation-angle ( -- theta ) pi 20 / ; From f1286a353f1e24a8036628323a3e75ae2d4fcc32 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 10 Oct 2008 13:43:58 -0500 Subject: [PATCH 088/224] Fix typo --- core/alien/alien-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 814ca8613e..ce3497439a 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -302,8 +302,8 @@ ARTICLE: "embedding" "Embedding Factor into C applications" "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" } } From 2779103b63c5d596ceef6430796fe61b91d2bcec Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 10 Oct 2008 15:32:36 -0500 Subject: [PATCH 089/224] add on-update --- basis/db/postgresql/postgresql.factor | 1 + basis/db/sqlite/sqlite.factor | 1 + basis/db/types/types.factor | 4 ++-- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index f9c9ea73ec..2b4cadf489 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -230,6 +230,7 @@ M: postgresql-db persistent-table ( -- hashtable ) { +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" } } diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 216f324bbf..93135a23e3 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -178,6 +178,7 @@ M: sqlite-db persistent-table ( -- assoc ) { +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" } } diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index ac9e3397f8..ad9c9b0acf 100644 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -26,8 +26,8 @@ SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ; 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 From ad533918066481c633c2afbe84b3b5fbc3de8610 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 10 Oct 2008 20:52:28 -0500 Subject: [PATCH 090/224] make all types singletons instead of symbols, add NULL support for select statements --- basis/db/queries/queries.factor | 3 +++ basis/db/tuples/tuples-tests.factor | 7 ++++++- basis/db/types/types.factor | 2 +- 3 files changed, 10 insertions(+), 2 deletions(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 768ec70185..3cf4d98215 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -114,6 +114,9 @@ M: sequence where ( spec obj -- ) [ " 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# ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index f5569a97cd..192986484e 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -472,7 +472,12 @@ TUPLE: exam id name score ; 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 ; : ( m n o -- obj ) diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index ad9c9b0acf..6a889689ce 100644 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -91,7 +91,7 @@ ERROR: not-persistent class ; : 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 ; From 3161a85736c77f7d49f14d0fde67ec5cea1e57ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 11 Oct 2008 00:35:19 -0600 Subject: [PATCH 091/224] fix calculator --- extra/webapps/calculator/calculator.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/calculator/calculator.factor b/extra/webapps/calculator/calculator.factor index f1416fb02d..d19946d39b 100644 --- a/extra/webapps/calculator/calculator.factor +++ b/extra/webapps/calculator/calculator.factor @@ -33,7 +33,7 @@ TUPLE: calculator < dispatcher ; ! Deployment example USING: db.sqlite furnace.alloy namespaces http.server ; -: calculator-db ( -- params db ) "calculator.db" sqlite-db ; +: calculator-db ( -- db ) "calculator.db" ; : run-calculator ( -- ) From 3368866fc307616f529ced38971bbc4213fbad77 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 12 Oct 2008 07:25:03 -0600 Subject: [PATCH 092/224] fix counter --- extra/webapps/counter/counter.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index a5c9fbc6b9..d62096fffc 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -32,7 +32,7 @@ M: counter-app init-session* drop 0 count sset ; ! Deployment example USING: db.sqlite furnace.alloy namespaces ; -: counter-db ( -- params db ) "counter.db" sqlite-db ; +: counter-db ( -- db ) "counter.db" ; : run-counter ( -- ) From 72be15283234e99acea31c451d1ae8293a65ed06 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 12 Oct 2008 07:25:16 -0600 Subject: [PATCH 093/224] fix db tutorial --- basis/db/tuples/tuples-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index 02f5dfa38c..51830ee610 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -229,7 +229,7 @@ T{ book "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 _ with-db ] call ; [ book recreate-table From 78e747186a80198f6754b19e6bccd54e16169fd1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 13 Oct 2008 23:32:35 -0500 Subject: [PATCH 094/224] *** empty log message *** --- extra/dns/cache/rr/rr.factor | 68 ++++++++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) create mode 100644 extra/dns/cache/rr/rr.factor diff --git a/extra/dns/cache/rr/rr.factor b/extra/dns/cache/rr/rr.factor new file mode 100644 index 0000000000..b9c12786e2 --- /dev/null +++ b/extra/dns/cache/rr/rr.factor @@ -0,0 +1,68 @@ + +USING: kernel sequences assocs sets locals combinators + accessors system math math.functions unicode.case prettyprint + combinators.cleave dns ; + +IN: dns.cache.rr + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: time data ; + +: now ( -- seconds ) millis 1000.0 / round >integer ; + +: expired? ( -- ? ) 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 [ now ENT time>> - ] | + 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{ 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 + ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From fa41397a17235d7488e0db9bbc4f8a2a6a66b2d8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 15 Oct 2008 04:44:18 -0500 Subject: [PATCH 095/224] Add 'bind-in' vocabulary (the -> operator...) --- extra/bind-in/bind-in.factor | 12 ++++++++++++ extra/dns/cache/nx/nx.factor | 35 +++++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+) create mode 100644 extra/bind-in/bind-in.factor create mode 100644 extra/dns/cache/nx/nx.factor diff --git a/extra/bind-in/bind-in.factor b/extra/bind-in/bind-in.factor new file mode 100644 index 0000000000..ab6ff19094 --- /dev/null +++ b/extra/bind-in/bind-in.factor @@ -0,0 +1,12 @@ + +USING: kernel parser lexer locals.private ; + +IN: bind-in + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: -> + "[" parse-tokens make-locals dup push-locals + \ ] (parse-lambda) + parsed-lambda + \ call parsed ; parsing \ No newline at end of file diff --git a/extra/dns/cache/nx/nx.factor b/extra/dns/cache/nx/nx.factor new file mode 100644 index 0000000000..9904f857ba --- /dev/null +++ b/extra/dns/cache/nx/nx.factor @@ -0,0 +1,35 @@ + +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 ] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + From 4505ab4944753a70a8fda0f626605580c671b08b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 15 Oct 2008 04:45:01 -0500 Subject: [PATCH 096/224] dns.cache.rr: Separate cache just for the rr objects --- extra/dns/cache/rr/rr.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/extra/dns/cache/rr/rr.factor b/extra/dns/cache/rr/rr.factor index b9c12786e2..f3082b124c 100644 --- a/extra/dns/cache/rr/rr.factor +++ b/extra/dns/cache/rr/rr.factor @@ -62,7 +62,4 @@ TUPLE: time data ; { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] } } cond - ] ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - + ] ; \ No newline at end of file From 4b0b19e8e77ed885338f9005e01876822c297727 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 15 Oct 2008 12:04:32 -0500 Subject: [PATCH 097/224] remove a couple unused words --- extra/sequences/lib/lib.factor | 18 +++--------------- 1 file changed, 3 insertions(+), 15 deletions(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ed7f40598c..6fe3de4f03 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -4,7 +4,8 @@ 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 @@ -131,11 +132,6 @@ PRIVATE> : 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 ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : 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' ) - >alist ; +: enumerate ( seq -- seq' ) >alist ; From 225097a5d344a00017159cbe12a3da2b70819d06 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Oct 2008 16:54:07 -0500 Subject: [PATCH 098/224] Fix some bugs in locals --- basis/locals/locals-tests.factor | 70 ++++++++++++++++++++++----- basis/locals/locals.factor | 33 ++++++++++--- basis/macros/expander/expander.factor | 29 ++++++++--- core/combinators/combinators.factor | 21 ++++---- 4 files changed, 116 insertions(+), 37 deletions(-) diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index bc1e736b75..c449c26348 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -1,7 +1,7 @@ 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 ; @@ -305,17 +305,29 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; [ 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 @@ -333,6 +345,16 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { 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 ] } @@ -340,4 +362,30 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { +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 diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index bbcc8a6745..0fb8cefc48 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -35,11 +35,15 @@ C: wlet 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 ; : ( name -- word ) @@ -142,12 +146,12 @@ GENERIC: free-vars* ( form -- ) [ 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 ; @@ -195,6 +199,20 @@ M: block lambda-rewrite* swap point-free , ] keep length \ curry % ; +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 -- ) @@ -203,7 +221,8 @@ GENERIC: rewrite-element ( obj -- ) : 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 ; diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index d62c6bf466..c2fceffae6 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -1,14 +1,12 @@ ! 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' ) -> literal ; +: expand-dispatch? ( word -- ? ) + \ dispatch eq? stack get length 1 >= and ; + +: expand-dispatch ( -- ) + stack get pop end + [ [ expand-macros ] [ ] map-as '[ _ dip ] % ] + [ + length [ ] keep + [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch , + ] bi ; + : expand-macro ( quot -- ) stack [ swap with-datastack >vector ] change stack get pop >quotation end (expand-macros) ; @@ -38,8 +47,14 @@ M: wrapper expand-macros* wrapped>> literal ; 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 ; @@ -48,5 +63,3 @@ M: callable expand-macros* M: callable expand-macros ( quot -- quot' ) [ begin (expand-macros) end ] [ ] make ; - -PRIVATE> diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 4a362a7f9d..577dd153a1 100644 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -2,7 +2,7 @@ ! 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 @@ -116,17 +116,16 @@ ERROR: no-case ; ] [ 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 { From 58a44f12e52e18ae6693acfc21a2032a6b43eb93 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Oct 2008 16:54:45 -0500 Subject: [PATCH 099/224] Fix erg's MEMO:: bug --- basis/locals/locals.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 0fb8cefc48..89a5c02746 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -460,7 +460,7 @@ M: lambda-memoized definition "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>> From 3ca9fc926e485667f98cdadba3ac5d1ffdd92532 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Oct 2008 16:55:38 -0500 Subject: [PATCH 100/224] Consistent edit-hook variable access --- basis/editors/editors.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 90c40f9bd5..7dfceafe59 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -27,7 +27,8 @@ SYMBOL: edit-hook : 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* ; From 6e03452f7576bccbfefd83700c18d2cb09b60a22 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 18 Oct 2008 12:41:32 -0500 Subject: [PATCH 101/224] dns.cache.rr: remove lambda bug workaround --- extra/dns/cache/rr/rr.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/dns/cache/rr/rr.factor b/extra/dns/cache/rr/rr.factor index f3082b124c..77d787ff27 100644 --- a/extra/dns/cache/rr/rr.factor +++ b/extra/dns/cache/rr/rr.factor @@ -39,7 +39,7 @@ TUPLE: time data ; [let | NAME [ OBJ name>> ] TYPE [ OBJ type>> ] CLASS [ OBJ class>> ] - TTL [ now ENT time>> - ] | + TTL [ ENT time>> now - ] | ENT data>> [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ] map From 9f131b7e45ec95d9600e0dbf212c232c64652399 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 18 Oct 2008 12:54:05 -0500 Subject: [PATCH 102/224] dns.forwarding: Check in rewritten version --- extra/dns/forwarding/forwarding.factor | 167 ++++++++++++------------- 1 file changed, 82 insertions(+), 85 deletions(-) diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor index 87f9821153..d22de16eb5 100644 --- a/extra/dns/forwarding/forwarding.factor +++ b/extra/dns/forwarding/forwarding.factor @@ -1,105 +1,102 @@ -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 ; IN: dns.forwarding -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! DNS server - caching, forwarding ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: (socket) ( -- vec ) V{ f } ; - -: socket ( -- socket ) (socket) 1st ; - -: init-socket-on-port ( port -- ) - f swap 0 (socket) as-mutate ; - -: init-socket ( -- ) 53 init-socket-on-port ; +: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: (upstream-server) ( -- vec ) V{ f } ; +:: 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 ] | -: upstream-server ( -- ip ) (upstream-server) 1st ; + 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 + ] | -: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ; + RRS + [ RRS/CNAME RRS append ] + [ f ] + if + ] ] ] + ] + if + ] ] + ] + if + ] ; -: init-upstream-server ( -- ) - upstream-server not - [ resolv-conf-server set-upstream-server ] - when ; +:: 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 + ] + ] ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ; +: 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 ; + +: answer-from-server ( msg servers -- msg ) random ask-server cache-message ; + +:: find-answer ( MSG SERVERS -- msg ) + { [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: start-server ( ADDR-SPEC SERVERS -- ) + + [let | SOCKET [ ADDR-SPEC ] | -: 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 ; + forever -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: 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 ; - -MAIN: start \ No newline at end of file + ] ; From 17fc0bea22d848891a8a7ea19cd3f97ac791cfe0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 18 Oct 2008 12:55:01 -0500 Subject: [PATCH 103/224] dns.forwarding: move 'forever' to 'dns.util' --- extra/dns/forwarding/forwarding.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor index d22de16eb5..31037c477a 100644 --- a/extra/dns/forwarding/forwarding.factor +++ b/extra/dns/forwarding/forwarding.factor @@ -8,10 +8,6 @@ IN: dns.forwarding ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - :: query->rrs ( QUERY -- rrs/f ) [let | RRS [ QUERY cache-get ] | RRS From 969171012ced058fd3fdfb45b38030f68bac6c21 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 18 Oct 2008 12:55:36 -0500 Subject: [PATCH 104/224] dns.util: add 'forever' --- extra/dns/util/util.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 96cf6c0a1e..9ae7389940 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -28,3 +28,6 @@ TUPLE: packet data addr socket ; : respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file From 00adf0c6bfae8a9c0549d41b066b08c809b14075 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 18 Oct 2008 13:09:17 -0500 Subject: [PATCH 105/224] Remove 'dns.cache' (has been split into dns.cache.rr and dns.cache.nx) --- extra/dns/cache/cache.factor | 145 ----------------------------------- 1 file changed, 145 deletions(-) delete mode 100644 extra/dns/cache/cache.factor diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor deleted file mode 100644 index 5c4539b913..0000000000 --- a/extra/dns/cache/cache.factor +++ /dev/null @@ -1,145 +0,0 @@ - -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 ] } " " 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - From 93e84d7bcd02dfd082851796e9fe3bff463322a5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 15:15:27 -0500 Subject: [PATCH 106/224] fix some database issues - sqlite booleans, >>group and >>order don't require arrays now, they can be passed strings for a single order or group by --- basis/db/queries/queries.factor | 2 ++ basis/db/sqlite/lib/lib.factor | 29 +++++++++++++++++------------ basis/db/sqlite/sqlite.factor | 1 + 3 files changed, 20 insertions(+), 12 deletions(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 3cf4d98215..49de6ee5fc 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -166,9 +166,11 @@ M: db ( tuple class -- statement ) 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 -- ) diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor index 03f424e8d4..1ec18260cd 100644 --- a/basis/db/sqlite/lib/lib.factor +++ b/basis/db/sqlite/lib/lib.factor @@ -5,7 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators 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 ; @@ -79,6 +79,9 @@ ERROR: sqlite-sql-error < sql-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 ; @@ -88,14 +91,14 @@ ERROR: sqlite-sql-error < sql-error n string ; : 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 ] } @@ -104,10 +107,7 @@ ERROR: sqlite-sql-error < sql-error n string ; { 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 ] } @@ -115,6 +115,14 @@ ERROR: sqlite-sql-error < sql-error n string ; [ 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 -- ) @@ -141,6 +149,7 @@ ERROR: sqlite-sql-error < sql-error n string ; { 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 ] } @@ -150,11 +159,7 @@ ERROR: sqlite-sql-error < sql-error n string ; { 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 ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 93135a23e3..c22bb3a2d8 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -185,6 +185,7 @@ M: sqlite-db persistent-table ( -- assoc ) { +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 } } From fd889b3686f44b9d4b191e83cc6bacf34d76007e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 18 Oct 2008 16:18:31 -0500 Subject: [PATCH 107/224] dns.forwarding: Fix bug (cache-message crashes for nx names) --- extra/dns/forwarding/forwarding.factor | 29 +++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor index 31037c477a..6d4fece949 100644 --- a/extra/dns/forwarding/forwarding.factor +++ b/extra/dns/forwarding/forwarding.factor @@ -62,12 +62,35 @@ IN: dns.forwarding : 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 | NAME [ MSG message-query name>> ] - TTL [ MSG message-soa ttl>> ] | - NAME TTL cache-non-existent-name + [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 From 6aadd70623c510fa999602fd3f39019d0d9378fe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 17:29:38 -0500 Subject: [PATCH 108/224] user-read? is now generic, can take a filename or an integer from a stat struct --- basis/io/unix/files/files-docs.factor | 46 ++++++++++++------------ basis/io/unix/files/files-tests.factor | 26 ++++++++++++++ basis/io/unix/files/files.factor | 50 +++++++++++++++++++------- 3 files changed, 87 insertions(+), 35 deletions(-) diff --git a/basis/io/unix/files/files-docs.factor b/basis/io/unix/files/files-docs.factor index 5b5e257c5e..5649b56abd 100644 --- a/basis/io/unix/files/files-docs.factor +++ b/basis/io/unix/files/files-docs.factor @@ -36,39 +36,39 @@ HELP: file-user-id HELP: group-execute? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } { $description "Tests whether the " { $snippet "group execute" } " bit is set on a file." } ; HELP: group-read? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file." } ; +{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file or an integer." } ; HELP: group-write? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file." } ; +{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file or an integer." } ; HELP: other-execute? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file." } ; +{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file or an integer." } ; HELP: other-read? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file." } ; +{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file or an integer." } ; HELP: other-write? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file." } ; +{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file or an integer." } ; HELP: set-file-access-time { $values @@ -124,9 +124,9 @@ HELP: set-gid HELP: gid? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file." } ; +{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file or an integer." } ; HELP: set-group-execute { $values @@ -165,9 +165,9 @@ HELP: set-sticky HELP: sticky? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "sticky" } " bit of a file is set." } ; +{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file or an integer." } ; HELP: set-uid { $values @@ -176,9 +176,9 @@ HELP: set-uid HELP: uid? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "uid" } " bit of a file is set." } ; +{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file or an integer." } ; HELP: set-user-execute { $values @@ -197,21 +197,21 @@ HELP: set-user-write HELP: user-execute? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file." } ; +{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file or an integer." } ; HELP: user-read? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file." } ; +{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file or an integer." } ; HELP: user-write? { $values - { "path" "a pathname string" } + { "obj" "a pathname string or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file." } ; +{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file or an integer." } ; ARTICLE: "unix-file-permissions" "Unix file permissions" "Reading all file permissions:" diff --git a/basis/io/unix/files/files-tests.factor b/basis/io/unix/files/files-tests.factor index 5a24c1314a..21a4d18759 100644 --- a/basis/io/unix/files/files-tests.factor +++ b/basis/io/unix/files/files-tests.factor @@ -135,3 +135,29 @@ prepare-test-file [ ] [ 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 diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 40ef9ad859..b5fa7783d0 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -166,18 +166,44 @@ PRIVATE> : OTHER-WRITE OCT: 0000002 ; inline : OTHER-EXECUTE OCT: 0000001 ; inline -: uid? ( path -- ? ) UID file-mode? ; -: gid? ( path -- ? ) GID file-mode? ; -: sticky? ( path -- ? ) STICKY file-mode? ; -: user-read? ( path -- ? ) USER-READ file-mode? ; -: user-write? ( path -- ? ) USER-WRITE file-mode? ; -: user-execute? ( path -- ? ) USER-EXECUTE file-mode? ; -: group-read? ( path -- ? ) GROUP-READ file-mode? ; -: group-write? ( path -- ? ) GROUP-WRITE file-mode? ; -: group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ; -: other-read? ( path -- ? ) OTHER-READ file-mode? ; -: other-write? ( path -- ? ) OTHER-WRITE file-mode? ; -: other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ; +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: 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 ; From d6784bdb466b15414c88183c9a86edf3d477edcc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 17:48:33 -0500 Subject: [PATCH 109/224] make user-read? work in file-info objects --- basis/io/unix/files/files-docs.factor | 46 +++++++++++++------------- basis/io/unix/files/files-tests.factor | 36 ++++++++++---------- basis/io/unix/files/files.factor | 13 ++++++++ 3 files changed, 54 insertions(+), 41 deletions(-) diff --git a/basis/io/unix/files/files-docs.factor b/basis/io/unix/files/files-docs.factor index 5649b56abd..3798380e0f 100644 --- a/basis/io/unix/files/files-docs.factor +++ b/basis/io/unix/files/files-docs.factor @@ -38,37 +38,37 @@ 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." } ; +{ $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 or an integer" } + { "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 or an integer." } ; +{ $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 or an integer" } + { "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 or an integer." } ; +{ $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 or an integer" } + { "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 or an integer." } ; +{ $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 or an integer" } + { "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 or an integer." } ; +{ $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 or an integer" } + { "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 or an integer." } ; +{ $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 @@ -124,9 +124,9 @@ HELP: set-gid HELP: gid? { $values - { "obj" "a pathname string or an integer" } + { "obj" "a pathname string, file-info object, or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file or an integer." } ; +{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: set-group-execute { $values @@ -165,9 +165,9 @@ HELP: set-sticky HELP: sticky? { $values - { "obj" "a pathname string or an integer" } + { "obj" "a pathname string, file-info object, or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file or an integer." } ; +{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: set-uid { $values @@ -176,9 +176,9 @@ HELP: set-uid HELP: uid? { $values - { "obj" "a pathname string or an integer" } + { "obj" "a pathname string, file-info object, or an integer" } { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file or an integer." } ; +{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ; HELP: set-user-execute { $values @@ -197,21 +197,21 @@ HELP: set-user-write HELP: user-execute? { $values - { "obj" "a pathname string or an integer" } + { "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 or an integer." } ; +{ $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 or an integer" } + { "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 or an integer." } ; +{ $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 or an integer" } + { "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 or an integer." } ; +{ $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:" diff --git a/basis/io/unix/files/files-tests.factor b/basis/io/unix/files/files-tests.factor index 21a4d18759..78a80ad969 100644 --- a/basis/io/unix/files/files-tests.factor +++ b/basis/io/unix/files/files-tests.factor @@ -55,32 +55,32 @@ prepare-test-file [ 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 +[ 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 +[ 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 +[ 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 +[ 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 +[ 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 +[ 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 +[ 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 +[ 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 +[ 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 diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index b5fa7783d0..e253e77748 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -192,6 +192,19 @@ 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? ; From 1e6caf3de3cd8562918be0a176e2220b87a10be1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 18 Oct 2008 20:09:00 -0500 Subject: [PATCH 110/224] Remove old resolver 'dns.resolver' --- extra/dns/resolver/resolver.factor | 49 ------------------------------ 1 file changed, 49 deletions(-) delete mode 100644 extra/dns/resolver/resolver.factor diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor deleted file mode 100644 index 2dae43b5d4..0000000000 --- a/extra/dns/resolver/resolver.factor +++ /dev/null @@ -1,49 +0,0 @@ - -USING: kernel vectors sequences combinators random - accessors newfx dns dns.cache ; - -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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: 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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: name->ip ( name -- ip ) - fully-qualified - dup name->ip/cache dup - [ nip ] - [ drop name->ip/server ] - if ; From 7a5ed225bfbc744905a0e36a5b04264d6f594178 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 18 Oct 2008 20:10:23 -0500 Subject: [PATCH 111/224] Remove old recursive resolver (dns.recursive) --- extra/dns/recursive/recursive.factor | 185 --------------------------- 1 file changed, 185 deletions(-) delete mode 100644 extra/dns/recursive/recursive.factor diff --git a/extra/dns/recursive/recursive.factor b/extra/dns/recursive/recursive.factor deleted file mode 100644 index 3a74667845..0000000000 --- a/extra/dns/recursive/recursive.factor +++ /dev/null @@ -1,185 +0,0 @@ - -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 ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 51f72043561dd954cf496cdf0f02138e76517a39 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:14:51 -0500 Subject: [PATCH 112/224] add unix utilities words --- basis/unix/utilities/authors.txt | 1 + basis/unix/utilities/utilities.factor | 19 +++++++++++++++++++ 2 files changed, 20 insertions(+) create mode 100644 basis/unix/utilities/authors.txt create mode 100644 basis/unix/utilities/utilities.factor diff --git a/basis/unix/utilities/authors.txt b/basis/unix/utilities/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/utilities/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor new file mode 100644 index 0000000000..1f3a6bf78a --- /dev/null +++ b/basis/unix/utilities/utilities.factor @@ -0,0 +1,19 @@ +! 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 ; + +: 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 ; From 8b2661080805fe2239816b650164c96e4459e97b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:15:43 -0500 Subject: [PATCH 113/224] os envs code and use unix.utilities --- basis/unix/groups/groups.factor | 9 ++------- basis/unix/process/process.factor | 17 ++++++++--------- basis/unix/unix.factor | 4 ++++ 3 files changed, 14 insertions(+), 16 deletions(-) diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index c3af9cc83d..b8edf7fa36 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -4,7 +4,7 @@ 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.users unix.utilities ; IN: unix.groups QUALIFIED: grouping @@ -18,12 +18,7 @@ GENERIC: group-struct ( obj -- group ) string - [ alien-address "char**" heap-size + ] dip - ] [ ] produce nip ; + group-gr_mem utf8 alien>strings ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) "group" tuck 4096 diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 7d3d757705..030f0977e2 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -1,6 +1,6 @@ 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 @@ -15,17 +15,16 @@ FUNCTION: int execv ( char* path, char** argv ) ; 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 ; @@ -99,4 +98,4 @@ FUNCTION: pid_t wait ( int* status ) ; FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; : wait-for-pid ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 960115d1a6..0963856ea6 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -105,6 +105,8 @@ FUNCTION: int getdtablesize ; 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 ( ) ; @@ -171,6 +173,8 @@ FUNCTION: int rename ( char* from, char* to ) ; 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 ) ; From 110caf3e54e12b3401d08e198cba3ab066fca726 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:16:15 -0500 Subject: [PATCH 114/224] os-env typedefs --- basis/windows/kernel32/kernel32.factor | 4 ++-- basis/windows/types/types.factor | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 108e02cb46..d4c610c7b9 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -933,9 +933,9 @@ FUNCTION: HANDLE GetCurrentThread ( ) ; ! FUNCTION: GetDllDirectoryW ! FUNCTION: GetDriveTypeA ! FUNCTION: GetDriveTypeW -! FUNCTION: GetEnvironmentStrings +FUNCTION: LPTCH GetEnvironmentStrings ( ) ; ! FUNCTION: GetEnvironmentStringsA -! FUNCTION: GetEnvironmentStringsW +ALIAS: GetEnvironmentStrings GetEnvironmentStringsW ! FUNCTION: GetEnvironmentVariableA ! FUNCTION: GetEnvironmentVariableW FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ; diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 3fef691741..56d617e835 100644 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -7,7 +7,7 @@ TYPEDEF: char CHAR TYPEDEF: uchar UCHAR TYPEDEF: uchar BYTE -TYPEDEF: ushort wchar_t +TYPEDEF: ushort wchar_t TYPEDEF: wchar_t WCHAR TYPEDEF: short SHORT @@ -65,6 +65,7 @@ TYPEDEF: longlong LARGE_INTEGER TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER TYPEDEF: WCHAR TCHAR +TYPEDEF: TCHAR* LPTCH TYPEDEF: TCHAR TBYTE TYPEDEF: wchar_t* LPCSTR TYPEDEF: wchar_t* LPWSTR From 5dc3bf2b277a62539c2cbc35bffc1f2a1cb44aff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:18:04 -0500 Subject: [PATCH 115/224] os-env change --- basis/ui/x11/x11.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index 3122bc536b..e3c8421080 100644 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -6,8 +6,8 @@ assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows io.encodings.string io.encodings.ascii io.encodings.utf8 combinators 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 @@ -262,5 +262,5 @@ M: x11-ui-backend beep ( -- ) x11-ui-backend ui-backend set-global -[ "DISPLAY" system:os-env "ui" "listener" ? ] +[ "DISPLAY" os-env "ui" "listener" ? ] main-vocab-hook set-global From 3e24ff97fe0841e25d1cf77831e9c40374a867bc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:18:58 -0500 Subject: [PATCH 116/224] remove os-env docs and tests from core/ --- core/system/system-docs.factor | 53 --------------------------------- core/system/system-tests.factor | 27 ----------------- 2 files changed, 80 deletions(-) delete mode 100644 core/system/system-tests.factor diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index 49886492ec..acd42b094f 100644 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -7,7 +7,6 @@ ABOUT: "system" ARTICLE: "system" "System interface" { $subsection "cpu" } { $subsection "os" } -{ $subsection "environment-variables" } "Getting the path to the Factor VM and image:" { $subsection vm } { $subsection image } @@ -16,15 +15,6 @@ ARTICLE: "system" "System interface" "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 } @@ -79,49 +69,6 @@ HELP: millis ( -- n ) { $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." } ; diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor deleted file mode 100644 index c731a14725..0000000000 --- a/core/system/system-tests.factor +++ /dev/null @@ -1,27 +0,0 @@ -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 "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 From 248d33b51fb9aa8aa88471df6b63098975a859c2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:20:13 -0500 Subject: [PATCH 117/224] initial checkin of environment --- basis/environment/authors.txt | 1 + basis/environment/environment-docs.factor | 68 +++++++++++++++++++ basis/environment/environment-tests.factor | 29 ++++++++ basis/environment/environment.factor | 27 ++++++++ basis/environment/summary.txt | 1 + basis/environment/unix/authors.txt | 1 + basis/environment/unix/macosx/authors.txt | 1 + .../unix/macosx/macosx-tests.factor | 4 ++ basis/environment/unix/macosx/macosx.factor | 8 +++ basis/environment/unix/macosx/tags.txt | 1 + basis/environment/unix/tags.txt | 1 + basis/environment/unix/unix.factor | 29 ++++++++ basis/environment/winnt/authors.txt | 1 + basis/environment/winnt/tags.txt | 1 + basis/environment/winnt/winnt.factor | 25 +++++++ 15 files changed, 198 insertions(+) create mode 100644 basis/environment/authors.txt create mode 100644 basis/environment/environment-docs.factor create mode 100644 basis/environment/environment-tests.factor create mode 100644 basis/environment/environment.factor create mode 100644 basis/environment/summary.txt create mode 100644 basis/environment/unix/authors.txt create mode 100644 basis/environment/unix/macosx/authors.txt create mode 100644 basis/environment/unix/macosx/macosx-tests.factor create mode 100644 basis/environment/unix/macosx/macosx.factor create mode 100644 basis/environment/unix/macosx/tags.txt create mode 100644 basis/environment/unix/tags.txt create mode 100644 basis/environment/unix/unix.factor create mode 100644 basis/environment/winnt/authors.txt create mode 100644 basis/environment/winnt/tags.txt create mode 100644 basis/environment/winnt/winnt.factor diff --git a/basis/environment/authors.txt b/basis/environment/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/environment/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/environment/environment-docs.factor b/basis/environment/environment-docs.factor new file mode 100644 index 0000000000..e539b446f3 --- /dev/null +++ b/basis/environment/environment-docs.factor @@ -0,0 +1,68 @@ +! 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" diff --git a/basis/environment/environment-tests.factor b/basis/environment/environment-tests.factor new file mode 100644 index 0000000000..3717303175 --- /dev/null +++ b/basis/environment/environment-tests.factor @@ -0,0 +1,29 @@ +! 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 "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 diff --git a/basis/environment/environment.factor b/basis/environment/environment.factor new file mode 100644 index 0000000000..492925c7c0 --- /dev/null +++ b/basis/environment/environment.factor @@ -0,0 +1,27 @@ +! 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 diff --git a/basis/environment/summary.txt b/basis/environment/summary.txt new file mode 100644 index 0000000000..24d14cb458 --- /dev/null +++ b/basis/environment/summary.txt @@ -0,0 +1 @@ +Environment variables diff --git a/basis/environment/unix/authors.txt b/basis/environment/unix/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/environment/unix/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/environment/unix/macosx/authors.txt b/basis/environment/unix/macosx/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/environment/unix/macosx/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/environment/unix/macosx/macosx-tests.factor b/basis/environment/unix/macosx/macosx-tests.factor new file mode 100644 index 0000000000..56a69fc599 --- /dev/null +++ b/basis/environment/unix/macosx/macosx-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test environment.unix.macosx ; +IN: environment.unix.macosx.tests diff --git a/basis/environment/unix/macosx/macosx.factor b/basis/environment/unix/macosx/macosx.factor new file mode 100644 index 0000000000..51cee7ba08 --- /dev/null +++ b/basis/environment/unix/macosx/macosx.factor @@ -0,0 +1,8 @@ +! 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 ; diff --git a/basis/environment/unix/macosx/tags.txt b/basis/environment/unix/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/environment/unix/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/environment/unix/tags.txt b/basis/environment/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/environment/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor new file mode 100644 index 0000000000..c2dddc25ab --- /dev/null +++ b/basis/environment/unix/unix.factor @@ -0,0 +1,29 @@ +! 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 diff --git a/basis/environment/winnt/authors.txt b/basis/environment/winnt/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/environment/winnt/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/environment/winnt/tags.txt b/basis/environment/winnt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/environment/winnt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/environment/winnt/winnt.factor b/basis/environment/winnt/winnt.factor new file mode 100644 index 0000000000..e73db5c292 --- /dev/null +++ b/basis/environment/winnt/winnt.factor @@ -0,0 +1,25 @@ +! 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 ; +IN: environment.winnt + +M: winnt os-env ( key -- value ) + MAX_UNICODE_PATH "TCHAR" + [ GetEnvironmentVariable ] keep over 0 = [ + 2drop f + ] [ + nip utf16 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 [ "\0" split ] [ FreeEnvironmentStrings ] bi ; From 26aee8687b6a4b90bb5281e1df7ef56d969c72a0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:20:35 -0500 Subject: [PATCH 118/224] remove empty tests file --- basis/environment/unix/macosx/macosx-tests.factor | 4 ---- 1 file changed, 4 deletions(-) delete mode 100644 basis/environment/unix/macosx/macosx-tests.factor diff --git a/basis/environment/unix/macosx/macosx-tests.factor b/basis/environment/unix/macosx/macosx-tests.factor deleted file mode 100644 index 56a69fc599..0000000000 --- a/basis/environment/unix/macosx/macosx-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test environment.unix.macosx ; -IN: environment.unix.macosx.tests From ab0ed9f988ad86854d16e0e7f743e8255c0dc991 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:24:14 -0500 Subject: [PATCH 119/224] redo home implementation --- basis/io/unix/files/files.factor | 5 ++++- basis/io/windows/nt/files/files.factor | 4 +++- core/io/files/files.factor | 8 ++------ 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index e253e77748..af023e3f13 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -5,7 +5,8 @@ unix unix.stat unix.time kernel math continuations math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system io.files.private destructors vocabs.loader calendar.unix -unix.stat alien.c-types arrays unix.users unix.groups ; +unix.stat alien.c-types arrays unix.users unix.groups +environment ; IN: io.unix.files M: unix cwd ( -- path ) @@ -294,3 +295,5 @@ M: string set-file-group ( path string -- ) : file-group-name ( path -- string ) file-group-id group-name ; + +M: unix home "HOME" os-env ; diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor index 157662ade8..9b77a9f128 100644 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -1,7 +1,7 @@ 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 ; @@ -59,3 +59,5 @@ M: winnt FileArgs-overlapped ( port -- overlapped ) M: winnt open-append [ dup file-info size>> ] [ drop 0 ] recover >r (open-append) r> >>ptr ; + +M: winnt home "USERPROFILE" os-env ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index bc84aa5d21..6b84073d34 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -332,10 +332,6 @@ C: pathname M: pathname <=> [ string>> ] compare ; ! Home directory -HOOK: home os ( -- dir ) +HOOK: home io-backend ( -- dir ) -M: winnt home "USERPROFILE" os-env ; - -M: wince home "" resource-path ; - -M: unix home "HOME" os-env ; +M: object home "" resource-path ; From 84ec1eec1dfeb509665b23191c9a98def781a5e8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:41:16 -0500 Subject: [PATCH 120/224] remove environ and os-envs primitives --- vm/os-freebsd.h | 4 --- vm/os-linux.h | 4 --- vm/os-macosx.h | 5 ---- vm/os-netbsd.h | 2 -- vm/os-openbsd.h | 4 --- vm/os-solaris.h | 2 -- vm/os-unix.c | 66 ------------------------------------------------- vm/os-windows.c | 35 -------------------------- vm/primitives.c | 5 ---- 9 files changed, 127 deletions(-) diff --git a/vm/os-freebsd.h b/vm/os-freebsd.h index 5cedbc82b7..c535e2d71f 100644 --- a/vm/os-freebsd.h +++ b/vm/os-freebsd.h @@ -10,7 +10,3 @@ extern int getosreldate(void); #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 diff --git a/vm/os-linux.h b/vm/os-linux.h index 1a1e088359..78ecbafd35 100644 --- a/vm/os-linux.h +++ b/vm/os-linux.h @@ -3,10 +3,6 @@ #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); diff --git a/vm/os-macosx.h b/vm/os-macosx.h index 701bb8da01..b9686a5a85 100644 --- a/vm/os-macosx.h +++ b/vm/os-macosx.h @@ -12,11 +12,6 @@ const char *default_image_path(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; diff --git a/vm/os-netbsd.h b/vm/os-netbsd.h index b42c6b9d7e..54b5d0bcff 100644 --- a/vm/os-netbsd.h +++ b/vm/os-netbsd.h @@ -4,5 +4,3 @@ #define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) #define DIRECTORY_P(file) ((file)->d_type == DT_DIR) - -extern char **environ; diff --git a/vm/os-openbsd.h b/vm/os-openbsd.h index 21e34c98f8..af47f7bcea 100644 --- a/vm/os-openbsd.h +++ b/vm/os-openbsd.h @@ -1,6 +1,2 @@ #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 diff --git a/vm/os-solaris.h b/vm/os-solaris.h index 909cc3f4e9..788a78090b 100644 --- a/vm/os-solaris.h +++ b/vm/os-solaris.h @@ -1,4 +1,2 @@ #define UNKNOWN_TYPE_P(file) 1 #define DIRECTORY_P(file) 0 - -extern char **environ; diff --git a/vm/os-unix.c b/vm/os-unix.c index d4aebad537..fa2d5bb40c 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -99,72 +99,6 @@ DEFINE_PRIMITIVE(read_dir) 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(); diff --git a/vm/os-windows.c b/vm/os-windows.c index 4c21c9b5c9..c36ba59a27 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -214,38 +214,3 @@ void sleep_millis(DWORD msec) { 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(); -} diff --git a/vm/primitives.c b/vm/primitives.c index b5d9403342..39dc2b10d7 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -71,7 +71,6 @@ void *primitives[] = { primitive_exit, primitive_data_room, primitive_code_room, - primitive_os_env, primitive_millis, primitive_modify_code_heap, primitive_dlopen, @@ -141,10 +140,6 @@ void *primitives[] = { 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, From 27c36974a7661268ce2cc0a42ba5fba45f45d533 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 21:42:01 -0500 Subject: [PATCH 121/224] remove primitives from core, update usages --- basis/debugger/debugger-docs.factor | 6 ++---- basis/io/launcher/launcher.factor | 2 +- basis/io/unix/launcher/launcher.factor | 2 +- basis/stack-checker/known-words/known-words.factor | 10 ---------- core/bootstrap/primitives.factor | 5 ----- core/system/system.factor | 6 ------ 6 files changed, 4 insertions(+), 27 deletions(-) diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index f8897712e7..fe00d011c3 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -1,7 +1,6 @@ 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" @@ -144,5 +143,4 @@ HELP: memory-error. { $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." } ; diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 7f1a3f4507..3e190e012e 100644 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -2,7 +2,7 @@ ! 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 diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor index fb8dc85cf8..421e12a92f 100644 --- a/basis/io/unix/launcher/launcher.factor +++ b/basis/io/unix/launcher/launcher.factor @@ -2,7 +2,7 @@ ! 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 diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 80e888a3e9..1a0f3c5eb2 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -412,8 +412,6 @@ do-primitive alien-invoke alien-indirect alien-callback \ 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 @@ -590,14 +588,6 @@ do-primitive alien-invoke alien-indirect alien-callback \ 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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 1a6fa3c18a..08ae762577 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -448,7 +448,6 @@ tuple { "exit" "system" } { "data-room" "memory" } { "code-room" "memory" } - { "os-env" "system" } { "millis" "system" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } @@ -518,10 +517,6 @@ tuple { "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" } diff --git a/core/system/system.factor b/core/system/system.factor index 6c9d838fa4..66662a23e1 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -65,9 +65,3 @@ PRIVATE> ] "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) ; From 7614a002e4f68d0581011ebed6659ae2f2bfc8e4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 22:49:55 -0500 Subject: [PATCH 122/224] unportable --- extra/hardware-info/windows/ce/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/hardware-info/windows/ce/tags.txt diff --git a/extra/hardware-info/windows/ce/tags.txt b/extra/hardware-info/windows/ce/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/hardware-info/windows/ce/tags.txt @@ -0,0 +1 @@ +unportable From 0a539520b2408151b0494338578e0f85d732bcd5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 22:50:10 -0500 Subject: [PATCH 123/224] fix using --- extra/shell/shell.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor index 0ed594602a..034cdaba5d 100644 --- a/extra/shell/shell.factor +++ b/extra/shell/shell.factor @@ -3,7 +3,7 @@ USING: kernel parser words continuations namespaces debugger sequences combinators splitting prettyprint system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep accessors multi-methods newfx shell.parser - combinators.short-circuit eval ; + combinators.short-circuit eval environment ; IN: shell @@ -139,4 +139,4 @@ DEFER: shell ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MAIN: ix \ No newline at end of file +MAIN: ix From 3905460c4565f4d27bf18a1f495f82eff0718893 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 18 Oct 2008 23:03:22 -0500 Subject: [PATCH 124/224] fix winnt environment variables --- basis/environment/winnt/winnt.factor | 16 ++++++++++++---- basis/windows/errors/errors.factor | 1 + basis/windows/kernel32/kernel32.factor | 11 +++++++---- basis/windows/types/types.factor | 9 ++++----- 4 files changed, 24 insertions(+), 13 deletions(-) diff --git a/basis/environment/winnt/winnt.factor b/basis/environment/winnt/winnt.factor index e73db5c292..33cf6a698b 100644 --- a/basis/environment/winnt/winnt.factor +++ b/basis/environment/winnt/winnt.factor @@ -1,15 +1,17 @@ ! 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 ; +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" - [ GetEnvironmentVariable ] keep over 0 = [ + [ dup length GetEnvironmentVariable ] keep over 0 = [ 2drop f ] [ - nip utf16 alien>string + nip utf16n alien>string ] if ; M: winnt set-os-env ( value key -- ) @@ -22,4 +24,10 @@ M: winnt unset-os-env ( key -- ) ] when ; M: winnt (os-envs) ( -- seq ) - GetEnvironmentStrings [ "\0" split ] [ FreeEnvironmentStrings ] bi ; + GetEnvironmentStrings [ + [ + utf16n decode-input + [ "\0" read-until drop dup empty? not ] + [ ] [ drop ] produce + ] with-input-stream* + ] [ FreeEnvironmentStrings win32-error=0/f ] bi ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 2e4e709d43..31a7cd8c09 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -4,6 +4,7 @@ IN: windows.errors : ERROR_SUCCESS 0 ; 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 diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index d4c610c7b9..f19561cda3 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -838,7 +838,8 @@ ALIAS: FindNextFile FindNextFileW ! FUNCTION: FormatMessageW ! FUNCTION: FreeConsole ! FUNCTION: FreeEnvironmentStringsA -! FUNCTION: FreeEnvironmentStringsW +FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ; +ALIAS: FreeEnvironmentStrings FreeEnvironmentStringsW ! FUNCTION: FreeLibrary ! FUNCTION: FreeLibraryAndExitThread ! FUNCTION: FreeResource @@ -933,11 +934,12 @@ FUNCTION: HANDLE GetCurrentThread ( ) ; ! FUNCTION: GetDllDirectoryW ! FUNCTION: GetDriveTypeA ! FUNCTION: GetDriveTypeW -FUNCTION: LPTCH GetEnvironmentStrings ( ) ; +FUNCTION: void* GetEnvironmentStringsW ( ) ; ! FUNCTION: GetEnvironmentStringsA 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 @@ -1418,7 +1420,8 @@ ALIAS: SetCurrentDirectory SetCurrentDirectoryW ! 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 diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 56d617e835..b1d8914be9 100644 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -64,13 +64,12 @@ TYPEDEF: ulonglong DWORD64 TYPEDEF: longlong LARGE_INTEGER TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER -TYPEDEF: WCHAR TCHAR -TYPEDEF: TCHAR* LPTCH -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 From 9476a07eb2a863db4728b5c08e18ab824089ee7b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 00:06:13 -0500 Subject: [PATCH 125/224] unportable pl0x --- extra/hardware-info/windows/nt/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/hardware-info/windows/nt/tags.txt diff --git a/extra/hardware-info/windows/nt/tags.txt b/extra/hardware-info/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/hardware-info/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable From adb0ada7ae52c28d047941ff78f5af3357ba4283 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Oct 2008 03:34:58 -0500 Subject: [PATCH 126/224] Add delq, filter-here --- core/sequences/sequences-docs.factor | 79 ++++++++++++++++++++-------- core/sequences/sequences.factor | 29 ++++++---- 2 files changed, 78 insertions(+), 30 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 0a4974607d..fc6f1465bb 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -397,6 +397,11 @@ HELP: filter { $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 -- ? )" } } { "subseq" "a new sequence" } } +{ $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." } @@ -436,20 +441,24 @@ HELP: last-index-from { $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 @@ -469,6 +478,13 @@ HELP: move 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 @@ -592,7 +608,7 @@ HELP: reverse { $values { "seq" sequence } { "newseq" "a new sequence" } } { $description "Outputs a new sequence having the same elements as " { $snippet "seq" } " but in reverse order." } ; -{ reverse } related-words +{ reverse reverse-here } related-words HELP: ( seq -- reversed ) { $values { "seq" sequence } { "reversed" "a new sequence" } } @@ -784,7 +800,7 @@ HELP: tail? { $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" } } @@ -982,7 +998,7 @@ HELP: harvest } } ; -{ filter sift harvest } related-words +{ filter filter-here sift harvest } related-words HELP: set-first { $values @@ -1315,6 +1331,7 @@ ARTICLE: "sequences-add-remove" "Adding and removing sequence elements" { $subsection suffix } "Removing elements:" { $subsection remove } +{ $subsection remq } { $subsection remove-nth } ; ARTICLE: "sequences-reshape" "Reshaping sequences" @@ -1446,29 +1463,49 @@ ARTICLE: "sequences-trimming" "Trimming 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" diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 63cc14d1d7..0fe47f0099 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -498,15 +498,18 @@ PRIVATE> : 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 ; @@ -552,16 +555,24 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; 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> [ From b9df6d89e3e08b17351cdbe43bb85776e5af5b79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Oct 2008 04:40:15 -0500 Subject: [PATCH 127/224] Fix dodgy init-hook --- basis/io/launcher/launcher.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index 3e190e012e..3e1ef6ce05 100644 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -58,8 +58,6 @@ SYMBOL: +realtime-priority+ ! 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 @@ -73,7 +71,10 @@ SYMBOL: wait-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 From 83638c35dabc6e1c0b683470c14dd8a90bb32ed0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 12:55:48 -0500 Subject: [PATCH 128/224] change up the way you read directories --- core/io/files/files-docs.factor | 30 ++++++++++------------- core/io/files/files-tests.factor | 14 +++++++---- core/io/files/files.factor | 41 ++++++++++++++++---------------- 3 files changed, 44 insertions(+), 41 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 8e32c100e0..984598688d 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -55,8 +55,9 @@ ARTICLE: "directories" "Directories" "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 } @@ -304,23 +305,22 @@ HELP: directory? { $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: resource-path { $values { "path" "a pathname string" } { "newpath" "a pathname string" } } @@ -329,10 +329,6 @@ HELP: resource-path HELP: pathname { $class-description "Class of path name objects. Path name objects can be created by calling " { $link } "." } ; -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 } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 0723096519..3104fcdb55 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -151,18 +151,24 @@ USE: debugger.threads "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 diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6b84073d34..8796834bc7 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -235,19 +235,22 @@ HOOK: make-directory 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 ; -: directory ( path -- seq ) - normalize-directory dup (directory) fixup-directory ; +HOOK: >directory-entry os ( byte-array -- directory-entry ) -: directory* ( path -- seq ) - dup directory [ first2 >r append-path r> 2array ] with map ; +HOOK: (directory-entries) os ( path -- seq ) + +: directory-entries ( path -- seq ) + normalize-path + (directory-entries) + [ name>> { "." ".." } member? not ] filter ; + +: directory-files ( path -- seq ) + directory-entries [ name>> ] map ; + +: with-directory-files ( path quot -- ) + [ "" directory-files ] prepose with-directory ; inline ! Touching files HOOK: touch-file io-backend ( path -- ) @@ -259,12 +262,10 @@ HOOK: delete-directory 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 ; @@ -303,9 +304,9 @@ DEFER: copy-tree-into { { +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 ; From 0e9ecc1ba9d77f49a3205001349678610d1cac5b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 13:09:48 -0500 Subject: [PATCH 129/224] directory changes --- basis/http/server/static/static.factor | 6 ++--- basis/io/monitors/recursive/recursive.factor | 6 +++-- basis/io/unix/files/files.factor | 23 +++++++++++++++++- basis/unix/unix.factor | 5 ++++ extra/shell/shell.factor | 2 +- extra/webapps/wiki/wiki.factor | 25 ++++++++++---------- 6 files changed, 48 insertions(+), 19 deletions(-) diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 3e3307033a..3edcfe81cd 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -59,8 +59,8 @@ TUPLE: file-responder root hook special allow-listings ; \ serve-file NOTICE add-input-logging -: file. ( name dirp -- ) - [ "/" append ] when +: file. ( name -- ) + dup link-info directory? [ "/" append ] when dup escape-string write ; : directory. ( path -- ) @@ -68,7 +68,7 @@ TUPLE: file-responder root hook special allow-listings ; [

file-name escape-string write

] [
    - directory sort-keys + directory-files [
  • file.
    • ] assoc-each
] bi diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index 383e166214..3cecee2b1e 100644 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -19,11 +19,13 @@ DEFER: add-child-monitor : add-child-monitors ( path -- ) #! We yield since this directory scan might take a while. - directory* [ first add-child-monitor ] each yield ; + [ + [ 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 ] [ [ diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index af023e3f13..67da640b71 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -6,7 +6,7 @@ math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system io.files.private destructors vocabs.loader calendar.unix unix.stat alien.c-types arrays unix.users unix.groups -environment ; +environment fry io.encodings.utf8 alien.strings ; IN: io.unix.files M: unix cwd ( -- path ) @@ -138,6 +138,27 @@ os { { linux [ ] } } case +: with-unix-directory ( path quot -- ) + [ opendir dup [ (io-error) ] unless ] dip + dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline + +: find-next-file ( DIR* -- byte-array ) + "dirent" + f + [ readdir_r 0 = [ (io-error) ] unless ] 2keep + *void* [ drop f ] unless ; + +M: unix >directory-entry ( byte-array -- directory-entry ) + [ dirent-d_name utf8 alien>string ] + [ dirent-d_type ] bi directory-entry boa ; + +M: unix (directory-entries) ( path -- seq ) + [ + '[ _ find-next-file dup ] + [ >directory-entry ] + [ drop ] produce + ] with-unix-directory ; + > os-env ; METHOD: expand { glob-expr } expr>> dup "*" = - [ drop current-directory get directory [ first ] map ] + [ drop current-directory get directory-files ] [ ] if ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 16c51a876b..b833cc8cc2 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -374,15 +374,16 @@ M: revision feed-entry-url id>> revision-url ; { wiki "wiki-common" } >>template ; : init-wiki ( -- ) - "resource:extra/webapps/wiki/initial-content" directory* keys - [ - dup file-name ".txt" ?tail [ - swap ascii file-contents - f - 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 + swap >>content + swap >>title + "slava" >>author + now >>date + add-revision + ] [ 2drop ] if + ] each + ] with-directory-files ; From 613cd3fd67ce1d02751dcb1e5511e134c3020662 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 13:10:28 -0500 Subject: [PATCH 130/224] directory/stat struct work --- basis/unix/bsd/macosx/macosx.factor | 37 +++++++++ basis/unix/stat/macosx/macosx.factor | 120 ++++++++++++++++++++++++++- basis/unix/stat/stat.factor | 8 +- 3 files changed, 158 insertions(+), 7 deletions(-) diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index c41ae6df7d..96e2cde163 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -132,3 +132,40 @@ C-STRUCT: utmpx { "timeval" "ut_tv" } { { "char" _UTX_HOSTSIZE } "ut_host" } { { "uint" 16 } "ut_pad" } ; + +: __PTHREAD_MUTEX_SIZE__ 40 ; inline + +C-STRUCT: _opaque_pthread_mutex_t + { "long" "__sig" } + { { "char" __PTHREAD_MUTEX_SIZE__ } "__opaque" } ; + +TYPEDEF: _opaque_pthread_mutex_t* __darwin_pthread_mutex_t + +C-STRUCT: DIR + { "int" "__dd_fd" } + { "long" "__dd_loc" } + { "long" "__dd_size" } + { "char*" "__dd_buf" } + { "int" "__dd_len" } + { "long" "__dd_seek" } + { "long" "__dd_rewind" } + { "int" "__dd_flags" } + { "__darwin_pthread_mutex_t" "__dd_lock" } + { "void*" "__dd_td" } ; + + +! #define DIRSIZ(dp) \ + ! ((sizeof (struct direct) - (MAXNAMLEN+1)) + (((dp)->d_namlen+1 + 3) &~ 3)) + +! __DARWIN_STRUCT_DIRENTRY { \ + +: __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" } ; diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index b2574b474d..03301d25b9 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -1,4 +1,5 @@ -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 @@ -30,3 +31,120 @@ FUNCTION: int lstat64 ( char* pathname, stat* buf ) ; : stat ( path buf -- n ) stat64 ; : lstat ( path buf -- n ) lstat64 ; + +: 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 + +! C-STRUCT: fhandle + ! { "int" "fh_len" } + ! { { "uchar" NFS_MAX_FH_SIZE } "fh_data" } ; + +! TYPEDEF: fhandle fhandle_t + +: 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 ) ; diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index 46fe7d98f9..f8ad74c213 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -27,11 +27,7 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; } case >> : file-status ( pathname -- stat ) - "stat" [ - [ stat ] unix-system-call drop - ] keep ; + "stat" [ [ stat ] unix-system-call drop ] keep ; : link-status ( pathname -- stat ) - "stat" [ - [ lstat ] unix-system-call drop - ] keep ; + "stat" [ [ lstat ] unix-system-call drop ] keep ; From 4af3543fcda176a5f930c7d644c2a1689033aa28 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 13:11:10 -0500 Subject: [PATCH 131/224] directory fix --- extra/io/paths/paths.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 58b3518edd..8237e59a1b 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -7,7 +7,7 @@ IN: io.paths 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 [ @@ -21,7 +21,7 @@ TUPLE: directory-iterator path bfs queue ; : 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 ; From 78a529b1c315c7c6c849784847524591eb015de1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 13:27:59 -0500 Subject: [PATCH 132/224] remove directory from the vm --- .../known-words/known-words.factor | 2 - basis/tools/vocabs/vocabs.factor | 7 +-- core/bootstrap/primitives.factor | 1 - vm/os-unix.c | 38 ---------------- vm/os-windows.c | 43 ------------------- vm/primitives.c | 1 - 6 files changed, 4 insertions(+), 88 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 1a0f3c5eb2..1332415c49 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -396,8 +396,6 @@ do-primitive alien-invoke alien-indirect alien-callback \ (exists?) { string } { object } define-primitive -\ (directory) { string } { array } define-primitive - \ gc { } { } define-primitive \ gc-stats { } { array } define-primitive diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 732a6635b7..05f354a8a8 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -14,8 +14,7 @@ IN: tools.vocabs : vocab-tests-dir ( vocab -- paths ) dup vocab-dir "tests" append-path vocab-append-path dup [ dup exists? [ - dup directory keys - [ ".factor" tail? ] filter + dup directory-files [ ".factor" tail? ] filter [ append-path ] with map ] [ drop f ] if ] [ drop f ] if ; @@ -208,7 +207,9 @@ M: vocab-link summary vocab-summary ; dup vocab-authors-path set-vocab-file-contents ; : subdirs ( dir -- dirs ) - directory [ second ] filter keys natural-sort ; + [ + [ link-info directory? ] filter + ] with-directory-files natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) [ vocab-dir append-path subdirs ] keep diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 08ae762577..62d4ec9273 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -434,7 +434,6 @@ tuple { "getenv" "kernel.private" } { "setenv" "kernel.private" } { "(exists?)" "io.files.private" } - { "(directory)" "io.files.private" } { "gc" "memory" } { "gc-stats" "memory" } { "save-image" "memory" } diff --git a/vm/os-unix.c b/vm/os-unix.c index fa2d5bb40c..4ca62e6623 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -61,44 +61,6 @@ DEFINE_PRIMITIVE(existsp) 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); -} - F_SEGMENT *alloc_segment(CELL size) { int pagesize = getpagesize(); diff --git a/vm/os-windows.c b/vm/os-windows.c index c36ba59a27..c19aa5c4b5 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -87,21 +87,6 @@ const F_CHAR *vm_executable_path(void) 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; @@ -136,34 +121,6 @@ DEFINE_PRIMITIVE(existsp) 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; diff --git a/vm/primitives.c b/vm/primitives.c index 39dc2b10d7..94151f6c40 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -57,7 +57,6 @@ void *primitives[] = { primitive_getenv, primitive_setenv, primitive_existsp, - primitive_read_dir, primitive_gc, primitive_gc_stats, primitive_save_image, From a71ca7242a660bb0c6664df8e2d619a583f1cd93 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 13:34:00 -0500 Subject: [PATCH 133/224] fix typo in docs, fix load error --- basis/io/windows/files/unique/unique.factor | 2 +- core/sequences/sequences-docs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/windows/files/unique/unique.factor b/basis/io/windows/files/unique/unique.factor index dcb713df7f..b1bf2bdc1c 100644 --- a/basis/io/windows/files/unique/unique.factor +++ b/basis/io/windows/files/unique/unique.factor @@ -1,6 +1,6 @@ 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 -- ) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index fc6f1465bb..a75b97c040 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -398,7 +398,7 @@ HELP: filter { $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 -- ? )" } } { "subseq" "a new sequence" } } +{ $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" } ; From bce8b1eff617da9a9c8e47a8938823e1d2326500 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 13:43:42 -0500 Subject: [PATCH 134/224] DIR is not meant to be explicit --- basis/unix/bsd/macosx/macosx.factor | 18 ------------------ basis/unix/unix.factor | 2 +- 2 files changed, 1 insertion(+), 19 deletions(-) diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index 96e2cde163..6270dc53b1 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -141,24 +141,6 @@ C-STRUCT: _opaque_pthread_mutex_t TYPEDEF: _opaque_pthread_mutex_t* __darwin_pthread_mutex_t -C-STRUCT: DIR - { "int" "__dd_fd" } - { "long" "__dd_loc" } - { "long" "__dd_size" } - { "char*" "__dd_buf" } - { "int" "__dd_len" } - { "long" "__dd_seek" } - { "long" "__dd_rewind" } - { "int" "__dd_flags" } - { "__darwin_pthread_mutex_t" "__dd_lock" } - { "void*" "__dd_td" } ; - - -! #define DIRSIZ(dp) \ - ! ((sizeof (struct direct) - (MAXNAMLEN+1)) + (((dp)->d_namlen+1 + 3) &~ 3)) - -! __DARWIN_STRUCT_DIRENTRY { \ - : __DARWIN_MAXPATHLEN 1024 ; inline : __DARWIN_MAXNAMELEN 255 ; inline : __DARWIN_MAXNAMELEN+1 255 ; inline diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index ab49cd3f45..d7af214a49 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -160,7 +160,7 @@ FUNCTION: int pipe ( int* filedes ) ; FUNCTION: void* popen ( char* command, char* type ) ; FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; -FUNCTION: int readdir_r ( DIR* dirp, dirent* entry, dirent** result ) ; +FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ; FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; From 548ee091d986ecf060ecc2ac07d892c84d1fb15c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 14:21:12 -0500 Subject: [PATCH 135/224] ffi work, add dirent struct for linux --- basis/unix/bsd/bsd.factor | 2 -- basis/unix/linux/fs/fs.factor | 4 +--- basis/unix/linux/linux.factor | 7 +++++++ basis/unix/stat/linux/linux.factor | 7 ++----- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index 7bbf2b4fdf..bf426ad867 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -3,8 +3,6 @@ USING: alien.syntax combinators system vocabs.loader ; IN: unix -! FreeBSD - : MAXPATHLEN 1024 ; inline : O_RDONLY HEX: 0000 ; inline diff --git a/basis/unix/linux/fs/fs.factor b/basis/unix/linux/fs/fs.factor index 475d0290a6..6cb9f68934 100644 --- a/basis/unix/linux/fs/fs.factor +++ b/basis/unix/linux/fs/fs.factor @@ -1,6 +1,4 @@ - USING: alien.syntax ; - IN: unix.linux.fs : MS_RDONLY 1 ; ! Mount read-only. @@ -22,4 +20,4 @@ FUNCTION: int mount ! FUNCTION: int umount2 ( char* file, int flags ) ; -FUNCTION: int umount ( char* file ) ; \ No newline at end of file +FUNCTION: int umount ( char* file ) ; diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 457d96c7d8..7a77dc9316 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -92,6 +92,13 @@ C-STRUCT: passwd { "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 diff --git a/basis/unix/stat/linux/linux.factor b/basis/unix/stat/linux/linux.factor index 2f4b6174d9..1df6865d41 100644 --- a/basis/unix/stat/linux/linux.factor +++ b/basis/unix/stat/linux/linux.factor @@ -1,11 +1,8 @@ - USING: layouts combinators vocabs.loader ; - IN: unix.stat cell-bits - { +{ { 32 [ "unix.stat.linux.32" require ] } { 64 [ "unix.stat.linux.64" require ] } - } -case +} case From cc1365390a54c56b7ad248b0e4e3e1f6bb53fca5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 14:33:45 -0500 Subject: [PATCH 136/224] dirent and type definitions --- basis/unix/bsd/freebsd/freebsd.factor | 17 +++++++ basis/unix/bsd/macosx/macosx.factor | 71 ++++++++++++++------------- basis/unix/bsd/netbsd/netbsd.factor | 17 +++++++ basis/unix/bsd/openbsd/openbsd.factor | 18 +++++++ 4 files changed, 89 insertions(+), 34 deletions(-) diff --git a/basis/unix/bsd/freebsd/freebsd.factor b/basis/unix/bsd/freebsd/freebsd.factor index 34f0f0429c..3af6358e94 100644 --- a/basis/unix/bsd/freebsd/freebsd.factor +++ b/basis/unix/bsd/freebsd/freebsd.factor @@ -13,6 +13,23 @@ C-STRUCT: addrinfo { "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" } ; + +: 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 + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index 6270dc53b1..de2fd4caf0 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -13,6 +13,43 @@ C-STRUCT: addrinfo { "void*" "addr" } { "addrinfo*" "next" } ; +: _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" } ; + +: 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 + + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline @@ -117,37 +154,3 @@ C-STRUCT: addrinfo : ETIME 101 ; inline : EOPNOTSUPP 102 ; inline : ENOPOLICY 103 ; inline - -: _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" } ; - -: __PTHREAD_MUTEX_SIZE__ 40 ; inline - -C-STRUCT: _opaque_pthread_mutex_t - { "long" "__sig" } - { { "char" __PTHREAD_MUTEX_SIZE__ } "__opaque" } ; - -TYPEDEF: _opaque_pthread_mutex_t* __darwin_pthread_mutex_t - -: __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" } ; diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index ca42b7840c..6c45811d51 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -13,6 +13,23 @@ C-STRUCT: addrinfo { "void*" "addr" } { "addrinfo*" "next" } ; +C-STRUCT: dirent + { "ino_t" "d_fileno" } + { "__uint16_t" "d_reclen" } + { "__uint16_t" "d_namlen" } + { "__uint8_t" "d_type" } + { { "char" 512 } "d_name" } ; + +: 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 + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/bsd/openbsd/openbsd.factor b/basis/unix/bsd/openbsd/openbsd.factor index 31025a47e9..f4a7863fdd 100644 --- a/basis/unix/bsd/openbsd/openbsd.factor +++ b/basis/unix/bsd/openbsd/openbsd.factor @@ -13,6 +13,24 @@ C-STRUCT: addrinfo { "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" } ; + +: 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 + + + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline From 60941f4eb5ab32b29af85fa39942ad515b0f4b70 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 14:56:22 -0500 Subject: [PATCH 137/224] fix types --- basis/unix/types/linux/linux.factor | 9 ++------- basis/unix/types/netbsd/netbsd.factor | 13 ------------- basis/unix/types/openbsd/openbsd.factor | 13 ------------- basis/unix/types/types.factor | 5 +++++ 4 files changed, 7 insertions(+), 33 deletions(-) diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index 8822366a3a..65731335d8 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -1,10 +1,6 @@ - USING: alien.syntax ; - IN: unix.types -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - TYPEDEF: ulonglong __uquad_type TYPEDEF: ulong __ulongword_type TYPEDEF: long __sword_type @@ -13,10 +9,9 @@ TYPEDEF: long __slongword_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 @@ -26,4 +21,4 @@ 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 diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor index 5b54928d95..3982d1e9f9 100644 --- a/basis/unix/types/netbsd/netbsd.factor +++ b/basis/unix/types/netbsd/netbsd.factor @@ -3,19 +3,6 @@ IN: unix.types ! 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 diff --git a/basis/unix/types/openbsd/openbsd.factor b/basis/unix/types/openbsd/openbsd.factor index a07e6f1c6a..8938afa936 100644 --- a/basis/unix/types/openbsd/openbsd.factor +++ b/basis/unix/types/openbsd/openbsd.factor @@ -3,19 +3,6 @@ IN: unix.types ! 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 diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 69d07a07f1..968b234b9f 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -16,6 +16,11 @@ 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 From d4916e9fcba15e7ae38aa8bd774a2e8ec0b9e4b1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 15:03:29 -0500 Subject: [PATCH 138/224] fix type --- basis/unix/types/linux/linux.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index 65731335d8..f32d8a23c4 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -17,6 +17,7 @@ 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 From d4fcc10aac34fa980d0e3b7d891376160a76ee32 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 15:29:59 -0500 Subject: [PATCH 139/224] fix windows directory code --- basis/io/windows/files/files.factor | 36 +++++++++++++++++++++++++---- basis/windows/errors/errors.factor | 2 +- 2 files changed, 33 insertions(+), 5 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index dbe16f0a6e..992d1f8d6a 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -1,10 +1,11 @@ ! 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 ; IN: io.windows.files : open-file ( path access-mode create-mode flags -- handle ) @@ -113,8 +114,35 @@ M: windows delete-directory ( path -- ) 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" tuck + FindFirstFile + [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep ; + +: find-next-file ( path -- WIN32_FIND_DATA/f ) + "WIN32_FIND_DATA" 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+ diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 31a7cd8c09..bd938fdbad 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -2,9 +2,9 @@ USING: kernel ; IN: windows.errors : ERROR_SUCCESS 0 ; inline +: ERROR_NO_MORE_FILES 18 ; inline : ERROR_HANDLE_EOF 38 ; inline : ERROR_BROKEN_PIPE 109 ; inline : ERROR_ENVVAR_NOT_FOUND 203 ; inline : ERROR_IO_INCOMPLETE 996 ; inline : ERROR_IO_PENDING 997 ; inline - From c9b15e98794a1bbd92c21051716b8cd654fbff6f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 15:41:04 -0500 Subject: [PATCH 140/224] fix logging --- basis/logging/server/server.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index d13ae616be..47656e8655 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -83,7 +83,7 @@ SYMBOL: log-files : (rotate-logs) ( -- ) (close-logs) - log-root directory [ drop rotate-log ] assoc-each ; + log-root directory-files [ rotate-log ] each ; : log-server-loop ( -- ) receive unclip { From ef51d1bbf058e8fee294ad7e8e45ca40e4e057b4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 15:52:59 -0500 Subject: [PATCH 141/224] refactoring --- extra/html/parser/analyzer/analyzer.factor | 93 +++++++++++++--------- 1 file changed, 57 insertions(+), 36 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 095e3c3246..8d7a92b0d9 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -3,7 +3,7 @@ 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 ; @@ -19,35 +19,34 @@ 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' ) [ @@ -61,27 +60,40 @@ TUPLE: link attributes clickable ; [ [ [ blank? ] trim ] change-text ] when ] map ; -: find-by-id ( id vector -- vector ) - [ attributes>> "id" swap at = ] with filter ; +: find-by-id ( vector id -- vector' ) + '[ attributes>> "id" at _ = ] find ; + +: find-by-class ( vector id -- vector' ) + '[ attributes>> "class" at _ = ] find ; -: find-by-class ( id vector -- vector ) - [ attributes>> "class" swap at = ] with filter ; +: find-by-name ( vector string -- vector ) + >lower '[ name>> _ = ] find ; -: find-by-name ( str vector -- vector ) - [ >lower ] dip [ name>> = ] with filter ; +: 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 ( key vector -- vector ) - [ >lower ] dip - [ attributes>> at ] with filter - sift ; +: find-by-attribute-key ( vector key -- vector' ) + >lower + [ attributes>> at _ = ] filter sift ; -: find-by-attribute-key-value ( value key vector -- vector ) - [ >lower ] dip +: 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 ) @@ -121,9 +133,9 @@ TUPLE: link attributes clickable ; 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 @@ -150,3 +162,12 @@ TUPLE: link attributes clickable ; : 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 ; From 12a721869ca8da848cdc2199f049a72bac59d510 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 16:33:09 -0500 Subject: [PATCH 142/224] directory usage --- extra/ftp/ftp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor index b2b5ebc9aa..1fd97df6d5 100644 --- a/extra/ftp/ftp.factor +++ b/extra/ftp/ftp.factor @@ -59,5 +59,5 @@ TUPLE: ftp-response n strings parsed ; 3array " " join ; : directory-list ( -- seq ) - "" directory keys + "" directory-files [ [ link-info ] keep file-info>string ] map ; From f324ceb2b074d173e7e17a91375cc54904dbaf17 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 16:50:11 -0500 Subject: [PATCH 143/224] remove some macroz --- vm/os-freebsd.h | 3 --- vm/os-linux.h | 3 --- vm/os-macosx.h | 2 -- vm/os-openbsd.h | 2 -- vm/os-solaris.h | 2 -- vm/platform.h | 2 -- 6 files changed, 14 deletions(-) delete mode 100644 vm/os-openbsd.h delete mode 100644 vm/os-solaris.h diff --git a/vm/os-freebsd.h b/vm/os-freebsd.h index c535e2d71f..617a6686c2 100644 --- a/vm/os-freebsd.h +++ b/vm/os-freebsd.h @@ -7,6 +7,3 @@ extern int getosreldate(void); #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) diff --git a/vm/os-linux.h b/vm/os-linux.h index 78ecbafd35..8e78595687 100644 --- a/vm/os-linux.h +++ b/vm/os-linux.h @@ -1,8 +1,5 @@ #include -#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) -#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) - int inotify_init(void); int inotify_add_watch(int fd, const char *name, u32 mask); int inotify_rm_watch(int fd, u32 wd); diff --git a/vm/os-macosx.h b/vm/os-macosx.h index b9686a5a85..216212e973 100644 --- a/vm/os-macosx.h +++ b/vm/os-macosx.h @@ -1,8 +1,6 @@ #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); diff --git a/vm/os-openbsd.h b/vm/os-openbsd.h deleted file mode 100644 index af47f7bcea..0000000000 --- a/vm/os-openbsd.h +++ /dev/null @@ -1,2 +0,0 @@ -#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) -#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) diff --git a/vm/os-solaris.h b/vm/os-solaris.h deleted file mode 100644 index 788a78090b..0000000000 --- a/vm/os-solaris.h +++ /dev/null @@ -1,2 +0,0 @@ -#define UNKNOWN_TYPE_P(file) 1 -#define DIRECTORY_P(file) 0 diff --git a/vm/platform.h b/vm/platform.h index 2f97cb9d1d..21336e88bb 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -55,7 +55,6 @@ #endif #elif defined(__OpenBSD__) #define FACTOR_OS_STRING "openbsd" - #include "os-openbsd.h" #if defined(FACTOR_X86) #include "os-openbsd-x86.32.h" @@ -102,7 +101,6 @@ #error "Unsupported Solaris flavor" #endif - #include "os-solaris.h" #else #error "Unsupported OS" #endif From 0ad47e21c803b9771d5f4e3fc5ea885f3571310e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 16:50:34 -0500 Subject: [PATCH 144/224] using bug --- basis/io/windows/nt/launcher/test/env.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/io/windows/nt/launcher/test/env.factor b/basis/io/windows/nt/launcher/test/env.factor index a0015f7ea2..503ca7d018 100644 --- a/basis/io/windows/nt/launcher/test/env.factor +++ b/basis/io/windows/nt/launcher/test/env.factor @@ -1,3 +1,4 @@ -USE: system -USE: prettyprint -os-envs . +USE: system +USE: prettyprint +USE: environment +os-envs . From f40fc145de0051bdf5bb98da89e66472874f8650 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 23:23:17 -0500 Subject: [PATCH 145/224] remove openbsd shiz --- basis/io/unix/files/files.factor | 6 +----- basis/io/unix/files/openbsd/authors.txt | 1 - basis/io/unix/files/openbsd/openbsd.factor | 7 ------- basis/io/unix/files/openbsd/tags.txt | 1 - 4 files changed, 1 insertion(+), 14 deletions(-) delete mode 100644 basis/io/unix/files/openbsd/authors.txt delete mode 100644 basis/io/unix/files/openbsd/openbsd.factor delete mode 100644 basis/io/unix/files/openbsd/tags.txt diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 2b85420ee9..67da640b71 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -142,9 +142,7 @@ os { [ opendir dup [ (io-error) ] unless ] dip dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline -HOOK: find-next-file os ( DIR* -- byte-array ) - -M: unix find-next-file ( DIR* -- byte-array ) +: find-next-file ( DIR* -- byte-array ) "dirent" f [ readdir_r 0 = [ (io-error) ] unless ] 2keep @@ -161,8 +159,6 @@ M: unix (directory-entries) ( path -- seq ) [ drop ] produce ] with-unix-directory ; -os openbsd = [ "io.unix.files.openbsd" require ] when - Date: Mon, 20 Oct 2008 23:25:40 -0500 Subject: [PATCH 146/224] add freebsd and openbsd structs --- basis/unix/statfs/freebsd/authors.txt | 1 + basis/unix/statfs/freebsd/freebsd.factor | 20 +++++++++++++++ basis/unix/statfs/freebsd/tags.txt | 1 + basis/unix/statfs/openbsd/32/32.factor | 26 +++++++++++++++++++ basis/unix/statfs/openbsd/32/authors.txt | 1 + basis/unix/statfs/openbsd/32/tags.txt | 1 + basis/unix/statfs/openbsd/64/64.factor | 32 ++++++++++++++++++++++++ basis/unix/statfs/openbsd/64/authors.txt | 1 + basis/unix/statfs/openbsd/64/tags.txt | 1 + basis/unix/statfs/openbsd/authors.txt | 1 + basis/unix/statfs/openbsd/openbsd.factor | 4 +++ basis/unix/statfs/openbsd/tags.txt | 1 + 12 files changed, 90 insertions(+) create mode 100644 basis/unix/statfs/freebsd/authors.txt create mode 100644 basis/unix/statfs/freebsd/freebsd.factor create mode 100644 basis/unix/statfs/freebsd/tags.txt create mode 100644 basis/unix/statfs/openbsd/32/32.factor create mode 100644 basis/unix/statfs/openbsd/32/authors.txt create mode 100644 basis/unix/statfs/openbsd/32/tags.txt create mode 100644 basis/unix/statfs/openbsd/64/64.factor create mode 100644 basis/unix/statfs/openbsd/64/authors.txt create mode 100644 basis/unix/statfs/openbsd/64/tags.txt create mode 100644 basis/unix/statfs/openbsd/authors.txt create mode 100644 basis/unix/statfs/openbsd/openbsd.factor create mode 100644 basis/unix/statfs/openbsd/tags.txt diff --git a/basis/unix/statfs/freebsd/authors.txt b/basis/unix/statfs/freebsd/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/freebsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor new file mode 100644 index 0000000000..f47f71f523 --- /dev/null +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel ; +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" } ; diff --git a/basis/unix/statfs/freebsd/tags.txt b/basis/unix/statfs/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/openbsd/32/32.factor b/basis/unix/statfs/openbsd/32/32.factor new file mode 100644 index 0000000000..aa1e8425dc --- /dev/null +++ b/basis/unix/statfs/openbsd/32/32.factor @@ -0,0 +1,26 @@ +! 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" } ; diff --git a/basis/unix/statfs/openbsd/32/authors.txt b/basis/unix/statfs/openbsd/32/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/openbsd/32/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/openbsd/32/tags.txt b/basis/unix/statfs/openbsd/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/openbsd/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/openbsd/64/64.factor b/basis/unix/statfs/openbsd/64/64.factor new file mode 100644 index 0000000000..fd40fba033 --- /dev/null +++ b/basis/unix/statfs/openbsd/64/64.factor @@ -0,0 +1,32 @@ +! 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" } ; diff --git a/basis/unix/statfs/openbsd/64/authors.txt b/basis/unix/statfs/openbsd/64/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/openbsd/64/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/openbsd/64/tags.txt b/basis/unix/statfs/openbsd/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/openbsd/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/openbsd/authors.txt b/basis/unix/statfs/openbsd/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/openbsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor new file mode 100644 index 0000000000..011ccb87d1 --- /dev/null +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: ; +IN: unix.statfs.openbsd diff --git a/basis/unix/statfs/openbsd/tags.txt b/basis/unix/statfs/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/openbsd/tags.txt @@ -0,0 +1 @@ +unportable From 76e460860d232b961a13dc866ada5f00452a8f06 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 23:43:36 -0500 Subject: [PATCH 147/224] moving stuff around --- basis/unix/statfs/linux/linux-tests.factor | 4 - basis/unix/statfs/linux/linux.factor | 7 +- basis/unix/statfs/macosx/macosx-tests.factor | 4 - basis/unix/statfs/macosx/macosx.factor | 112 +++++++++++++++++++ basis/unix/statfs/netbsd/netbsd-tests.factor | 4 - 5 files changed, 118 insertions(+), 13 deletions(-) delete mode 100644 basis/unix/statfs/linux/linux-tests.factor delete mode 100644 basis/unix/statfs/macosx/macosx-tests.factor delete mode 100644 basis/unix/statfs/netbsd/netbsd-tests.factor diff --git a/basis/unix/statfs/linux/linux-tests.factor b/basis/unix/statfs/linux/linux-tests.factor deleted file mode 100644 index 549905f081..0000000000 --- a/basis/unix/statfs/linux/linux-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test unix.statfs.linux ; -IN: unix.statfs.linux.tests diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 44c32fd53d..367d32d520 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -1,9 +1,14 @@ ! 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 ; +math accessors system unix io.backend layouts vocabs.loader ; IN: unix.statfs.linux +<< cell-bits { + { 32 [ "unix.statfs.linux.32" require ] } + { 64 [ "unix.statfs.linux.64" require ] } +} case >> + TUPLE: linux-file-system-info < file-system-info type bsize blocks bfree bavail files ffree fsid namelen frsize spare ; diff --git a/basis/unix/statfs/macosx/macosx-tests.factor b/basis/unix/statfs/macosx/macosx-tests.factor deleted file mode 100644 index 35625e2198..0000000000 --- a/basis/unix/statfs/macosx/macosx-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test unix.statfs.macosx ; -IN: unix.statfs.macosx.tests diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 60fb1658c5..82f999ea5a 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -5,6 +5,118 @@ kernel sequences unix.stat accessors unix combinators math grouping system unix.statfs io.files io.backend alien.strings ; 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 flags filesystem-subtype diff --git a/basis/unix/statfs/netbsd/netbsd-tests.factor b/basis/unix/statfs/netbsd/netbsd-tests.factor deleted file mode 100644 index be100c1cb6..0000000000 --- a/basis/unix/statfs/netbsd/netbsd-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test unix.statfs.netbsd ; -IN: unix.statfs.netbsd.tests From 236aaf4a35b4f356987565153f1b1857379e9285 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 23:43:50 -0500 Subject: [PATCH 148/224] more moving --- basis/unix/stat/linux/32/32.factor | 13 ---- basis/unix/stat/linux/64/64.factor | 19 ----- basis/unix/stat/macosx/macosx.factor | 111 --------------------------- basis/unix/types/linux/linux.factor | 4 + 4 files changed, 4 insertions(+), 143 deletions(-) diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor index 00a6239916..ded06595de 100644 --- a/basis/unix/stat/linux/32/32.factor +++ b/basis/unix/stat/linux/32/32.factor @@ -22,21 +22,8 @@ C-STRUCT: stat { "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 ; - -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" } ; diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index b9d48066fb..f406b2ccee 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -28,22 +28,3 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; : stat ( pathname buf -- int ) 1 -rot __xstat ; : lstat ( pathname buf -- int ) 1 -rot __lxstat ; - -TYPEDEF: ssize_t __SWORD_TYPE -TYPEDEF: ulonglong __fsblkcnt64_t -TYPEDEF: ulonglong __fsfilcnt64_t - -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 ) ; diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index 49b6709847..2656ec71e1 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -31,114 +31,3 @@ FUNCTION: int lstat64 ( char* pathname, stat* buf ) ; : stat ( path buf -- n ) stat64 ; : lstat ( path buf -- n ) lstat64 ; - -: 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 ) ; diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index f32d8a23c4..bf5d4b7f1d 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -23,3 +23,7 @@ TYPEDEF: __slongword_type blkcnt_t TYPEDEF: __sword_type ssize_t TYPEDEF: __s32_type pid_t TYPEDEF: __slongword_type time_t + +TYPEDEF: ssize_t __SWORD_TYPE +TYPEDEF: ulonglong __fsblkcnt64_t +TYPEDEF: ulonglong __fsfilcnt64_t From bfeec2e9aa07a09b59800711f98205507dd9dd42 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 00:52:04 -0500 Subject: [PATCH 149/224] ready to push now, expect some more bugs.. --- basis/unix/statfs/freebsd/freebsd.factor | 30 +++++++++++++++ basis/unix/statfs/linux/32/32.factor | 15 ++++++++ basis/unix/statfs/linux/32/authors.txt | 1 + basis/unix/statfs/linux/32/tags.txt | 1 + basis/unix/statfs/linux/64/64.factor | 19 ++++++++++ basis/unix/statfs/linux/64/authors.txt | 1 + basis/unix/statfs/linux/64/tags.txt | 1 + basis/unix/statfs/linux/linux.factor | 2 +- basis/unix/statfs/openbsd/openbsd.factor | 47 +++++++++++++++++++++++- basis/unix/statfs/statfs.factor | 6 +-- 10 files changed, 118 insertions(+), 5 deletions(-) create mode 100644 basis/unix/statfs/linux/32/32.factor create mode 100644 basis/unix/statfs/linux/32/authors.txt create mode 100644 basis/unix/statfs/linux/32/tags.txt create mode 100644 basis/unix/statfs/linux/64/64.factor create mode 100644 basis/unix/statfs/linux/64/authors.txt create mode 100644 basis/unix/statfs/linux/64/tags.txt diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index f47f71f523..508047ccc5 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -18,3 +18,33 @@ C-STRUCT: statvfs { "ulong" "f_frsize" } { "ulong" "f_fsid" } { "ulong" "f_namemax" } ; + + +TUPLE: freebsd-file-system-info < file-system-info +bavail bfree blocks favail ffree ffiles +bsize flag frsize fsid namemax ; + +: statfs>file-system-info ( struct -- statfs ) + [ \ freebsd-file-system-info new ] dip + { + [ + [ statfs64-f_bsize ] + [ statfs64-f_bavail ] bi * >>free-space + ] + [ statfs64-f_bavail >>bavail ] + [ statfs64-f_bfree >>bfree ] + [ statfs64-f_blocks >>blocks ] + [ statfs64-f_favail >>favail ] + [ statfs64-f_ffree >>ffree ] + [ statfs64-f_files >>files ] + [ statfs64-f_bsize >>bsize ] + [ statfs64-f_flag >>flag ] + [ statfs64-f_frsize >>frsize ] + [ statfs64-f_fsid >>fsid ] + [ statfs64-f_namelen >>namelen ] + } cleave ; + +M: freebsd file-system-info ( path -- byte-array ) + normalize-path + "statvfs" tuck statvfs io-error + statfs>file-system-info ; diff --git a/basis/unix/statfs/linux/32/32.factor b/basis/unix/statfs/linux/32/32.factor new file mode 100644 index 0000000000..86fb61e83d --- /dev/null +++ b/basis/unix/statfs/linux/32/32.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax unix.types ; +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" } ; diff --git a/basis/unix/statfs/linux/32/authors.txt b/basis/unix/statfs/linux/32/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/linux/32/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/linux/32/tags.txt b/basis/unix/statfs/linux/32/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/linux/32/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/linux/64/64.factor b/basis/unix/statfs/linux/64/64.factor new file mode 100644 index 0000000000..20688680fb --- /dev/null +++ b/basis/unix/statfs/linux/64/64.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax unix.types ; +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 ) ; diff --git a/basis/unix/statfs/linux/64/authors.txt b/basis/unix/statfs/linux/64/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/linux/64/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/linux/64/tags.txt b/basis/unix/statfs/linux/64/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/linux/64/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 367d32d520..b938062e55 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -1,7 +1,7 @@ ! 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 ; +math accessors system unix io.backend layouts vocabs.loader ; IN: unix.statfs.linux << cell-bits { diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor index 011ccb87d1..d07d159192 100644 --- a/basis/unix/statfs/openbsd/openbsd.factor +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -1,4 +1,49 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: ; +USING: alien.syntax accessors combinators kernel 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 + +TUPLE: openbsd-file-system-info < file-system-info +bsize frsize blocks bfree bavail files ffree favail +fsid flag namemax ; + +: statfs>file-system-info ( struct -- statfs ) + [ \ openbsd-file-system-info new ] dip + { + [ + [ statfs64-f_bsize ] + [ statfs64-f_bavail ] bi * >>free-space + ] + [ statfs64-f_bsize >>bsize ] + [ statfs64-f_frsize >>frsize ] + [ statfs64-f_blocks >>blocks ] + [ statfs64-f_bfree >>bfree ] + [ statfs64-f_bavail >>bavail ] + [ statfs64-f_files >>files ] + [ statfs64-f_ffree >>ffree ] + [ statfs64-f_favail >>favail ] + [ statfs64-f_fsid >>fsid ] + [ statfs64-f_flag >>flag ] + [ statfs64-f_namelen >>namelen ] + } cleave ; + +M: openbsd file-system-info ( path -- byte-array ) + normalize-path + "statvfs" tuck statvfs io-error + statfs>file-system-info ; diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor index 0d99b57faf..8ac5a46883 100644 --- a/basis/unix/statfs/statfs.factor +++ b/basis/unix/statfs/statfs.factor @@ -25,7 +25,7 @@ TUPLE: file-system-info root-directory total-free-size total-size ; 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 ] } + { freebsd [ "unix.statfs.freebsd" require ] } + { netbsd [ "unix.statfs.netbsd" require ] } + { openbsd [ "unix.statfs.openbsd" require ] } } case From 4ff38b2148ea23db611ea55a7e4730ab12a64cde Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 01:05:41 -0500 Subject: [PATCH 150/224] pull in unix.statfs in the io code --- basis/io/unix/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 67da640b71..9ebfdaaa5a 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -6,7 +6,7 @@ math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system io.files.private destructors vocabs.loader calendar.unix unix.stat alien.c-types arrays unix.users unix.groups -environment fry io.encodings.utf8 alien.strings ; +environment fry io.encodings.utf8 alien.strings unix.statfs ; IN: io.unix.files M: unix cwd ( -- path ) From d5c33a865f8c2361470d06f662f0da0f3ca96ff2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 01:07:07 -0500 Subject: [PATCH 151/224] usings --- basis/unix/statfs/macosx/macosx.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 82f999ea5a..8e61d22d24 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -2,7 +2,8 @@ ! 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 ; +grouping system unix.statfs io.files io.backend alien.strings +math.bitwise alien.syntax ; IN: unix.statfs.macosx : MNT_RDONLY HEX: 00000001 ; inline From 34fa12a737c81683f5c08d18766da51ba0e3c83b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 01:08:36 -0500 Subject: [PATCH 152/224] tabs --- basis/unix/statfs/freebsd/freebsd.factor | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index 508047ccc5..2219ba3e66 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -7,17 +7,17 @@ IN: unix.statfs.freebsd : 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" } ; + { "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" } ; TUPLE: freebsd-file-system-info < file-system-info From b9d23a2ce7703f07c229032f937707353508de96 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 01:17:49 -0500 Subject: [PATCH 153/224] more ffi work --- basis/unix/statfs/freebsd/freebsd.factor | 30 ++++++++++++----------- basis/unix/statfs/netbsd/netbsd.factor | 4 ++- basis/unix/statfs/openbsd/openbsd.factor | 31 +++++++++++++----------- basis/unix/types/netbsd/netbsd.factor | 6 ----- basis/unix/types/types.factor | 5 ++++ 5 files changed, 41 insertions(+), 35 deletions(-) diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index 2219ba3e66..bd84aec444 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel ; +USING: alien.syntax kernel unix io.files math accessors +combinators system io.backend alien.c-types ; IN: unix.statfs.freebsd : ST_RDONLY 1 ; inline @@ -19,6 +20,7 @@ C-STRUCT: statvfs { "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 ffiles @@ -28,20 +30,20 @@ bsize flag frsize fsid namemax ; [ \ freebsd-file-system-info new ] dip { [ - [ statfs64-f_bsize ] - [ statfs64-f_bavail ] bi * >>free-space + [ statvfs-f_bsize ] + [ statvfs-f_bavail ] bi * >>free-space ] - [ statfs64-f_bavail >>bavail ] - [ statfs64-f_bfree >>bfree ] - [ statfs64-f_blocks >>blocks ] - [ statfs64-f_favail >>favail ] - [ statfs64-f_ffree >>ffree ] - [ statfs64-f_files >>files ] - [ statfs64-f_bsize >>bsize ] - [ statfs64-f_flag >>flag ] - [ statfs64-f_frsize >>frsize ] - [ statfs64-f_fsid >>fsid ] - [ statfs64-f_namelen >>namelen ] + [ 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 ) diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index c58d6e1a0d..6b89f5b394 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax kernel io.files unix.stat math unix combinators system io.backend accessors alien.c-types -io.encodings.utf8 alien.strings ; +io.encodings.utf8 alien.strings unix.types ; IN: unix.statfs.netbsd : _VFS_NAMELEN 32 ; inline @@ -34,6 +34,8 @@ C-STRUCT: statvfs { { "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 diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor index d07d159192..b5b5a0468b 100644 --- a/basis/unix/statfs/openbsd/openbsd.factor +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax accessors combinators kernel io.files ; +USING: alien.syntax accessors combinators kernel io.files +unix.types math system io.backend alien.c-types unix ; IN: unix.statfs.openbsd C-STRUCT: statvfs @@ -19,6 +20,8 @@ C-STRUCT: statvfs : 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 ; @@ -27,20 +30,20 @@ fsid flag namemax ; [ \ openbsd-file-system-info new ] dip { [ - [ statfs64-f_bsize ] - [ statfs64-f_bavail ] bi * >>free-space + [ statvfs-f_bsize ] + [ statvfs-f_bavail ] bi * >>free-space ] - [ statfs64-f_bsize >>bsize ] - [ statfs64-f_frsize >>frsize ] - [ statfs64-f_blocks >>blocks ] - [ statfs64-f_bfree >>bfree ] - [ statfs64-f_bavail >>bavail ] - [ statfs64-f_files >>files ] - [ statfs64-f_ffree >>ffree ] - [ statfs64-f_favail >>favail ] - [ statfs64-f_fsid >>fsid ] - [ statfs64-f_flag >>flag ] - [ statfs64-f_namelen >>namelen ] + [ 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 ) diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor index d69d498704..b5b0ffe661 100644 --- a/basis/unix/types/netbsd/netbsd.factor +++ b/basis/unix/types/netbsd/netbsd.factor @@ -17,12 +17,6 @@ TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t -TYPEDEF: __uint64_t fsblkcnt_t -TYPEDEF: fsblkcnt_t __fsblkcnt_t - -TYPEDEF: __uint64_t fsfilcnt_t -TYPEDEF: fsfilcnt_t __fsfilcnt_t - cell-bits { { 32 [ "unix.types.netbsd.32" require ] } { 64 [ "unix.types.netbsd.64" require ] } diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 968b234b9f..51db6f5da0 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -6,6 +6,11 @@ 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: char int8_t TYPEDEF: short int16_t TYPEDEF: int int32_t From dfef28e71593e69baa0b8b4a3abfdfe6641b62fd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 01:27:15 -0500 Subject: [PATCH 154/224] make a word generic --- basis/unix/statfs/freebsd/freebsd.factor | 4 ++-- basis/unix/statfs/linux/linux.factor | 4 ++-- basis/unix/statfs/macosx/macosx.factor | 4 ++-- basis/unix/statfs/netbsd/netbsd.factor | 4 ++-- basis/unix/statfs/openbsd/openbsd.factor | 4 ++-- core/io/files/files.factor | 3 +++ 6 files changed, 13 insertions(+), 10 deletions(-) diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index bd84aec444..6c5a45c4d2 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -26,7 +26,7 @@ TUPLE: freebsd-file-system-info < file-system-info bavail bfree blocks favail ffree ffiles bsize flag frsize fsid namemax ; -: statfs>file-system-info ( struct -- statfs ) +M: freebsd >file-system-info ( struct -- statfs ) [ \ freebsd-file-system-info new ] dip { [ @@ -49,4 +49,4 @@ bsize flag frsize fsid namemax ; M: freebsd file-system-info ( path -- byte-array ) normalize-path "statvfs" tuck statvfs io-error - statfs>file-system-info ; + >file-system-info ; diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index b938062e55..7a407da78b 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -13,7 +13,7 @@ TUPLE: linux-file-system-info < file-system-info type bsize blocks bfree bavail files ffree fsid namelen frsize spare ; -: statfs>file-system-info ( struct -- statfs ) +M: linux >file-system-info ( struct -- statfs ) [ \ linux-file-system-info new ] dip { [ @@ -36,4 +36,4 @@ namelen frsize spare ; M: linux file-system-info ( path -- byte-array ) normalize-path "statfs64" tuck statfs64 io-error - statfs>file-system-info ; + >file-system-info ; diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 8e61d22d24..4bd9f55132 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -128,7 +128,7 @@ M: macosx mounted* ( -- array ) [ *void* ] dip "statfs64" heap-size [ * memory>byte-array ] keep group ; -: statfs64>file-system-info ( byte-array -- file-system-info ) +M: macosx >file-system-info ( byte-array -- file-system-info ) [ \ macosx-file-system-info new ] dip { [ @@ -162,4 +162,4 @@ M: macosx mounted* ( -- array ) M: macosx file-system-info ( path -- file-system-info ) normalize-path "statfs64" tuck statfs64 io-error - statfs64>file-system-info ; + >file-system-info ; diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index 6b89f5b394..dd1ccd4c9a 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -43,7 +43,7 @@ files ffree sync-reads sync-writes async-reads async-writes fsidx fsid namemax owner spare fstype mnotonname mntfromname file-system-type-name mount-from ; -: statvfs>file-system-info ( byte-array -- netbsd-file-system-info ) +M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info ) [ \ netbsd-file-system-info new ] dip { [ @@ -75,4 +75,4 @@ file-system-type-name mount-from ; M: netbsd file-system-info normalize-path "statvfs" tuck statvfs io-error - statvfs>file-system-info ; + >file-system-info ; diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor index b5b5a0468b..a64b60a078 100644 --- a/basis/unix/statfs/openbsd/openbsd.factor +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -26,7 +26,7 @@ TUPLE: openbsd-file-system-info < file-system-info bsize frsize blocks bfree bavail files ffree favail fsid flag namemax ; -: statfs>file-system-info ( struct -- statfs ) +M: openbsd >file-system-info ( struct -- statfs ) [ \ openbsd-file-system-info new ] dip { [ @@ -49,4 +49,4 @@ fsid flag namemax ; M: openbsd file-system-info ( path -- byte-array ) normalize-path "statvfs" tuck statvfs io-error - statfs>file-system-info ; + >file-system-info ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1f6a48b50e..cfb90d58a5 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -188,6 +188,9 @@ TUPLE: file-system-info mount-on free-space ; HOOK: file-system-info os ( path -- file-system-info ) +HOOK: >file-system-info os ( struct -- statfs ) + + Date: Tue, 21 Oct 2008 02:27:39 -0500 Subject: [PATCH 155/224] try to add winnt space-free --- basis/io/windows/files/files.factor | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 992d1f8d6a..9ddc2b1eae 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -246,6 +246,20 @@ M: winnt file-info ( path -- info ) M: winnt link-info ( path -- info ) file-info ; +TUPLE: winnt-file-system-info < file-system-info +total-bytes total-free-bytes ; + +M: winnt file-system-info ( path -- file-system-info ) + normalize-path + "ULARGE_INTEGER" + "ULARGE_INTEGER" + "ULARGE_INTEGER" + [ GetDiskFreeSpaceEx ] 3keep + \ winnt-file-system-info new + swap >>total-free-bytes + swap >>total-bytes + swap >>free-space ; + : file-times ( path -- timestamp timestamp timestamp ) [ normalize-path open-existing &dispose handle>> From 623a21256aa5de64f293c3837786c35abe4c2f76 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 17:41:46 -0500 Subject: [PATCH 156/224] win32 ffi work --- basis/windows/kernel32/kernel32.factor | 3 ++- basis/windows/types/types.factor | 2 ++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index f19561cda3..dfac6a5236 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -928,7 +928,8 @@ FUNCTION: HANDLE GetCurrentThread ( ) ; ! 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 diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index b1d8914be9..0ac8409016 100644 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -62,7 +62,9 @@ TYPEDEF: ulonglong ULONGLONG 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_t* LPCSTR TYPEDEF: wchar_t* LPWSTR From b9e5c98ce77da2e2a5cc18a51c1ea4a3f0c3ad79 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 17:43:22 -0500 Subject: [PATCH 157/224] fix file-system-info --- basis/io/windows/files/files.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 9ddc2b1eae..be8d131158 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -254,11 +254,11 @@ M: winnt file-system-info ( path -- file-system-info ) "ULARGE_INTEGER" "ULARGE_INTEGER" "ULARGE_INTEGER" - [ GetDiskFreeSpaceEx ] 3keep + [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep \ winnt-file-system-info new - swap >>total-free-bytes - swap >>total-bytes - swap >>free-space ; + swap *ulonglong >>total-free-bytes + swap *ulonglong >>total-bytes + swap *ulonglong >>free-space ; : file-times ( path -- timestamp timestamp timestamp ) [ From 4221f2c963a6b5e029ea83743a33a86dfb7209fc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 17:46:51 -0500 Subject: [PATCH 158/224] the windows file-system-info now works on any path, not just directories --- basis/io/windows/files/files.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index be8d131158..e4fe0fbc63 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -251,6 +251,7 @@ total-bytes total-free-bytes ; M: winnt file-system-info ( path -- file-system-info ) normalize-path + dup file-info directory? [ parent-directory ] unless "ULARGE_INTEGER" "ULARGE_INTEGER" "ULARGE_INTEGER" From 964961ed74bc68325de30f95933cf20f32e5a687 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 18:13:59 -0500 Subject: [PATCH 159/224] remove dead code --- vm/os-windows-nt.c | 29 ----------------------------- 1 file changed, 29 deletions(-) diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index 4f5778d0c4..54afd1c147 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -8,35 +8,6 @@ s64 current_millis(void) - 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; From f5f6c400db70d983424211a8dfec79f1dbe4d167 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 18:19:15 -0500 Subject: [PATCH 160/224] change windows file-system-info implementation --- basis/io/windows/files/files.factor | 9 ++++++--- basis/io/windows/nt/files/files.factor | 5 +++-- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index e4fe0fbc63..80caf5222f 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -246,12 +246,14 @@ M: winnt file-info ( path -- info ) 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 ; M: winnt file-system-info ( path -- file-system-info ) - normalize-path - dup file-info directory? [ parent-directory ] unless + normalize-path root-directory + dup "ULARGE_INTEGER" "ULARGE_INTEGER" "ULARGE_INTEGER" @@ -259,7 +261,8 @@ M: winnt file-system-info ( path -- file-system-info ) \ winnt-file-system-info new swap *ulonglong >>total-free-bytes swap *ulonglong >>total-bytes - swap *ulonglong >>free-space ; + swap *ulonglong >>free-space + swap "\\\\?\\" ?head drop root-directory >>name ; : file-times ( path -- timestamp timestamp timestamp ) [ diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor index 9b77a9f128..2fbc809263 100644 --- a/basis/io/windows/nt/files/files.factor +++ b/basis/io/windows/nt/files/files.factor @@ -31,12 +31,13 @@ M: winnt root-directory? ( path -- ? ) 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? [ From e310e382c5afaeb5e8dd166ab030c98b5f92316b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 18:30:51 -0500 Subject: [PATCH 161/224] fix io monitors recusive --- basis/io/monitors/recursive/recursive.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index 3cecee2b1e..45979363c9 100644 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -19,7 +19,8 @@ DEFER: add-child-monitor : add-child-monitors ( path -- ) #! We yield since this directory scan might take a while. - [ + dup [ + [ append-path ] with map [ add-child-monitor ] each yield ] with-directory-files ; From e4b6cd7578de989d8ef7bdb222cf6b84857db315 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 18:47:23 -0500 Subject: [PATCH 162/224] directory throws now instead of returning nicely if does not exist --- basis/tools/vocabs/vocabs.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 05f354a8a8..1f81ac5802 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -207,13 +207,16 @@ M: vocab-link summary vocab-summary ; dup vocab-authors-path set-vocab-file-contents ; : subdirs ( dir -- dirs ) - [ + dup [ [ link-info directory? ] filter - ] with-directory-files natural-sort ; + ] with-directory-files + [ append-path ] with map natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) - [ vocab-dir append-path subdirs ] keep [ + vocab-dir append-path dup exists? + [ subdirs ] [ drop { } ] if + ] keep [ swap [ "." swap 3append ] with map ] unless-empty ; From 4f948ef5ce842fca41a36e6306db4bd809bb6b09 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 19:39:20 -0500 Subject: [PATCH 163/224] try to make bootstrap work again --- basis/unix/stat/linux/32/32.factor | 12 ++++ basis/unix/stat/linux/64/64.factor | 91 +++++++++++++++++++++++++++++- 2 files changed, 101 insertions(+), 2 deletions(-) diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor index 3f6c6ba0e0..d05ae2e550 100644 --- a/basis/unix/stat/linux/32/32.factor +++ b/basis/unix/stat/linux/32/32.factor @@ -31,3 +31,15 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; : stat ( pathname buf -- int ) 3 -rot __xstat ; : lstat ( pathname buf -- int ) 3 -rot __lxstat ; + +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" } ; + diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index 088ab8d339..e7c5ca69c6 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -1,5 +1,5 @@ - -USING: kernel alien.syntax math ; +USING: kernel alien.syntax math sequences unix +alien.c-types arrays accessors combinators ; IN: unix.stat @@ -29,3 +29,90 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; : stat ( pathname buf -- int ) 1 -rot __xstat ; : lstat ( pathname buf -- int ) 1 -rot __lxstat ; + +C-STRUCT: fstab + { "char*" "fs_spec" } + { "char*" "fs_file" } + { "char*" "fs_vfstype" } + { "char*" "fs_mntops" } + { "char*" "fs_type" } + { "int" "fs_freq" } + { "int" "fs_passno" } ; + +FUNCTION: fstab* getfsent ( ) ; +FUNCTION: fstab* getfsspec ( char* name ) ; +FUNCTION: fstab* getfsfile ( char* name ) ; +FUNCTION: int setfsent ( ) ; +FUNCTION: void endfsent ( ) ; + +TUPLE: fstab spec file vfstype mntops type freq passno ; + +: fstab-struct>fstab ( struct -- fstab ) + [ fstab new ] dip + { + [ fstab-fs_spec >>spec ] + [ fstab-fs_file >>file ] + [ fstab-fs_vfstype >>vfstype ] + [ fstab-fs_mntops >>mntops ] + [ fstab-fs_type >>type ] + [ fstab-fs_freq >>freq ] + [ fstab-fs_passno >>passno ] + } cleave ; + +C-STRUCT: fsid + { { "int" 2 } "__val" } ; + +TYPEDEF: fsid __fsid_t + +TYPEDEF: ssize_t __SWORD_TYPE +TYPEDEF: ulonglong __fsblkcnt64_t +TYPEDEF: ulonglong __fsfilcnt64_t + +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" } ; + +TUPLE: statfs type bsize blocks bfree bavail files ffree fsid +namelen frsize spare ; + +: statfs-struct>statfs ( struct -- statfs ) + [ \ statfs new ] dip + { + [ 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 ; + +FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; +: statfs ( path -- byte-array ) + "statfs64" [ statfs64 io-error ] keep ; + +: all-fstabs ( -- seq ) + setfsent io-error + [ getfsent dup ] [ fstab-struct>fstab ] [ drop ] produce endfsent ; + +C-STRUCT: mntent + { "char*" "mnt_fsname" } + { "char*" "mnt_dir" } + { "char*" "mnt_type" } + { "char*" "mnt_opts" } + { "int" "mnt_freq" } + { "int" "mnt_passno" } ; + From 16f7c09b544039dca158b38db9ca78ba817bd762 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 19:43:46 -0500 Subject: [PATCH 164/224] try to fix bootstrap --- basis/unix/stat/linux/64/64.factor | 5 ----- basis/unix/stat/linux/linux.factor | 7 ++++++- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index e7c5ca69c6..03791bc8bd 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -59,11 +59,6 @@ TUPLE: fstab spec file vfstype mntops type freq passno ; [ fstab-fs_passno >>passno ] } cleave ; -C-STRUCT: fsid - { { "int" 2 } "__val" } ; - -TYPEDEF: fsid __fsid_t - TYPEDEF: ssize_t __SWORD_TYPE TYPEDEF: ulonglong __fsblkcnt64_t TYPEDEF: ulonglong __fsfilcnt64_t diff --git a/basis/unix/stat/linux/linux.factor b/basis/unix/stat/linux/linux.factor index 1df6865d41..aa48fd37ea 100644 --- a/basis/unix/stat/linux/linux.factor +++ b/basis/unix/stat/linux/linux.factor @@ -1,6 +1,11 @@ -USING: layouts combinators vocabs.loader ; +USING: alien.syntax layouts combinators vocabs.loader ; IN: unix.stat +C-STRUCT: fsid + { { "int" 2 } "__val" } ; + +TYPEDEF: fsid __fsid_t + cell-bits { { 32 [ "unix.stat.linux.32" require ] } From dcd534292e33d4ddf831c36d6cb03cdfffcbfc24 Mon Sep 17 00:00:00 2001 From: erg Date: Sun, 19 Oct 2008 19:45:54 -0500 Subject: [PATCH 165/224] fixes --- basis/unix/stat/linux/32/32.factor | 3 --- basis/unix/stat/linux/linux.factor | 1 + 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor index d05ae2e550..00a6239916 100644 --- a/basis/unix/stat/linux/32/32.factor +++ b/basis/unix/stat/linux/32/32.factor @@ -1,6 +1,4 @@ - USING: kernel alien.syntax math ; - IN: unix.stat ! Ubuntu 8.04 32-bit @@ -42,4 +40,3 @@ C-STRUCT: statfs { "long" "f_ffree" } { "fsid_t" "f_fsid" } { "long" "f_namelen" } ; - diff --git a/basis/unix/stat/linux/linux.factor b/basis/unix/stat/linux/linux.factor index aa48fd37ea..4bcab0b477 100644 --- a/basis/unix/stat/linux/linux.factor +++ b/basis/unix/stat/linux/linux.factor @@ -5,6 +5,7 @@ C-STRUCT: fsid { { "int" 2 } "__val" } ; TYPEDEF: fsid __fsid_t +TYPEDEF: fsid fsid_t cell-bits { From d77771eec8dc1fcab3f1b36f8b3f79c25bbfe4a9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 19:47:37 -0500 Subject: [PATCH 166/224] fix test --- basis/io/windows/nt/launcher/launcher-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/windows/nt/launcher/launcher-tests.factor b/basis/io/windows/nt/launcher/launcher-tests.factor index d5e77caa19..48859dc6df 100644 --- a/basis/io/windows/nt/launcher/launcher-tests.factor +++ b/basis/io/windows/nt/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ -IN: io.windows.launcher.nt.tests -USING: io.launcher tools.test calendar accessors +USING: io.launcher tools.test calendar accessors environmnent namespaces kernel system arrays io io.files io.encodings.ascii sequences parser assocs hashtables math continuations eval ; +IN: io.windows.launcher.nt.tests [ ] [ From 16f2a281d6d2552e0becf581af7882bbcc5e277c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 20:30:54 -0500 Subject: [PATCH 167/224] typo --- basis/io/windows/nt/launcher/launcher-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/windows/nt/launcher/launcher-tests.factor b/basis/io/windows/nt/launcher/launcher-tests.factor index 48859dc6df..949b0a7961 100644 --- a/basis/io/windows/nt/launcher/launcher-tests.factor +++ b/basis/io/windows/nt/launcher/launcher-tests.factor @@ -1,4 +1,4 @@ -USING: io.launcher tools.test calendar accessors environmnent +USING: io.launcher tools.test calendar accessors environment namespaces kernel system arrays io io.files io.encodings.ascii sequences parser assocs hashtables math continuations eval ; IN: io.windows.launcher.nt.tests From 3dc4002c35df24c647779de232a6d5aa1586ef4d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 20:37:11 -0500 Subject: [PATCH 168/224] fix subdirs --- basis/tools/vocabs/vocabs.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 1f81ac5802..b929c62e04 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -207,10 +207,9 @@ M: vocab-link summary vocab-summary ; dup vocab-authors-path set-vocab-file-contents ; : subdirs ( dir -- dirs ) - dup [ + [ [ link-info directory? ] filter - ] with-directory-files - [ append-path ] with map natural-sort ; + ] with-directory-files natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) [ From e9c79ee85ee61fc580e3d9e0ac70e87d6349ef0e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 20:42:27 -0500 Subject: [PATCH 169/224] fix directory. --- basis/http/server/static/static.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 3edcfe81cd..208273364c 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -68,8 +68,7 @@ TUPLE: file-responder root hook special allow-listings ; [

file-name escape-string write

] [
    - directory-files - [
  • file.
    • ] assoc-each + directory-files [
  • file.
    • ] each
] bi ] simple-page ; From 6037ed413d0c525daffbf6e6be40c98e8b783540 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 20:45:04 -0500 Subject: [PATCH 170/224] add unportable tags --- basis/unix/statfs/linux/tags.txt | 1 + basis/unix/statfs/macosx/tags.txt | 1 + 2 files changed, 2 insertions(+) create mode 100644 basis/unix/statfs/linux/tags.txt create mode 100644 basis/unix/statfs/macosx/tags.txt diff --git a/basis/unix/statfs/linux/tags.txt b/basis/unix/statfs/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/macosx/tags.txt b/basis/unix/statfs/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/macosx/tags.txt @@ -0,0 +1 @@ +unportable From 54819c0f95d9871931447a88f5ef3201b95e5ce2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 20:45:34 -0500 Subject: [PATCH 171/224] more tags --- basis/unix/statfs/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/unix/statfs/tags.txt diff --git a/basis/unix/statfs/tags.txt b/basis/unix/statfs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/tags.txt @@ -0,0 +1 @@ +unportable From 763f4f7503adcb1ab15224f2140984b6034a8278 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 22:01:14 -0500 Subject: [PATCH 172/224] move constants to bsd.factor --- basis/unix/bsd/bsd.factor | 10 ++++++++++ basis/unix/bsd/freebsd/freebsd.factor | 10 ---------- basis/unix/bsd/macosx/macosx.factor | 11 ----------- basis/unix/bsd/netbsd/netbsd.factor | 10 ---------- basis/unix/bsd/openbsd/openbsd.factor | 11 ----------- 5 files changed, 10 insertions(+), 42 deletions(-) diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index bf426ad867..bd66c5253e 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -83,6 +83,16 @@ C-STRUCT: passwd : 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 ] } diff --git a/basis/unix/bsd/freebsd/freebsd.factor b/basis/unix/bsd/freebsd/freebsd.factor index 3af6358e94..81885ff141 100644 --- a/basis/unix/bsd/freebsd/freebsd.factor +++ b/basis/unix/bsd/freebsd/freebsd.factor @@ -20,16 +20,6 @@ C-STRUCT: dirent { "u_int8_t" "d_namlen" } { { "char" 256 } "d_name" } ; -: 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 - : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index de2fd4caf0..fb9eb9a621 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -39,17 +39,6 @@ C-STRUCT: dirent { "__uint8_t" "d_namlen" } { { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ; -: 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 - - : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index 6c45811d51..bd6bcc407a 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -20,16 +20,6 @@ C-STRUCT: dirent { "__uint8_t" "d_type" } { { "char" 512 } "d_name" } ; -: 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 - : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/bsd/openbsd/openbsd.factor b/basis/unix/bsd/openbsd/openbsd.factor index f4a7863fdd..a4189775e7 100644 --- a/basis/unix/bsd/openbsd/openbsd.factor +++ b/basis/unix/bsd/openbsd/openbsd.factor @@ -20,17 +20,6 @@ C-STRUCT: dirent { "__uint8_t" "d_namlen" } { { "char" 256 } "d_name" } ; -: 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 - - - : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline From fe66a089e3a5423eea4adc63422e966481096e15 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 19 Oct 2008 22:13:33 -0500 Subject: [PATCH 173/224] a convert to/from md5 shadow passwords. just for fun --- extra/crypto/passwd-md5/authors.txt | 1 + .../crypto/passwd-md5/passwd-md5-docs.factor | 34 ++++++++++++++ .../crypto/passwd-md5/passwd-md5-tests.factor | 16 +++++++ extra/crypto/passwd-md5/passwd-md5.factor | 47 +++++++++++++++++++ 4 files changed, 98 insertions(+) create mode 100644 extra/crypto/passwd-md5/authors.txt create mode 100644 extra/crypto/passwd-md5/passwd-md5-docs.factor create mode 100644 extra/crypto/passwd-md5/passwd-md5-tests.factor create mode 100644 extra/crypto/passwd-md5/passwd-md5.factor diff --git a/extra/crypto/passwd-md5/authors.txt b/extra/crypto/passwd-md5/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/crypto/passwd-md5/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/crypto/passwd-md5/passwd-md5-docs.factor b/extra/crypto/passwd-md5/passwd-md5-docs.factor new file mode 100644 index 0000000000..eb8f3e74a9 --- /dev/null +++ b/extra/crypto/passwd-md5/passwd-md5-docs.factor @@ -0,0 +1,34 @@ +! 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" diff --git a/extra/crypto/passwd-md5/passwd-md5-tests.factor b/extra/crypto/passwd-md5/passwd-md5-tests.factor new file mode 100644 index 0000000000..a858d8dab5 --- /dev/null +++ b/extra/crypto/passwd-md5/passwd-md5-tests.factor @@ -0,0 +1,16 @@ +! 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 diff --git a/extra/crypto/passwd-md5/passwd-md5.factor b/extra/crypto/passwd-md5/passwd-md5.factor new file mode 100644 index 0000000000..32a913ef23 --- /dev/null +++ b/extra/crypto/passwd-md5/passwd-md5.factor @@ -0,0 +1,47 @@ +! 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 + + + +:: passwd-md5 ( magic salt password -- bytes ) + [let* | final! [ password magic salt 3append + salt password tuck 3append md5 checksum-bytes + password length + [ 16 / ceiling swap 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 = ; From 0121d0f678b606f750abafb3cfb47fa33c0d7314 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 00:30:24 -0500 Subject: [PATCH 174/224] add file-system-info --- basis/unix/stat/macosx/macosx.factor | 6 ------ core/io/files/files.factor | 9 ++++++++- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index 03301d25b9..49b6709847 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -115,12 +115,6 @@ C-STRUCT: vfsquery : NFSV2_MAX_FH_SIZE 32 ; inline : NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE ; inline -! C-STRUCT: fhandle - ! { "int" "fh_len" } - ! { { "uchar" NFS_MAX_FH_SIZE } "fh_data" } ; - -! TYPEDEF: fhandle fhandle_t - : MFSNAMELEN 15 ; inline : MNAMELEN 90 ; inline : MFSTYPENAMELEN 16 ; inline diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 8796834bc7..1f6a48b50e 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -153,7 +153,8 @@ PRIVATE> "." last-split1 nip ; ! File info -TUPLE: file-info type size permissions created modified accessed ; +TUPLE: file-info type size permissions created modified +accessed ; HOOK: file-info io-backend ( path -- info ) @@ -181,6 +182,12 @@ SYMBOL: +unknown+ : directory? ( file-info -- ? ) type>> +directory+ = ; +! File-system + +TUPLE: file-system-info mount-on free-space ; + +HOOK: file-system-info os ( path -- file-system-info ) + Date: Mon, 20 Oct 2008 00:47:51 -0500 Subject: [PATCH 175/224] add statfs stuff --- basis/unix/statfs/authors.txt | 1 + basis/unix/statfs/linux/authors.txt | 1 + basis/unix/statfs/linux/linux-tests.factor | 4 ++ basis/unix/statfs/linux/linux.factor | 28 +++++++++++ basis/unix/statfs/macosx/authors.txt | 1 + basis/unix/statfs/macosx/macosx-tests.factor | 4 ++ basis/unix/statfs/macosx/macosx.factor | 52 ++++++++++++++++++++ basis/unix/statfs/statfs-tests.factor | 4 ++ basis/unix/statfs/statfs.factor | 31 ++++++++++++ 9 files changed, 126 insertions(+) create mode 100644 basis/unix/statfs/authors.txt create mode 100644 basis/unix/statfs/linux/authors.txt create mode 100644 basis/unix/statfs/linux/linux-tests.factor create mode 100644 basis/unix/statfs/linux/linux.factor create mode 100644 basis/unix/statfs/macosx/authors.txt create mode 100644 basis/unix/statfs/macosx/macosx-tests.factor create mode 100644 basis/unix/statfs/macosx/macosx.factor create mode 100644 basis/unix/statfs/statfs-tests.factor create mode 100644 basis/unix/statfs/statfs.factor diff --git a/basis/unix/statfs/authors.txt b/basis/unix/statfs/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/linux/authors.txt b/basis/unix/statfs/linux/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/linux/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/linux/linux-tests.factor b/basis/unix/statfs/linux/linux-tests.factor new file mode 100644 index 0000000000..549905f081 --- /dev/null +++ b/basis/unix/statfs/linux/linux-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test unix.statfs.linux ; +IN: unix.statfs.linux.tests diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor new file mode 100644 index 0000000000..b758503ab5 --- /dev/null +++ b/basis/unix/statfs/linux/linux.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types combinators kernel ; +IN: unix.statfs.linux + +TUPLE: linux-file-system-info < file-system-info +type bsize blocks bfree bavail files ffree fsid +namelen frsize spare ; + +: statfs-struct>statfs ( struct -- statfs ) + [ \ statfs new ] dip + { + [ 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 ; + +: statfs ( path -- byte-array ) + "statfs64" [ statfs64 io-error ] keep ; + diff --git a/basis/unix/statfs/macosx/authors.txt b/basis/unix/statfs/macosx/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/macosx/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/macosx/macosx-tests.factor b/basis/unix/statfs/macosx/macosx-tests.factor new file mode 100644 index 0000000000..35625e2198 --- /dev/null +++ b/basis/unix/statfs/macosx/macosx-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test unix.statfs.macosx ; +IN: unix.statfs.macosx.tests diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor new file mode 100644 index 0000000000..60fb1658c5 --- /dev/null +++ b/basis/unix/statfs/macosx/macosx.factor @@ -0,0 +1,52 @@ +! 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 ; +IN: unix.statfs.macosx + +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 flags filesystem-subtype +file-system-type-name mount-from ; + +M: macosx mounted* ( -- array ) + f dup 0 getmntinfo64 dup io-error + [ *void* ] dip + "statfs64" heap-size [ * memory>byte-array ] keep group ; + +: statfs64>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-on ] + [ 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 ] + [ statfs64-f_flags >>flags ] + [ statfs64-f_fssubtype >>filesystem-subtype ] + [ + statfs64-f_fstypename utf8 alien>string + >>file-system-type-name + ] + [ + statfs64-f_mntfromname + utf8 alien>string >>mount-from + ] + } cleave ; + +M: macosx file-system-info ( path -- file-system-info ) + normalize-path + "statfs64" tuck statfs64 io-error + statfs64>file-system-info ; diff --git a/basis/unix/statfs/statfs-tests.factor b/basis/unix/statfs/statfs-tests.factor new file mode 100644 index 0000000000..39bc77fc87 --- /dev/null +++ b/basis/unix/statfs/statfs-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test unix.statfs ; +IN: unix.statfs.tests diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor new file mode 100644 index 0000000000..0d99b57faf --- /dev/null +++ b/basis/unix/statfs/statfs.factor @@ -0,0 +1,31 @@ +! 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: mounted block-size io-size blocks blocks-free +blocks-available files files-free file-system-id owner type +flags filesystem-subtype file-system-type-name mount-on +mount-from ; + +HOOK: mounted* os ( -- array ) +HOOK: mounted-struct>mounted os ( byte-array -- mounted ) + +TUPLE: file-system-info root-directory total-free-size total-size ; + +: mounted ( -- array ) + mounted* [ mounted-struct>mounted ] map ; + +: mounted-drive ( path -- mounted/f ) + mounted + [ [ mount-on>> ] bi@ <=> ] sort + [ mount-on>> head? ] with find nip ; + +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 From dc4a1bc902088239757213a62648cb1fdb03b0a2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 01:14:07 -0500 Subject: [PATCH 176/224] fix netbsd stat struct --- basis/unix/bsd/netbsd/netbsd.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index 6c45811d51..9f9e9e5a71 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -14,11 +14,11 @@ C-STRUCT: addrinfo { "addrinfo*" "next" } ; C-STRUCT: dirent - { "ino_t" "d_fileno" } + { "__uint32_t" "d_fileno" } { "__uint16_t" "d_reclen" } - { "__uint16_t" "d_namlen" } { "__uint8_t" "d_type" } - { { "char" 512 } "d_name" } ; + { "__uint8_t" "d_namlen" } + { { "char" 256 } "d_name" } ; : DT_UNKNOWN 0 ; inline : DT_FIFO 1 ; inline From deb4526bd11823e8fbeb8904f21462d5ddde7f4d Mon Sep 17 00:00:00 2001 From: erg Date: Mon, 20 Oct 2008 01:55:40 -0500 Subject: [PATCH 177/224] ffi work --- basis/unix/stat/linux/64/64.factor | 64 ---------------------------- basis/unix/statfs/linux/linux.factor | 18 +++++--- 2 files changed, 12 insertions(+), 70 deletions(-) diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index 03791bc8bd..b9d48066fb 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -1,6 +1,5 @@ USING: kernel alien.syntax math sequences unix alien.c-types arrays accessors combinators ; - IN: unix.stat ! Ubuntu 7.10 64-bit @@ -30,35 +29,6 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; : stat ( pathname buf -- int ) 1 -rot __xstat ; : lstat ( pathname buf -- int ) 1 -rot __lxstat ; -C-STRUCT: fstab - { "char*" "fs_spec" } - { "char*" "fs_file" } - { "char*" "fs_vfstype" } - { "char*" "fs_mntops" } - { "char*" "fs_type" } - { "int" "fs_freq" } - { "int" "fs_passno" } ; - -FUNCTION: fstab* getfsent ( ) ; -FUNCTION: fstab* getfsspec ( char* name ) ; -FUNCTION: fstab* getfsfile ( char* name ) ; -FUNCTION: int setfsent ( ) ; -FUNCTION: void endfsent ( ) ; - -TUPLE: fstab spec file vfstype mntops type freq passno ; - -: fstab-struct>fstab ( struct -- fstab ) - [ fstab new ] dip - { - [ fstab-fs_spec >>spec ] - [ fstab-fs_file >>file ] - [ fstab-fs_vfstype >>vfstype ] - [ fstab-fs_mntops >>mntops ] - [ fstab-fs_type >>type ] - [ fstab-fs_freq >>freq ] - [ fstab-fs_passno >>passno ] - } cleave ; - TYPEDEF: ssize_t __SWORD_TYPE TYPEDEF: ulonglong __fsblkcnt64_t TYPEDEF: ulonglong __fsfilcnt64_t @@ -76,38 +46,4 @@ C-STRUCT: statfs64 { "__SWORD_TYPE" "f_frsize" } { { "__SWORD_TYPE" 5 } "f_spare" } ; -TUPLE: statfs type bsize blocks bfree bavail files ffree fsid -namelen frsize spare ; - -: statfs-struct>statfs ( struct -- statfs ) - [ \ statfs new ] dip - { - [ 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 ; - FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; -: statfs ( path -- byte-array ) - "statfs64" [ statfs64 io-error ] keep ; - -: all-fstabs ( -- seq ) - setfsent io-error - [ getfsent dup ] [ fstab-struct>fstab ] [ drop ] produce endfsent ; - -C-STRUCT: mntent - { "char*" "mnt_fsname" } - { "char*" "mnt_dir" } - { "char*" "mnt_type" } - { "char*" "mnt_opts" } - { "int" "mnt_freq" } - { "int" "mnt_passno" } ; - diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index b758503ab5..44c32fd53d 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -1,15 +1,20 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types combinators kernel ; +USING: alien.c-types combinators kernel io.files unix.stat +math accessors system unix io.backend ; IN: unix.statfs.linux TUPLE: linux-file-system-info < file-system-info type bsize blocks bfree bavail files ffree fsid namelen frsize spare ; -: statfs-struct>statfs ( struct -- statfs ) - [ \ statfs new ] dip +: statfs>file-system-info ( struct -- statfs ) + [ \ linux-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 ] @@ -23,6 +28,7 @@ namelen frsize spare ; [ statfs64-f_spare >>spare ] } cleave ; -: statfs ( path -- byte-array ) - "statfs64" [ statfs64 io-error ] keep ; - +M: linux file-system-info ( path -- byte-array ) + normalize-path + "statfs64" tuck statfs64 io-error + statfs>file-system-info ; From f721105993996f9bfc86cab893cbf2dd774b3216 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 01:58:17 -0500 Subject: [PATCH 178/224] Add 3dip --- core/kernel/kernel-docs.factor | 9 +++++++++ core/kernel/kernel.factor | 2 ++ 2 files changed, 11 insertions(+) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 786919bb68..61e10a9c00 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -621,6 +621,14 @@ HELP: 2dip { $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." } @@ -815,6 +823,7 @@ ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators" "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 } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 55ed67e0fa..1402b4edf2 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -59,6 +59,8 @@ DEFER: if : 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 From fe67aae4f466cfda7c458d71c4597271c7b6492b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 02:05:15 -0500 Subject: [PATCH 179/224] add netbsd statvfs struct --- basis/unix/stat/netbsd/netbsd.factor | 32 ++++++++++++++++++++++++++- basis/unix/types/netbsd/netbsd.factor | 8 +++++++ 2 files changed, 39 insertions(+), 1 deletion(-) diff --git a/basis/unix/stat/netbsd/netbsd.factor b/basis/unix/stat/netbsd/netbsd.factor index 8057e5939b..f71e9f63d2 100644 --- a/basis/unix/stat/netbsd/netbsd.factor +++ b/basis/unix/stat/netbsd/netbsd.factor @@ -1,7 +1,37 @@ -USING: layouts combinators vocabs.loader ; +USING: layouts combinators vocabs.loader alien.syntax ; IN: unix.stat cell-bits { { 32 [ "unix.stat.netbsd.32" require ] } { 64 [ "unix.stat.netbsd.64" require ] } } case + +: _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" } ; + diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor index 3982d1e9f9..27b8966eda 100644 --- a/basis/unix/types/netbsd/netbsd.factor +++ b/basis/unix/types/netbsd/netbsd.factor @@ -8,6 +8,7 @@ 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 @@ -16,6 +17,13 @@ TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t + +TYPEDEF: __uint64_t fsblkcnt_t +TYPEDEF: fsblkcnt_t __fsblkcnt_t + +TYPEDEF: __uint64_t fsfilcnt_t +TYPEDEF: fsfilcnt_t __fsfilcnt_t + cell-bits { { 32 [ "unix.types.netbsd.32" require ] } { 64 [ "unix.types.netbsd.64" require ] } From 70fb131e82dd681eb0a94528e5ec864f4da705f1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 02:27:09 -0500 Subject: [PATCH 180/224] add netbsd --- basis/unix/statfs/netbsd/authors.txt | 1 + basis/unix/statfs/netbsd/netbsd-tests.factor | 4 ++++ basis/unix/statfs/netbsd/netbsd.factor | 7 +++++++ 3 files changed, 12 insertions(+) create mode 100644 basis/unix/statfs/netbsd/authors.txt create mode 100644 basis/unix/statfs/netbsd/netbsd-tests.factor create mode 100644 basis/unix/statfs/netbsd/netbsd.factor diff --git a/basis/unix/statfs/netbsd/authors.txt b/basis/unix/statfs/netbsd/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/netbsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/netbsd/netbsd-tests.factor b/basis/unix/statfs/netbsd/netbsd-tests.factor new file mode 100644 index 0000000000..be100c1cb6 --- /dev/null +++ b/basis/unix/statfs/netbsd/netbsd-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test unix.statfs.netbsd ; +IN: unix.statfs.netbsd.tests diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor new file mode 100644 index 0000000000..f9c86e117f --- /dev/null +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel ; +IN: unix.statfs.netbsd + + + From ff918546c1cfaa5c19c57c02333ea10a19d5370f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 02:08:33 -0500 Subject: [PATCH 181/224] ffi work --- basis/unix/stat/linux/linux.factor | 6 ------ basis/unix/stat/netbsd/netbsd.factor | 2 +- basis/unix/stat/stat.factor | 6 ++++++ 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/unix/stat/linux/linux.factor b/basis/unix/stat/linux/linux.factor index 4bcab0b477..f1c931617e 100644 --- a/basis/unix/stat/linux/linux.factor +++ b/basis/unix/stat/linux/linux.factor @@ -1,12 +1,6 @@ USING: alien.syntax layouts combinators vocabs.loader ; IN: unix.stat -C-STRUCT: fsid - { { "int" 2 } "__val" } ; - -TYPEDEF: fsid __fsid_t -TYPEDEF: fsid fsid_t - cell-bits { { 32 [ "unix.stat.linux.32" require ] } diff --git a/basis/unix/stat/netbsd/netbsd.factor b/basis/unix/stat/netbsd/netbsd.factor index f71e9f63d2..aefa9fd2cf 100644 --- a/basis/unix/stat/netbsd/netbsd.factor +++ b/basis/unix/stat/netbsd/netbsd.factor @@ -29,7 +29,7 @@ C-STRUCT: statvfs { "fsid_t" "f_fsidx" } { "ulong" "f_fsid" } { "ulong" "f_namemax" } - { "uid_t"" "f_owner" } + { "uid_t" "f_owner" } { { "uint32_t" 4 } "f_spare" } { { "char" _VFS_NAMELEN } "f_fstypename" } { { "char" _VFS_NAMELEN } "f_mntonname" } diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index f8ad74c213..17d6604fc0 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -18,6 +18,12 @@ FUNCTION: int chmod ( char* path, mode_t mode ) ; FUNCTION: int fchmod ( int fd, mode_t mode ) ; FUNCTION: int mkdir ( char* path, mode_t mode ) ; +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 ] } From d686ea1293b88d50f5b241dab51465724e5cc5ea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 03:01:44 -0500 Subject: [PATCH 182/224] netbsd work --- basis/unix/statfs/netbsd/netbsd.factor | 43 +++++++++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index f9c86e117f..f72eb7da27 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -1,7 +1,48 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel ; +USING: alien.syntax kernel io.files unix.stat math unix +combinators system io.backend accessors alien.c-types +io.encodings.utf8 alien.strings ; IN: unix.statfs.netbsd +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 ; +: statvfs>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 >>flag ] + [ statvfs-f_fresvd >>flag ] + [ statvfs-f_files >>files ] + [ statvfs-f_ffree >>ffree ] + [ statvfs-f_syncreads >>sync-reads ] + [ statvfs-f_syncwrites >>sync-writes ] + [ statvfs-f_asyncreads >>async-writes ] + [ 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-on ] + [ statvfs-f_mntfromname utf8 alien>string >>mount-from ] + } cleave ; +M: netbsd file-system-info + normalize-path "statvfs" tuck statvfs io-error + statvfs>file-system-info ; From 74dab4f90a7b3efe2250c0ddce6df5849b425d61 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 04:30:01 -0500 Subject: [PATCH 183/224] netbsd work --- basis/unix/stat/netbsd/netbsd.factor | 30 ------------------------ basis/unix/statfs/netbsd/netbsd.factor | 32 ++++++++++++++++++++++++-- basis/unix/statfs/netbsd/tags.txt | 1 + basis/unix/types/netbsd/netbsd.factor | 1 - 4 files changed, 31 insertions(+), 33 deletions(-) create mode 100644 basis/unix/statfs/netbsd/tags.txt diff --git a/basis/unix/stat/netbsd/netbsd.factor b/basis/unix/stat/netbsd/netbsd.factor index aefa9fd2cf..6fccd570e3 100644 --- a/basis/unix/stat/netbsd/netbsd.factor +++ b/basis/unix/stat/netbsd/netbsd.factor @@ -5,33 +5,3 @@ cell-bits { { 32 [ "unix.stat.netbsd.32" require ] } { 64 [ "unix.stat.netbsd.64" require ] } } case - -: _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" } ; - diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index f72eb7da27..042cd79ada 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -5,11 +5,39 @@ combinators system io.backend accessors alien.c-types io.encodings.utf8 alien.strings ; 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" } ; + 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 +files ffree sync-reads sync-writes async-reads async-writes fsidx fsid namemax owner spare fstype mnotonname mntfromname file-system-type-name mount-from ; diff --git a/basis/unix/statfs/netbsd/tags.txt b/basis/unix/statfs/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor index 27b8966eda..d69d498704 100644 --- a/basis/unix/types/netbsd/netbsd.factor +++ b/basis/unix/types/netbsd/netbsd.factor @@ -17,7 +17,6 @@ TYPEDEF: long ssize_t TYPEDEF: int pid_t TYPEDEF: int time_t - TYPEDEF: __uint64_t fsblkcnt_t TYPEDEF: fsblkcnt_t __fsblkcnt_t From 1b03aaf63e931cc69ff3dcb5487073fd303fee10 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 04:35:15 -0500 Subject: [PATCH 184/224] typos --- basis/unix/statfs/netbsd/netbsd.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index 042cd79ada..c58d6e1a0d 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -54,13 +54,13 @@ file-system-type-name mount-from ; [ statvfs-f_iosize >>io-size ] [ statvfs-f_blocks >>blocks ] [ statvfs-f_bfree >>blocks-free ] - [ statvfs-f_favail >>flag ] - [ statvfs-f_fresvd >>flag ] + [ 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-writes ] + [ statvfs-f_asyncreads >>async-reads ] [ statvfs-f_asyncwrites >>async-writes ] [ statvfs-f_fsidx >>fsidx ] [ statvfs-f_namemax >>namemax ] From ab61e5cd8c599bdeb5c6511119d1238e724d79d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 05:56:13 -0500 Subject: [PATCH 185/224] Fix performance problem --- core/classes/tuple/tuple.factor | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 577ad133e1..8cde049524 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -102,8 +102,8 @@ ERROR: bad-superclass 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 ) [ @@ -138,16 +138,12 @@ ERROR: bad-superclass class ; : define-tuple-prototype ( class -- ) dup tuple-prototype "prototype" set-word-prop ; -: finalize-tuple-slots ( class slots -- slots ) - swap superclass-size 2 + finalize-slots ; - : define-tuple-slots ( class -- ) - dup dup "slots" word-prop finalize-tuple-slots - define-accessors ; + dup "slots" word-prop 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 ; @@ -208,7 +204,6 @@ M: tuple-class update-class } 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 ] @@ -241,16 +236,19 @@ M: tuple-class update-class : check-superclass ( superclass -- ) dup valid-superclass? [ bad-superclass ] unless drop ; +GENERIC# (define-tuple-class) 2 ( class superclass slots -- ) + PRIVATE> -GENERIC# define-tuple-class 2 ( class superclass slots -- ) - -M: word define-tuple-class +: define-tuple-class ( class superclass slots -- ) over check-superclass + make-slots over class-size 2 + finalize-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 ; From b90aeee25c491f88c6a3361e55d98378ea08e41a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Oct 2008 11:32:55 -0500 Subject: [PATCH 186/224] use readdir on openbsd until we upgrade so the build machine is ok --- basis/io/unix/files/bsd/bsd.factor | 5 ++++- basis/io/unix/files/files.factor | 6 +++++- basis/io/unix/files/openbsd/authors.txt | 1 + basis/io/unix/files/openbsd/openbsd.factor | 7 +++++++ basis/io/unix/files/openbsd/tags.txt | 1 + basis/unix/unix.factor | 1 + 6 files changed, 19 insertions(+), 2 deletions(-) create mode 100644 basis/io/unix/files/openbsd/authors.txt create mode 100644 basis/io/unix/files/openbsd/openbsd.factor create mode 100644 basis/io/unix/files/openbsd/tags.txt diff --git a/basis/io/unix/files/bsd/bsd.factor b/basis/io/unix/files/bsd/bsd.factor index 18e713af2f..3c94baa39a 100644 --- a/basis/io/unix/files/bsd/bsd.factor +++ b/basis/io/unix/files/bsd/bsd.factor @@ -13,5 +13,8 @@ M: bsd stat>file-info ( stat -- file-info ) { [ stat-st_flags >>flags ] [ stat-st_gen >>gen ] - [ stat-st_birthtimespec timespec>unix-time >>birth-time ] + [ + stat-st_birthtimespec timespec>unix-time + >>birth-time + ] } cleave ; diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 67da640b71..2b85420ee9 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -142,7 +142,9 @@ os { [ opendir dup [ (io-error) ] unless ] dip dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline -: find-next-file ( DIR* -- byte-array ) +HOOK: find-next-file os ( DIR* -- byte-array ) + +M: unix find-next-file ( DIR* -- byte-array ) "dirent" f [ readdir_r 0 = [ (io-error) ] unless ] 2keep @@ -159,6 +161,8 @@ M: unix (directory-entries) ( path -- seq ) [ drop ] produce ] with-unix-directory ; +os openbsd = [ "io.unix.files.openbsd" require ] when + Date: Mon, 20 Oct 2008 14:52:58 -0500 Subject: [PATCH 187/224] check in aes data with unit tests, compared against 7zip's aes implementation --- extra/crypto/aes/aes-tests.factor | 344 ++++++++++++++++++++++++++++++ extra/crypto/aes/aes.factor | 117 ++++++++++ extra/crypto/aes/authors.txt | 1 + 3 files changed, 462 insertions(+) create mode 100644 extra/crypto/aes/aes-tests.factor create mode 100644 extra/crypto/aes/aes.factor create mode 100644 extra/crypto/aes/authors.txt diff --git a/extra/crypto/aes/aes-tests.factor b/extra/crypto/aes/aes-tests.factor new file mode 100644 index 0000000000..c76ee8cb14 --- /dev/null +++ b/extra/crypto/aes/aes-tests.factor @@ -0,0 +1,344 @@ +! 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 + diff --git a/extra/crypto/aes/aes.factor b/extra/crypto/aes/aes.factor new file mode 100644 index 0000000000..cacfc5971a --- /dev/null +++ b/extra/crypto/aes/aes.factor @@ -0,0 +1,117 @@ +! 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 + 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 + 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 + 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 -- ) + + ; +*/ diff --git a/extra/crypto/aes/authors.txt b/extra/crypto/aes/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/crypto/aes/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file From 8d5135682fbc10007ddf1db4fc47fc8b31c017f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 21:07:46 -0500 Subject: [PATCH 188/224] Print a message when tests fail --- basis/tools/test/test.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index d3304bbdb1..5c2bd8f4e3 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -12,6 +12,7 @@ SYMBOL: failures error-continuation get 3array ; : failure ( error what -- ) + "--> test failed!" print failures get push ; SYMBOL: this-test From 325dbf3eefb6e29faf15d0878a5f0f504d85ab6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 21:07:55 -0500 Subject: [PATCH 189/224] Fix regression --- core/classes/tuple/tuple.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 8cde049524..ecff54d9bc 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -138,8 +138,12 @@ ERROR: bad-superclass class ; : define-tuple-prototype ( class -- ) dup tuple-prototype "prototype" set-word-prop ; +: prepare-slots ( slots superclass -- slots' ) + [ make-slots ] [ class-size 2 + ] bi* finalize-slots ; + : define-tuple-slots ( class -- ) - dup "slots" word-prop define-accessors ; + dup "slots" word-prop over superclass prepare-slots + define-accessors ; : make-tuple-layout ( class -- layout ) [ ] @@ -242,7 +246,7 @@ PRIVATE> : define-tuple-class ( class superclass slots -- ) over check-superclass - make-slots over class-size 2 + finalize-slots + over prepare-slots (define-tuple-class) ; M: word (define-tuple-class) From 1df08ba8c800a12e529dd6d2ca084186b3e5ad9b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 22:05:22 -0500 Subject: [PATCH 190/224] Unit tests no longer use hard-coded ports --- basis/http/http-tests.factor | 159 +++++++++--------- .../connection/connection-tests.factor | 19 +-- basis/tools/deploy/deploy-tests.factor | 38 +++-- basis/tools/deploy/test/5/5.factor | 7 +- 4 files changed, 109 insertions(+), 114 deletions(-) diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index b3930878ff..96320b7d12 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -192,110 +192,104 @@ test-db [ init-furnace-tables ] with-db -: test-httpd ( -- ) - #! Return as soon as server is running. - - 1237 >>insecure - f >>secure - start-server* ; +: test-httpd ( responder -- ) + [ + main-responder set + + 0 >>insecure + f >>secure + dup start-server* + sockets>> first addr>> port>> + ] with-scope "port" set ; [ ] [ - [ + + add-quit-action - add-quit-action - - "resource:basis/http/test" >>default - "nested" add-responder - - [ URL" redirect-loop" ] >>display - "redirect-loop" add-responder - main-responder set + "resource:basis/http/test" >>default + "nested" add-responder + + [ URL" redirect-loop" ] >>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 [ ] [ - [ - - add-quit-action - [ "quit" ] >>display - "redirect" add-responder - main-responder set + + add-quit-action + [ "quit" ] >>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 [ ] [ - [ + + + "Test" + + "" add-responder + add-quit-action - - "Test" - - "" add-responder - add-quit-action - - "" add-responder - "d" add-responder - test-db - main-responder set + "" add-responder + "d" add-responder + test-db - 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 [ ] [ - [ - - [ [ "Hi" write ] "text/plain" ] >>display - "Test" - - "" add-responder - add-quit-action - test-db - main-responder set + + [ [ "Hi" write ] "text/plain" ] >>display + "Test" + + "" add-responder + add-quit-action + test-db - test-httpd - ] with-scope + 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 @@ -304,22 +298,19 @@ furnace furnace.conversations ; SYMBOL: a [ ] [ - [ - - - [ a get-global "a" set-value ] >>init - [ [ "a" render ] "text/html" ] >>display - [ { { "a" [ v-integer ] } } validate-params ] >>validate - [ "a" value a set-global URL" " ] >>submit - - - >>default - add-quit-action - test-db - main-responder set + + + [ a get-global "a" set-value ] >>init + [ [ "a" render ] "text/html" ] >>display + [ { { "a" [ v-integer ] } } validate-params ] >>validate + [ "a" value a set-global URL" " ] >>submit + + + >>default + add-quit-action + test-db - test-httpd - ] with-scope + test-httpd ] unit-test 3 a set-global @@ -327,27 +318,35 @@ SYMBOL: a : 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/" "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 "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/" "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 "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 diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index a3223ed2aa..ae79290f0a 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -27,25 +27,12 @@ concurrency.promises io.encodings.ascii io threads calendar ; init-server semaphore>> count>> ] unit-test -[ ] [ "p" set ] unit-test - [ ] [ 5 >>max-connections - 1237 >>insecure + 0 >>insecure [ "Hello world." write stop-this-server ] >>handler - "server" set + dup start-server* sockets>> first addr>> port>> "port" set ] unit-test -[ ] [ - [ - "server" get start-server - t "p" get fulfill - ] in-thread -] unit-test - -[ ] [ "server" get wait-for-server ] unit-test - -[ "Hello world." ] [ "localhost" 1237 ascii drop contents ] unit-test - -[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test +[ "Hello world." ] [ "localhost" "port" get ascii drop contents ] unit-test diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index db4255cdb1..71e83ea29c 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -1,7 +1,8 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math sequences io.launcher arrays -namespaces continuations layouts accessors ; +namespaces continuations layouts accessors io.encodings.ascii +urls math.parser ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors @@ -38,7 +39,7 @@ namespaces continuations layouts accessors ; ! [ ] [ "tetris" shake-and-bake ] unit-test ! ! [ t ] [ 1500000 small-enough? ] unit-test -! + [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ 2500000 small-enough? ] unit-test @@ -71,22 +72,24 @@ M: quit-responder call-responder* : add-quot-responder ( responder -- responder ) quit-responder "quit" add-responder ; -: test-httpd ( -- ) - #! Return as soon as server is running. - - 1237 >>insecure - f >>secure - start-server* ; +: test-httpd ( responder -- ) + [ + main-responder set + + 0 >>insecure + f >>secure + dup start-server* + sockets>> first addr>> port>> + dup number>string "resource:temp/port-number" ascii set-file-contents + ] with-scope + "port" set ; [ ] [ - [ - - add-quot-responder - "resource:basis/http/test" >>default - main-responder set + + add-quot-responder + "resource:basis/http/test" >>default - test-httpd - ] with-scope + test-httpd ] unit-test [ ] [ @@ -94,7 +97,10 @@ M: quit-responder call-responder* run-temp-image ] unit-test -[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test +: add-port ( url -- url' ) + >url clone "port" get >>port ; + +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test [ ] [ "tools.deploy.test.6" shake-and-bake diff --git a/basis/tools/deploy/test/5/5.factor b/basis/tools/deploy/test/5/5.factor index debc020d49..9118fa3ca7 100644 --- a/basis/tools/deploy/test/5/5.factor +++ b/basis/tools/deploy/test/5/5.factor @@ -1,7 +1,10 @@ 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 From 76cde4e005e277be1449f11928f4073c675785b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 22:55:57 -0500 Subject: [PATCH 191/224] Fix tetris deployment --- extra/tetris/deploy.factor | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/extra/tetris/deploy.factor b/extra/tetris/deploy.factor index 57a5eda494..a21e592cc8 100755 --- a/extra/tetris/deploy.factor +++ b/extra/tetris/deploy.factor @@ -1,12 +1,15 @@ USING: tools.deploy.config ; -V{ +H{ { deploy-ui? t } - { deploy-io 1 } - { deploy-reflection 1 } { deploy-compiler? t } - { deploy-math? t } + { deploy-threads? t } { deploy-word-props? f } - { deploy-c-types? 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" } } From 6c985918807d8c7315bd8bd871af8748a7cc3c31 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 23:07:54 -0500 Subject: [PATCH 192/224] Don't hardcode port number in socket benchmark --- extra/benchmark/richards/richards.factor | 272 +++++++++++++++++++++++ extra/benchmark/sockets/sockets.factor | 26 ++- 2 files changed, 289 insertions(+), 9 deletions(-) create mode 100644 extra/benchmark/richards/richards.factor diff --git a/extra/benchmark/richards/richards.factor b/extra/benchmark/richards/richards.factor new file mode 100644 index 0000000000..894948e44f --- /dev/null +++ b/extra/benchmark/richards/richards.factor @@ -0,0 +1,272 @@ +! 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 + +: ( link id kind -- packet ) + packet new + swap >>kind + swap >>id + swap >>link + 0 >>a1 + BUFSIZE 0 >>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 ; + +: ( 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 ; + +: ( 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 } ; + +: ( 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 } ; + +: ( 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 to: task-tab + f to: tracing + 0 to: hold-count + 0 to: qpkt-count ; + +: start ( -- ) + I_IDLE 1 10000 drop + + I_WORK 1000 + f 0 K_WORK 0 K_WORK + drop + + I_HANDLERA 2000 + f I_DEVA K_DEV + I_DEVA K_DEV + I_DEVA K_DEV + drop + + I_HANDLERB 3000 + f I_DEVB K_DEV + I_DEVB K_DEV + I_DEVB K_DEV + drop + + I_DEVA 4000 f drop + I_DEVB 4000 f drop ; + +: check ( -- ) + qpkt-count 23246 assert= + hold-count 9297 assert= ; + +: run ( -- ) + init + start + schedule check ; diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 68e3a625a7..20c905156b 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -1,20 +1,25 @@ -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 ; +: server-addr ( -- addr ) + "127.0.0.1" port-promise get ?promise ; : server-loop ( server -- ) dup accept drop [ [ read1 CHAR: x = [ - "server" get dispose + server get dispose ] [ number-of-requests [ read1 write1 flush ] times @@ -25,9 +30,11 @@ SYMBOL: counter : simple-server ( -- ) [ - server-addr ascii dup "server" set [ - server-loop - ] with-disposal + "127.0.0.1" 0 ascii + [ server set ] + [ addr>> port>> port-promise get fulfill ] + [ [ server-loop ] with-disposal ] + tri ] ignore-errors ; : simple-client ( -- ) @@ -47,6 +54,7 @@ SYMBOL: counter : clients ( n -- ) dup pprint " clients: " write [ + port-promise set dup 2 * counter set [ simple-server ] "Simple server" spawn drop yield yield From a8d1ec34f8c227d8af953b1f7df04afd846f5aa6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 23:28:02 -0500 Subject: [PATCH 193/224] Fix an UI bug and remove some pick usages --- basis/ui/tools/listener/listener-tests.factor | 4 +++- basis/ui/tools/listener/listener.factor | 11 ++++++----- basis/ui/tools/tools.factor | 8 ++++---- 3 files changed, 13 insertions(+), 10 deletions(-) diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index e86b52c664..616226a9c5 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor 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 @@ -51,3 +51,5 @@ IN: ui.tools.listener.tests [ ] [ "listener" get com-end ] unit-test ] with-grafted-gadget + +[ ] [ \ + interactor-use use-if-necessary ] unit-test diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 6fc6fa4f10..4c8b88d62c 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -101,8 +101,8 @@ M: engine-word word-completion-string "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 ; @@ -114,9 +114,10 @@ M: engine-word word-completion-string 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 ; diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index f4205061cd..aed4b9d675 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -40,11 +40,11 @@ IN: ui.tools : 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 From 655b483ff1e5be0bec1fb7bb41a1bfc33fbe64d8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 23:29:38 -0500 Subject: [PATCH 194/224] Move unfinished benchmark to unfinished --- {extra => unfinished}/benchmark/richards/richards.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {extra => unfinished}/benchmark/richards/richards.factor (100%) diff --git a/extra/benchmark/richards/richards.factor b/unfinished/benchmark/richards/richards.factor similarity index 100% rename from extra/benchmark/richards/richards.factor rename to unfinished/benchmark/richards/richards.factor From 69aad251c122e00b2774fc57a4048bf9c534c8ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 02:53:34 -0500 Subject: [PATCH 195/224] use common statfs fields on linux for now --- basis/unix/statfs/linux/linux.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 7a407da78b..3644fcf89b 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -29,8 +29,8 @@ M: linux >file-system-info ( struct -- statfs ) [ statfs64-f_ffree >>ffree ] [ statfs64-f_fsid >>fsid ] [ statfs64-f_namelen >>namelen ] - [ statfs64-f_frsize >>frsize ] - [ statfs64-f_spare >>spare ] + ! [ statfs64-f_frsize >>frsize ] + ! [ statfs64-f_spare >>spare ] } cleave ; M: linux file-system-info ( path -- byte-array ) From 09c1f8cc016d963ee57aed613d95738e9c9e5f9b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 03:11:26 -0500 Subject: [PATCH 196/224] split up linux statfs --- basis/unix/statfs/linux/32/32.factor | 33 +++++++++++++++++++++++++++- basis/unix/statfs/linux/64/64.factor | 33 +++++++++++++++++++++++++++- basis/unix/statfs/linux/linux.factor | 33 ++-------------------------- 3 files changed, 66 insertions(+), 33 deletions(-) diff --git a/basis/unix/statfs/linux/32/32.factor b/basis/unix/statfs/linux/32/32.factor index 86fb61e83d..ea8f39137f 100644 --- a/basis/unix/statfs/linux/32/32.factor +++ b/basis/unix/statfs/linux/32/32.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax unix.types ; +USING: alien.c-types combinators kernel io.files unix.stat +math accessors system unix io.backend layouts vocabs.loader +alien.syntax ; IN: unix.statfs.linux C-STRUCT: statfs @@ -13,3 +15,32 @@ C-STRUCT: statfs { "long" "f_ffree" } { "fsid_t" "f_fsid" } { "long" "f_namelen" } ; + +FUNCTION: int statfs ( char* path, statfs64* buf ) ; + +TUPLE: linux-file-system-info < file-system-info +type bsize blocks bfree bavail files ffree fsid +namelen frsize spare ; + +M: linux >file-system-info ( struct -- statfs ) + [ \ linux-file-system-info new ] dip + { + [ + [ statfs64-f_bsize ] + [ statfs64-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" tuck statfs io-error + >file-system-info ; diff --git a/basis/unix/statfs/linux/64/64.factor b/basis/unix/statfs/linux/64/64.factor index 20688680fb..49ed79cd6e 100644 --- a/basis/unix/statfs/linux/64/64.factor +++ b/basis/unix/statfs/linux/64/64.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax unix.types ; +USING: alien.c-types combinators kernel io.files unix.stat +math accessors system unix io.backend layouts vocabs.loader +alien.syntax ; IN: unix.statfs.linux C-STRUCT: statfs64 @@ -17,3 +19,32 @@ C-STRUCT: statfs64 { { "__SWORD_TYPE" 5 } "f_spare" } ; FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; + +TUPLE: linux-file-system-info < file-system-info +type bsize blocks bfree bavail files ffree fsid +namelen frsize spare ; + +M: linux >file-system-info ( struct -- statfs ) + [ \ linux-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" tuck statfs64 io-error + >file-system-info ; diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 3644fcf89b..b4413fba15 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -4,36 +4,7 @@ USING: alien.c-types combinators kernel io.files unix.stat math accessors system unix io.backend layouts vocabs.loader ; IN: unix.statfs.linux -<< cell-bits { +cell-bits { { 32 [ "unix.statfs.linux.32" require ] } { 64 [ "unix.statfs.linux.64" require ] } -} case >> - -TUPLE: linux-file-system-info < file-system-info -type bsize blocks bfree bavail files ffree fsid -namelen frsize spare ; - -M: linux >file-system-info ( struct -- statfs ) - [ \ linux-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" tuck statfs64 io-error - >file-system-info ; +} case From 33948aa024925f4906570fced80d8fbb51213272 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 03:16:48 -0500 Subject: [PATCH 197/224] linux32 and linx64 filesystem info objects instead of only one type --- basis/unix/statfs/linux/32/32.factor | 4 ++-- basis/unix/statfs/linux/64/64.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/unix/statfs/linux/32/32.factor b/basis/unix/statfs/linux/32/32.factor index ea8f39137f..b21e3904f4 100644 --- a/basis/unix/statfs/linux/32/32.factor +++ b/basis/unix/statfs/linux/32/32.factor @@ -18,12 +18,12 @@ C-STRUCT: statfs FUNCTION: int statfs ( char* path, statfs64* buf ) ; -TUPLE: linux-file-system-info < file-system-info +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 ) - [ \ linux-file-system-info new ] dip + [ \ linux32-file-system-info new ] dip { [ [ statfs64-f_bsize ] diff --git a/basis/unix/statfs/linux/64/64.factor b/basis/unix/statfs/linux/64/64.factor index 49ed79cd6e..a84bec0486 100644 --- a/basis/unix/statfs/linux/64/64.factor +++ b/basis/unix/statfs/linux/64/64.factor @@ -20,12 +20,12 @@ C-STRUCT: statfs64 FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; -TUPLE: linux-file-system-info < file-system-info +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 ) - [ \ linux-file-system-info new ] dip + [ \ linux64-file-system-info new ] dip { [ [ statfs64-f_bsize ] From 1423577d8948df03af01113972ad8d0440442501 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 03:21:17 -0500 Subject: [PATCH 198/224] typo --- basis/unix/statfs/linux/32/32.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/unix/statfs/linux/32/32.factor b/basis/unix/statfs/linux/32/32.factor index b21e3904f4..c6ec0bc658 100644 --- a/basis/unix/statfs/linux/32/32.factor +++ b/basis/unix/statfs/linux/32/32.factor @@ -16,7 +16,7 @@ C-STRUCT: statfs { "fsid_t" "f_fsid" } { "long" "f_namelen" } ; -FUNCTION: int statfs ( char* path, statfs64* buf ) ; +FUNCTION: int statfs ( char* path, statfs* buf ) ; TUPLE: linux32-file-system-info < file-system-info type bsize blocks bfree bavail files ffree fsid @@ -26,8 +26,8 @@ M: linux >file-system-info ( struct -- statfs ) [ \ linux32-file-system-info new ] dip { [ - [ statfs64-f_bsize ] - [ statfs64-f_bavail ] bi * >>free-space + [ statfs-f_bsize ] + [ statfs-f_bavail ] bi * >>free-space ] [ statfs-f_type >>type ] [ statfs-f_bsize >>bsize ] From 003000b7cf154767eb994099282cb90f404c224b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 04:19:50 -0500 Subject: [PATCH 199/224] timeval>seconds --- basis/calendar/unix/unix.factor | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor index d5b66ffc1a..9848d0c164 100644 --- a/basis/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -4,13 +4,19 @@ USING: alien alien.c-types alien.syntax arrays calendar kernel math unix unix.time namespaces system ; IN: calendar.unix -: timeval>unix-time ( timeval -- timestamp ) +: timeval>seconds ( timeval -- seconds ) [ timeval-sec seconds ] [ timeval-usec microseconds ] bi - time+ since-1970 ; + time+ ; -: timespec>unix-time ( timeval -- timestamp ) +: timeval>unix-time ( timeval -- timestamp ) + timeval>seconds since-1970 ; + +: timespec>seconds ( timespec -- seconds ) [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi - time+ since-1970 ; + time+ ; + +: timespec>unix-time ( timespec -- timestamp ) + timespec>seconds since-1970 ; : get-time ( -- alien ) f time localtime ; From edb78de4a7ec3ca5ec7e8daa821bfe3e4e155f15 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 20:30:26 -0500 Subject: [PATCH 200/224] add parsing word to roman --- extra/roman/roman-docs.factor | 3 +++ extra/roman/roman-tests.factor | 2 ++ extra/roman/roman.factor | 8 +++++++- 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/extra/roman/roman-docs.factor b/extra/roman/roman-docs.factor index a62e92ce08..87551635f1 100644 --- a/extra/roman/roman-docs.factor +++ b/extra/roman/roman-docs.factor @@ -43,3 +43,6 @@ HELP: roman/mod { $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." } ; diff --git a/extra/roman/roman-tests.factor b/extra/roman/roman-tests.factor index a15dcef354..82084e0b1f 100644 --- a/extra/roman/roman-tests.factor +++ b/extra/roman/roman-tests.factor @@ -36,3 +36,5 @@ USING: arrays kernel math roman roman.private sequences tools.test ; [ "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 diff --git a/extra/roman/roman.factor b/extra/roman/roman.factor index dcadb865f9..5ffdf67753 100644 --- a/extra/roman/roman.factor +++ b/extra/roman/roman.factor @@ -2,10 +2,11 @@ ! 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 : >roman ( n -- str ) @@ -49,11 +51,13 @@ PRIVATE> ] map sum ; ( str1 str2 -- m n ) [ roman> ] bi@ ; : binary-roman-op ( str1 str2 quot -- str3 ) >r 2roman> r> call >roman ; inline + PRIVATE> : roman+ ( str1 str2 -- str3 ) @@ -70,3 +74,5 @@ PRIVATE> : roman/mod ( str1 str2 -- str3 str4 ) [ /mod ] binary-roman-op >r >roman r> ; + +: ROMAN: scan roman> parsed ; parsing From ee8ba1d5d4b1a4b025a8086287540dc5f2bac854 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 20:43:29 -0500 Subject: [PATCH 201/224] tweak hexdump --- extra/hexdump/hexdump-docs.factor | 6 +++--- extra/hexdump/hexdump.factor | 25 +++++++++++++------------ 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/extra/hexdump/hexdump-docs.factor b/extra/hexdump/hexdump-docs.factor index a83f64e8db..4278e92f0e 100644 --- a/extra/hexdump/hexdump-docs.factor +++ b/extra/hexdump/hexdump-docs.factor @@ -1,14 +1,14 @@ ! 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. } ; diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor index 618ed00802..5262755821 100644 --- a/extra/hexdump/hexdump.factor +++ b/extra/hexdump/hexdump.factor @@ -7,29 +7,30 @@ IN: hexdump 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 write [ dup printable? [ drop CHAR: . ] unless write1 ] each nl ; PRIVATE> -: hexdump ( sequence -- string ) +: hexdump ( seq -- str ) [ - dup length header. - 16 [ line. ] each-index + [ length write-header ] + [ 16 [ write-hex-line ] each-index ] bi ] with-string-writer ; -: hexdump. ( sequence -- ) - hexdump write ; +: hexdump. ( seq -- ) hexdump write ; From 9870a7d7cd3b0fb624d9eb4bcd79effa698849f8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 21:03:37 -0500 Subject: [PATCH 202/224] fix bug with printing docs directory --- basis/tools/scaffold/scaffold.factor | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 17eafa91c6..6659940b2b 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -16,13 +16,18 @@ ERROR: vocab-name-contains-dot path ; ERROR: no-vocab vocab ; . ; +: (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 ( -- ) @@ -205,14 +213,15 @@ ERROR: no-vocab vocab ; : 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 - . ; + [ find-vocab-root ] + [ vocab>scaffold-path ] bi + "-docs.factor" (scaffold-path) . ; : help. ( word -- ) [ (help.) ] [ nl vocabulary>> link-vocab ] bi ; From cfd1978aaae39839dec5ba9a6003ccb15992dc67 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 21:51:54 -0500 Subject: [PATCH 203/224] checkin so i can work with this elsewhere --- extra/math/floating-point/authors.txt | 1 + .../floating-point-tests.factor | 4 +++ .../math/floating-point/floating-point.factor | 32 +++++++++++++++++++ 3 files changed, 37 insertions(+) create mode 100644 extra/math/floating-point/authors.txt create mode 100644 extra/math/floating-point/floating-point-tests.factor create mode 100644 extra/math/floating-point/floating-point.factor diff --git a/extra/math/floating-point/authors.txt b/extra/math/floating-point/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/math/floating-point/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor new file mode 100644 index 0000000000..2a60d30d02 --- /dev/null +++ b/extra/math/floating-point/floating-point-tests.factor @@ -0,0 +1,4 @@ +! 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 diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor new file mode 100644 index 0000000000..87767181cd --- /dev/null +++ b/extra/math/floating-point/floating-point.factor @@ -0,0 +1,32 @@ +! 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+ * * ; + From 2f3fe3c8ecd687a04f1c35f4e755bb9712770361 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 22:55:48 -0500 Subject: [PATCH 204/224] docs for file-system-info --- core/io/files/files-docs.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 984598688d..9a85688202 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -81,6 +81,7 @@ ARTICLE: "fs-meta" "File metadata" { $subsection link-info } { $subsection exists? } { $subsection directory? } + "File types:" { $subsection "file-types" } ; @@ -322,6 +323,12 @@ 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" } } { $description "Resolve a path relative to the Factor source code location." } ; From 52020c2fe33b7d1ae6f5bf2df61895511f281104 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Oct 2008 23:18:27 -0500 Subject: [PATCH 205/224] Fixing x86 instruction encoding for addressing with base = ESP or R12 --- .../cpu/x86/assembler/assembler-tests.factor | 24 ++++++++++++++++--- basis/cpu/x86/assembler/assembler.factor | 19 ++++++++------- 2 files changed, 31 insertions(+), 12 deletions(-) diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 941bbe5b73..915847a453 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -4,9 +4,9 @@ IN: cpu.x86.assembler.tests [ { 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 @@ -39,3 +39,21 @@ IN: cpu.x86.assembler.tests [ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 OR ] { } make ] unit-test [ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 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 diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index f557bb4adc..8cb0d620af 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -64,18 +64,18 @@ M: indirect extended? base>> extended? ; : 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 ; : ( base index scale displacement -- indirect ) indirect boa canonicalize ; @@ -91,7 +91,7 @@ M: indirect extended? base>> extended? ; 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 ; @@ -254,7 +254,8 @@ M: object operand-64? 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 ; From b9e043effee243acad4b9a3949b858a1b4e12cbe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 21 Oct 2008 23:43:36 -0500 Subject: [PATCH 206/224] move >file-system-info --- basis/unix/statfs/statfs.factor | 2 ++ core/io/files/files.factor | 3 --- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor index 8ac5a46883..f00ffe77cd 100644 --- a/basis/unix/statfs/statfs.factor +++ b/basis/unix/statfs/statfs.factor @@ -14,6 +14,8 @@ HOOK: mounted-struct>mounted os ( byte-array -- mounted ) TUPLE: file-system-info root-directory total-free-size total-size ; +HOOK: >file-system-info os ( struct -- statfs ) + : mounted ( -- array ) mounted* [ mounted-struct>mounted ] map ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index cfb90d58a5..1f6a48b50e 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -188,9 +188,6 @@ TUPLE: file-system-info mount-on free-space ; HOOK: file-system-info os ( path -- file-system-info ) -HOOK: >file-system-info os ( struct -- statfs ) - - Date: Wed, 22 Oct 2008 09:54:59 -0500 Subject: [PATCH 207/224] Add 'dns.resolver' --- extra/dns/resolver/resolver.factor | 66 ++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) create mode 100644 extra/dns/resolver/resolver.factor diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor new file mode 100644 index 0000000000..dff1afbb18 --- /dev/null +++ b/extra/dns/resolver/resolver.factor @@ -0,0 +1,66 @@ + +USING: kernel accessors namespaces continuations + io io.sockets io.binary io.timeouts io.encodings.binary + destructors + locals strings sequences random prettyprint calendar dns ; + +IN: dns.resolver + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: send-receive-udp ( BA SERVER -- ba ) + T{ inet4 f f 0 } + 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 ] [ ] 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 ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: dns-servers ( -- seq ) \ dns-servers get ; + +! : dns-server ( -- server ) dns-servers random ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: dns-ip ( name -- ips ) + fully-qualified + [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 ] ; + From 92abf2825660adaafcc0efe21d8dd1c11389ac2d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 22 Oct 2008 10:21:36 -0500 Subject: [PATCH 208/224] dns.resolver: use 'resolv.conf' servers by default --- extra/dns/resolver/resolver.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index dff1afbb18..f7983965d5 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -2,7 +2,7 @@ USING: kernel accessors namespaces continuations io io.sockets io.binary io.timeouts io.encodings.binary destructors - locals strings sequences random prettyprint calendar dns ; + locals strings sequences random prettyprint calendar dns dns.misc ; IN: dns.resolver @@ -50,7 +50,11 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: dns-servers ( -- seq ) \ dns-servers get ; +: dns-servers ( -- seq ) + \ dns-servers get + [ ] + [ resolv-conf-servers \ dns-servers set dns-servers ] + if* ; ! : dns-server ( -- server ) dns-servers random ; From 371b1f8f206d44a82815cf0e3cff6f17d49d2a82 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Oct 2008 18:46:24 -0500 Subject: [PATCH 209/224] fix mounted on macosx --- basis/unix/statfs/macosx/macosx.factor | 3 +++ basis/unix/statfs/statfs.factor | 5 ++--- basis/unix/types/types.factor | 18 +++++++++--------- basis/unix/unix.factor | 7 +++++++ 4 files changed, 21 insertions(+), 12 deletions(-) diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 4bd9f55132..048c292cea 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -128,6 +128,9 @@ M: macosx mounted* ( -- array ) [ *void* ] dip "statfs64" heap-size [ * memory>byte-array ] keep group ; +M: macosx >mounted + >file-system-info ; + M: macosx >file-system-info ( byte-array -- file-system-info ) [ \ macosx-file-system-info new ] dip { diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor index f00ffe77cd..9aef2246c0 100644 --- a/basis/unix/statfs/statfs.factor +++ b/basis/unix/statfs/statfs.factor @@ -10,14 +10,13 @@ flags filesystem-subtype file-system-type-name mount-on mount-from ; HOOK: mounted* os ( -- array ) -HOOK: mounted-struct>mounted os ( byte-array -- mounted ) +HOOK: >mounted os ( byte-array -- mounted ) TUPLE: file-system-info root-directory total-free-size total-size ; HOOK: >file-system-info os ( struct -- statfs ) -: mounted ( -- array ) - mounted* [ mounted-struct>mounted ] map ; +: mounted ( -- array ) mounted* [ >mounted ] map ; : mounted-drive ( path -- mounted/f ) mounted diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 51db6f5da0..65845874b1 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -2,15 +2,6 @@ USING: kernel system alien.syntax combinators vocabs.loader system ; IN: unix.types -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: char int8_t TYPEDEF: short int16_t TYPEDEF: int int32_t @@ -36,6 +27,15 @@ 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 os { { linux [ "unix.types.linux" require ] } diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 2fcb83dc2c..4950daef2c 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -116,6 +116,13 @@ 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 ) ; From f9b90d035b8c7dcb263d590abf37534f860b99d0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Oct 2008 19:01:45 -0500 Subject: [PATCH 210/224] implement mounted on linux --- basis/unix/statfs/linux/linux.factor | 24 ++++++++++++++++++++++++ basis/unix/statfs/macosx/macosx.factor | 3 --- basis/unix/statfs/statfs.factor | 2 +- 3 files changed, 25 insertions(+), 4 deletions(-) diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index b4413fba15..94ed8cb8cf 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -8,3 +8,27 @@ 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 csv first >>options ] + [ 4 swap nth >>frequency ] + [ 5 swap nth >>pass-number ] + } cleave ; + +: parse-mtab ( -- array ) + [ + "/etc/mtab" utf8 + CHAR: \s delimiter set csv + ] with-scope + [ mtab-csv>mtab-entry ] map ; + +M: linux mounted* + parse-mtab [ mount-point>> >file-system-info ] map ; diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 048c292cea..4bd9f55132 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -128,9 +128,6 @@ M: macosx mounted* ( -- array ) [ *void* ] dip "statfs64" heap-size [ * memory>byte-array ] keep group ; -M: macosx >mounted - >file-system-info ; - M: macosx >file-system-info ( byte-array -- file-system-info ) [ \ macosx-file-system-info new ] dip { diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor index 9aef2246c0..cfa0c159d1 100644 --- a/basis/unix/statfs/statfs.factor +++ b/basis/unix/statfs/statfs.factor @@ -16,7 +16,7 @@ TUPLE: file-system-info root-directory total-free-size total-size ; HOOK: >file-system-info os ( struct -- statfs ) -: mounted ( -- array ) mounted* [ >mounted ] map ; +: mounted ( -- array ) mounted* [ >file-system-info ] map ; : mounted-drive ( path -- mounted/f ) mounted From b4b02d29fad5bd10e1cf2eb097721f531d7572df Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 22 Oct 2008 19:54:22 -0500 Subject: [PATCH 211/224] fix mounted on linux --- basis/unix/statfs/linux/32/32.factor | 4 ++-- basis/unix/statfs/linux/linux.factor | 8 +++++--- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/unix/statfs/linux/32/32.factor b/basis/unix/statfs/linux/32/32.factor index c6ec0bc658..6658d5942d 100644 --- a/basis/unix/statfs/linux/32/32.factor +++ b/basis/unix/statfs/linux/32/32.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types combinators kernel io.files unix.stat +USING: alien.c-types combinators kernel unix.stat math accessors system unix io.backend layouts vocabs.loader -alien.syntax ; +alien.syntax unix.statfs io.files ; IN: unix.statfs.linux C-STRUCT: statfs diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 94ed8cb8cf..6f4b1d619d 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -1,7 +1,9 @@ ! 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 ; +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 { @@ -30,5 +32,5 @@ frequency pass-number ; ] with-scope [ mtab-csv>mtab-entry ] map ; -M: linux mounted* - parse-mtab [ mount-point>> >file-system-info ] map ; +M: linux mounted + parse-mtab [ mount-point>> file-system-info ] map ; From 89e9fa8b6bdd1c994a0e64a2bd7534aff1039354 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Oct 2008 19:56:46 -0500 Subject: [PATCH 212/224] mounted* -> mounted --- basis/unix/statfs/macosx/macosx.factor | 5 +++-- basis/unix/statfs/statfs.factor | 10 +--------- 2 files changed, 4 insertions(+), 11 deletions(-) diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 4bd9f55132..675e65a2d8 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -123,10 +123,11 @@ block-size io-size blocks blocks-free blocks-available files files-free file-system-id owner type flags filesystem-subtype file-system-type-name mount-from ; -M: macosx mounted* ( -- array ) +M: macosx mounted ( -- array ) f dup 0 getmntinfo64 dup io-error [ *void* ] dip - "statfs64" heap-size [ * memory>byte-array ] keep group ; + "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 diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor index cfa0c159d1..20010370ae 100644 --- a/basis/unix/statfs/statfs.factor +++ b/basis/unix/statfs/statfs.factor @@ -9,19 +9,11 @@ blocks-available files files-free file-system-id owner type flags filesystem-subtype file-system-type-name mount-on mount-from ; -HOOK: mounted* os ( -- array ) -HOOK: >mounted os ( byte-array -- mounted ) - TUPLE: file-system-info root-directory total-free-size total-size ; HOOK: >file-system-info os ( struct -- statfs ) -: mounted ( -- array ) mounted* [ >file-system-info ] map ; - -: mounted-drive ( path -- mounted/f ) - mounted - [ [ mount-on>> ] bi@ <=> ] sort - [ mount-on>> head? ] with find nip ; +HOOK: mounted os ( -- array ) os { { linux [ "unix.statfs.linux" require ] } From 278b55ee5766553eb37b0776b02424b022f5dbf5 Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 22 Oct 2008 20:04:10 -0500 Subject: [PATCH 213/224] include mount point in file-system-info --- basis/unix/statfs/linux/linux.factor | 5 ++++- basis/unix/statfs/statfs.factor | 5 ----- core/io/files/files.factor | 2 +- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 6f4b1d619d..caf2e8334c 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -33,4 +33,7 @@ frequency pass-number ; [ mtab-csv>mtab-entry ] map ; M: linux mounted - parse-mtab [ mount-point>> file-system-info ] map ; + parse-mtab [ + mount-point>> + [ file-system-info ] keep >>name + ] map ; diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor index 20010370ae..e77ef37b0f 100644 --- a/basis/unix/statfs/statfs.factor +++ b/basis/unix/statfs/statfs.factor @@ -4,11 +4,6 @@ USING: sequences system vocabs.loader combinators accessors kernel math.order sorting ; IN: unix.statfs -TUPLE: mounted block-size io-size blocks blocks-free -blocks-available files files-free file-system-id owner type -flags filesystem-subtype file-system-type-name mount-on -mount-from ; - TUPLE: file-system-info root-directory total-free-size total-size ; HOOK: >file-system-info os ( struct -- statfs ) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1f6a48b50e..fd45343043 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -184,7 +184,7 @@ SYMBOL: +unknown+ ! File-system -TUPLE: file-system-info mount-on free-space ; +TUPLE: file-system-info name free-space ; HOOK: file-system-info os ( path -- file-system-info ) From 46fbd8c5202f549edc042e2a235fa5a96c027af9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Oct 2008 20:18:58 -0500 Subject: [PATCH 214/224] mounton -> name --- basis/unix/statfs/macosx/macosx.factor | 2 +- basis/unix/statfs/netbsd/netbsd.factor | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 675e65a2d8..becce262b8 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -136,7 +136,7 @@ M: macosx >file-system-info ( byte-array -- file-system-info ) [ statfs64-f_bavail ] [ statfs64-f_bsize ] bi * >>free-space ] - [ statfs64-f_mntonname utf8 alien>string >>mount-on ] + [ statfs64-f_mntonname utf8 alien>string >>name ] [ statfs64-f_bsize >>block-size ] [ statfs64-f_iosize >>io-size ] diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index dd1ccd4c9a..5aff13cceb 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel io.files unix.stat math unix +USING: alien.syntax kernel unix.stat math unix combinators system io.backend accessors alien.c-types -io.encodings.utf8 alien.strings unix.types ; +io.encodings.utf8 alien.strings unix.types unix.statfs io.files ; IN: unix.statfs.netbsd : _VFS_NAMELEN 32 ; inline @@ -69,7 +69,7 @@ M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info ) [ 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-on ] + [ statvfs-f_mntonname utf8 alien>string >>name ] [ statvfs-f_mntfromname utf8 alien>string >>mount-from ] } cleave ; From 4ddfc834231b0c33220500dd2e92897c554ec548 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Oct 2008 20:22:35 -0500 Subject: [PATCH 215/224] id_t type --- basis/unix/types/macosx/macosx.factor | 8 +------- basis/unix/types/types.factor | 1 + 2 files changed, 2 insertions(+), 7 deletions(-) diff --git a/basis/unix/types/macosx/macosx.factor b/basis/unix/types/macosx/macosx.factor index 156e756641..ac62776ed7 100644 --- a/basis/unix/types/macosx/macosx.factor +++ b/basis/unix/types/macosx/macosx.factor @@ -1,19 +1,13 @@ - 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 diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 65845874b1..f7ce6406fe 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -36,6 +36,7 @@ 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 ] } From bccf9d96986fc6aa170876e12f162e86641a5db8 Mon Sep 17 00:00:00 2001 From: erg Date: Wed, 22 Oct 2008 20:28:30 -0500 Subject: [PATCH 216/224] add device-name and type to file-system-info --- basis/unix/statfs/linux/linux.factor | 8 ++++++-- core/io/files/files.factor | 2 +- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index caf2e8334c..5e6e5360ef 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -34,6 +34,10 @@ frequency pass-number ; M: linux mounted parse-mtab [ - mount-point>> - [ file-system-info ] keep >>name + [ mount-point>> file-system-info ] keep + { + [ file-system-name>> >>device-name ] + [ mount-point>> >>name ] + [ type>> >>type ] + } cleave ] map ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index fd45343043..f643f4ca3c 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -184,7 +184,7 @@ SYMBOL: +unknown+ ! File-system -TUPLE: file-system-info name free-space ; +TUPLE: file-system-info device-name name type free-space ; HOOK: file-system-info os ( path -- file-system-info ) From c9167e2ab2222165783de57cbf76521c877c759f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Oct 2008 20:32:39 -0500 Subject: [PATCH 217/224] better file-system-info on mac --- basis/unix/statfs/macosx/macosx.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index becce262b8..e065fc6118 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -120,8 +120,7 @@ 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 flags filesystem-subtype -file-system-type-name mount-from ; +files-free file-system-id owner type-id flags filesystem-subtype ; M: macosx mounted ( -- array ) f dup 0 getmntinfo64 dup io-error @@ -147,16 +146,16 @@ M: macosx >file-system-info ( byte-array -- file-system-info ) [ statfs64-f_ffree >>files-free ] [ statfs64-f_fsid >>file-system-id ] [ statfs64-f_owner >>owner ] - [ statfs64-f_type >>type ] + [ statfs64-f_type >>type-id ] [ statfs64-f_flags >>flags ] [ statfs64-f_fssubtype >>filesystem-subtype ] [ statfs64-f_fstypename utf8 alien>string - >>file-system-type-name + >>type ] [ statfs64-f_mntfromname - utf8 alien>string >>mount-from + utf8 alien>string >>device-name ] } cleave ; From b85b0f6820762d73d9383f97ec103ae7904115be Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Oct 2008 21:43:19 -0500 Subject: [PATCH 218/224] fix typo --- basis/unix/statfs/freebsd/freebsd.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index 6c5a45c4d2..64ee8716c2 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -23,7 +23,7 @@ C-STRUCT: statvfs FUNCTION: int statvfs ( char* path, statvfs* buf ) ; TUPLE: freebsd-file-system-info < file-system-info -bavail bfree blocks favail ffree ffiles +bavail bfree blocks favail ffree files bsize flag frsize fsid namemax ; M: freebsd >file-system-info ( struct -- statfs ) From e776bd29e16e2326c22d7244aaec6bcab18425cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Oct 2008 22:02:33 -0500 Subject: [PATCH 219/224] add type to file-system-info --- basis/io/windows/files/files.factor | 48 ++++++++++++++++++++++---- basis/windows/kernel32/kernel32.factor | 44 +++++++++++++++++++---- 2 files changed, 78 insertions(+), 14 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index 80caf5222f..d7b0b49dd1 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -5,7 +5,7 @@ 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 continuations -windows.errors arrays ; +windows.errors arrays byte-arrays ; IN: io.windows.files : open-file ( path access-mode create-mode flags -- handle ) @@ -251,18 +251,52 @@ 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+ + MAX_PATH 1+ + "DWORD" "DWORD" "DWORD" + MAX_PATH 1+ + 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" + "ULARGE_INTEGER" + "ULARGE_INTEGER" + [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ; + M: winnt file-system-info ( path -- file-system-info ) normalize-path root-directory - dup - "ULARGE_INTEGER" - "ULARGE_INTEGER" - "ULARGE_INTEGER" - [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep + 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 "\\\\?\\" ?head drop root-directory >>name ; + swap >>type + swap >>name ; + +: find-first-volume ( word -- string handle ) + MAX_PATH 1+ dup length + dupd + FindFirstVolume dup win32-error=0/f + [ utf16n alien>string ] dip ; + +: find-next-volume ( handle -- string ) + MAX_PATH 1+ 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 ) [ diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index dfac6a5236..eb90fb522e 100644 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -812,22 +812,42 @@ FUNCTION: HANDLE FindFirstFileW ( LPCTSTR lpFileName, LPWIN32_FIND_DATA lpFindFi 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 @@ -1094,7 +1114,17 @@ FUNCTION: DWORD GetVersion ( ) ; 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 From 94fa3929a886e3a40344de5f52b706426ab2f15f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Oct 2008 05:28:22 -0500 Subject: [PATCH 220/224] Rice --- core/classes/tuple/tuple.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index ecff54d9bc..ef2cf616be 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -93,9 +93,8 @@ ERROR: bad-superclass class ; : 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 -- ) From 03d96cc1bd804d4335db41611f8c094511ed112c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Oct 2008 13:18:00 -0500 Subject: [PATCH 221/224] rename name to mount-point --- basis/io/windows/files/files.factor | 2 +- basis/unix/statfs/linux/linux.factor | 2 +- basis/unix/statfs/macosx/macosx.factor | 2 +- basis/unix/statfs/netbsd/netbsd.factor | 2 +- core/io/files/files.factor | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor index d7b0b49dd1..3fb8029ee7 100644 --- a/basis/io/windows/files/files.factor +++ b/basis/io/windows/files/files.factor @@ -274,7 +274,7 @@ M: winnt file-system-info ( path -- file-system-info ) swap *ulonglong >>total-bytes swap *ulonglong >>free-space swap >>type - swap >>name ; + swap >>mount-point ; : find-first-volume ( word -- string handle ) MAX_PATH 1+ dup length diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 5e6e5360ef..aae8d09145 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -37,7 +37,7 @@ M: linux mounted [ mount-point>> file-system-info ] keep { [ file-system-name>> >>device-name ] - [ mount-point>> >>name ] + [ mount-point>> >>mount-point ] [ type>> >>type ] } cleave ] map ; diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index e065fc6118..6bf09fcdc0 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -135,7 +135,7 @@ M: macosx >file-system-info ( byte-array -- file-system-info ) [ statfs64-f_bavail ] [ statfs64-f_bsize ] bi * >>free-space ] - [ statfs64-f_mntonname utf8 alien>string >>name ] + [ statfs64-f_mntonname utf8 alien>string >>mount-point ] [ statfs64-f_bsize >>block-size ] [ statfs64-f_iosize >>io-size ] diff --git a/basis/unix/statfs/netbsd/netbsd.factor b/basis/unix/statfs/netbsd/netbsd.factor index 5aff13cceb..56c632edb4 100644 --- a/basis/unix/statfs/netbsd/netbsd.factor +++ b/basis/unix/statfs/netbsd/netbsd.factor @@ -69,7 +69,7 @@ M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info ) [ statvfs-f_owner >>owner ] [ statvfs-f_spare >>spare ] [ statvfs-f_fstypename utf8 alien>string >>file-system-type-name ] - [ statvfs-f_mntonname utf8 alien>string >>name ] + [ statvfs-f_mntonname utf8 alien>string >>mount-point ] [ statvfs-f_mntfromname utf8 alien>string >>mount-from ] } cleave ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index f643f4ca3c..9899f5a014 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -184,7 +184,7 @@ SYMBOL: +unknown+ ! File-system -TUPLE: file-system-info device-name name type free-space ; +TUPLE: file-system-info device-name mount-point type free-space ; HOOK: file-system-info os ( path -- file-system-info ) From a42c8d4ab7da4b8b474de55a494cc5bc0c1905ef Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Oct 2008 13:37:14 -0500 Subject: [PATCH 222/224] fix using --- basis/unix/statfs/openbsd/openbsd.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor index a64b60a078..fa86ef2bc2 100644 --- a/basis/unix/statfs/openbsd/openbsd.factor +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax accessors combinators kernel io.files -unix.types math system io.backend alien.c-types unix ; +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 From 2937f71702dac0f89a4071feb1837f86d787682b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Oct 2008 13:38:26 -0500 Subject: [PATCH 223/224] more usings --- basis/unix/statfs/freebsd/freebsd.factor | 5 +++-- basis/unix/statfs/linux/64/64.factor | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index 64ee8716c2..b6179a4ad7 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel unix io.files math accessors -combinators system io.backend alien.c-types ; +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 diff --git a/basis/unix/statfs/linux/64/64.factor b/basis/unix/statfs/linux/64/64.factor index a84bec0486..3bf2644e12 100644 --- a/basis/unix/statfs/linux/64/64.factor +++ b/basis/unix/statfs/linux/64/64.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types combinators kernel io.files unix.stat +USING: alien.c-types combinators kernel unix.stat math accessors system unix io.backend layouts vocabs.loader -alien.syntax ; +alien.syntax unix.statfs io.files ; IN: unix.statfs.linux C-STRUCT: statfs64 From 89db7676c417c6db80b23aef3e1c70c5258ba6b8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 23 Oct 2008 18:24:11 -0500 Subject: [PATCH 224/224] dns.forwarding: Use new 'ask-servers' --- extra/dns/forwarding/forwarding.factor | 7 +++++-- extra/dns/resolver/resolver.factor | 4 +++- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extra/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor index 6d4fece949..4b7db30abd 100644 --- a/extra/dns/forwarding/forwarding.factor +++ b/extra/dns/forwarding/forwarding.factor @@ -2,7 +2,8 @@ USING: kernel sequences combinators accessors locals random combinators.short-circuit io.sockets - dns dns.util dns.cache.rr dns.cache.nx ; + dns dns.util dns.cache.rr dns.cache.nx + dns.resolver ; IN: dns.forwarding @@ -99,7 +100,9 @@ IN: dns.forwarding MSG additional-section>> [ cache-add ] each MSG ; -: answer-from-server ( msg servers -- msg ) random ask-server cache-message ; +! : 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|| ; diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index f7983965d5..32ad23669c 100644 --- a/extra/dns/resolver/resolver.factor +++ b/extra/dns/resolver/resolver.factor @@ -60,7 +60,7 @@ IN: dns.resolver ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: dns-ip ( name -- ips ) +: dns-ip4 ( name -- ips ) fully-qualified [let | MSG [ A IN query boa query->message dns-servers ask-servers ] | MSG rcode>> NO-ERROR = @@ -68,3 +68,5 @@ IN: dns.resolver [ "dns-ip: rcode = " MSG rcode>> unparse append throw ] if ] ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +