diff --git a/Makefile b/Makefile index 5f7cdca06d..769aeacb8c 100755 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ AR = ar LD = ld EXECUTABLE = factor -VERSION = 0.91 +VERSION = 0.92 IMAGE = factor.image BUNDLE = Factor.app diff --git a/README.txt b/README.txt index dd7c3e7ad3..754791aa1a 100755 --- a/README.txt +++ b/README.txt @@ -146,12 +146,13 @@ usage documentation, enter the following in the UI listener: The Factor source tree is organized as follows: build-support/ - scripts used for compiling Factor - core/ - Factor core library and compiler - extra/ - more libraries + vm/ - sources for the Factor VM, written in C + core/ - Factor core library + basis/ - Factor basis library, compiler, tools + extra/ - more libraries and applications fonts/ - TrueType fonts used by UI misc/ - editor modes, icons, etc unmaintained/ - unmaintained contributions, please help! - vm/ - sources for the Factor VM, written in C * Community diff --git a/extra/alarms/alarms-docs.factor b/basis/alarms/alarms-docs.factor similarity index 74% rename from extra/alarms/alarms-docs.factor rename to basis/alarms/alarms-docs.factor index b25df236c9..49480c0fe0 100755 --- a/extra/alarms/alarms-docs.factor +++ b/basis/alarms/alarms-docs.factor @@ -9,13 +9,19 @@ HELP: add-alarm { $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ; HELP: later -{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } } -{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ; +{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } } +{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ; HELP: cancel-alarm { $values { "alarm" alarm } } { $description "Cancels an alarm. Does nothing if the alarm is not active." } ; +HELP: every +{ $values + { "quot" quotation } { "duration" duration } + { "alarm" alarm } } +{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ; + ARTICLE: "alarms" "Alarms" "Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread." { $subsection alarm } diff --git a/extra/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor similarity index 100% rename from extra/alarms/alarms-tests.factor rename to basis/alarms/alarms-tests.factor diff --git a/extra/alarms/alarms.factor b/basis/alarms/alarms.factor similarity index 56% rename from extra/alarms/alarms.factor rename to basis/alarms/alarms.factor index ddc1d34121..7fdeca9ae6 100755 --- a/extra/alarms/alarms.factor +++ b/basis/alarms/alarms.factor @@ -1,11 +1,15 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar combinators generic init kernel math -namespaces sequences heaps boxes threads debugger quotations -assocs math.order ; +USING: accessors arrays calendar combinators generic init +kernel math namespaces sequences heaps boxes threads debugger +quotations assocs math.order ; IN: alarms -TUPLE: alarm quot time interval entry ; +TUPLE: alarm + { quot callable initial: [ ] } + { time timestamp } + interval + { entry box } ; ( quot time frequency -- alarm ) check-alarm alarm boa ; : register-alarm ( alarm -- ) - dup dup alarm-time alarms get-global heap-push* - swap alarm-entry >box + dup dup time>> alarms get-global heap-push* + swap entry>> >box notify-alarm-thread ; : alarm-expired? ( alarm now -- ? ) - >r alarm-time r> before=? ; + [ time>> ] dip before=? ; : reschedule-alarm ( alarm -- ) - dup alarm-time over alarm-interval time+ - over set-alarm-time - register-alarm ; + dup [ swap interval>> time+ ] change-time register-alarm ; : call-alarm ( alarm -- ) - dup alarm-entry box> drop - dup alarm-quot "Alarm execution" spawn drop - dup alarm-interval [ reschedule-alarm ] [ drop ] if ; + [ entry>> box> drop ] + [ quot>> "Alarm execution" spawn drop ] + [ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ; : (trigger-alarms) ( alarms now -- ) over heap-empty? [ @@ -57,7 +58,7 @@ SYMBOL: alarm-thread : next-alarm ( alarms -- timestamp/f ) dup heap-empty? - [ drop f ] [ heap-peek drop alarm-time ] if ; + [ drop f ] [ heap-peek drop time>> ] if ; : alarm-thread-loop ( -- ) alarms get-global @@ -66,7 +67,7 @@ SYMBOL: alarm-thread : cancel-alarms ( alarms -- ) [ - heap-pop-all [ nip alarm-entry box> drop ] assoc-each + heap-pop-all [ nip entry>> box> drop ] assoc-each ] when* ; : init-alarms ( -- ) @@ -81,11 +82,11 @@ PRIVATE> : add-alarm ( quot time frequency -- alarm ) [ register-alarm ] keep ; -: later ( quot dt -- alarm ) - from-now f add-alarm ; +: later ( quot duration -- alarm ) + hence f add-alarm ; -: every ( quot dt -- alarm ) - [ from-now ] keep add-alarm ; +: every ( quot duration -- alarm ) + [ hence ] keep add-alarm ; : cancel-alarm ( alarm -- ) - alarm-entry [ alarms get-global heap-delete ] if-box? ; + entry>> [ alarms get-global heap-delete ] if-box? ; diff --git a/extra/alarms/authors.txt b/basis/alarms/authors.txt similarity index 100% rename from extra/alarms/authors.txt rename to basis/alarms/authors.txt diff --git a/basis/alias/alias-docs.factor b/basis/alias/alias-docs.factor new file mode 100644 index 0000000000..f4d4ac0361 --- /dev/null +++ b/basis/alias/alias-docs.factor @@ -0,0 +1,17 @@ +USING: kernel words help.markup help.syntax ; +IN: alias + +HELP: ALIAS: +{ $syntax "ALIAS: new-word existing-word" } +{ $values { "new-word" word } { "existing-word" word } } +{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." } +{ $examples + { $example "USING: alias prettyprint sequences ;" + "IN: alias.test" + "ALIAS: sequence-nth nth" + "0 { 10 20 30 } sequence-nth ." + "10" + } +} ; + + diff --git a/basis/alias/alias.factor b/basis/alias/alias.factor new file mode 100755 index 0000000000..4de4d833fa --- /dev/null +++ b/basis/alias/alias.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors words quotations kernel effects sequences parser ; +IN: alias + +PREDICATE: alias < word "alias" word-prop ; + +M: alias reset-word + [ call-next-method ] [ f "alias" set-word-prop ] bi ; + +M: alias stack-effect + def>> first stack-effect ; + +: define-alias ( new old -- ) + [ 1quotation define-inline ] + [ drop t "alias" set-word-prop ] 2bi ; + +: ALIAS: CREATE-WORD scan-word define-alias ; parsing diff --git a/core/alien/arrays/authors.txt b/basis/alias/authors.txt similarity index 100% rename from core/alien/arrays/authors.txt rename to basis/alias/authors.txt diff --git a/core/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor similarity index 100% rename from core/alien/arrays/arrays-docs.factor rename to basis/alien/arrays/arrays-docs.factor diff --git a/core/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor similarity index 94% rename from core/alien/arrays/arrays.factor rename to basis/alien/arrays/arrays.factor index 0f756e0ad0..71c3fd6ff2 100644 --- a/core/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -10,7 +10,7 @@ M: array c-type ; M: array heap-size unclip heap-size [ * ] reduce ; -M: array c-type-align first c-type c-type-align ; +M: array c-type-align first c-type-align ; M: array c-type-stack-align? drop f ; diff --git a/core/alien/c-types/authors.txt b/basis/alien/arrays/authors.txt similarity index 100% rename from core/alien/c-types/authors.txt rename to basis/alien/arrays/authors.txt diff --git a/core/alien/arrays/summary.txt b/basis/alien/arrays/summary.txt similarity index 100% rename from core/alien/arrays/summary.txt rename to basis/alien/arrays/summary.txt diff --git a/core/alien/compiler/authors.txt b/basis/alien/c-types/authors.txt similarity index 100% rename from core/alien/compiler/authors.txt rename to basis/alien/c-types/authors.txt diff --git a/core/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor similarity index 98% rename from core/alien/c-types/c-types-docs.factor rename to basis/alien/c-types/c-types-docs.factor index 8da030c7d1..03208de63a 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,7 +1,7 @@ IN: alien.c-types USING: alien help.syntax help.markup libc kernel.private byte-arrays math strings hashtables alien.syntax -bit-arrays float-arrays debugger destructors ; +debugger destructors ; HELP: { $values { "type" hashtable } } @@ -200,7 +200,7 @@ $nl "Structure and union types are specified by the name of the structure or union." ; ARTICLE: "c-byte-arrays" "Passing data in byte arrays" -"Instances of the " { $link byte-array } ", " { $link bit-array } " and " { $link float-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array." +"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array." $nl "Byte arrays can be allocated directly with a byte count using the " { $link } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:" { $subsection } @@ -253,4 +253,4 @@ $nl "New C types can be defined:" { $subsection "c-structs" } { $subsection "c-unions" } -{ $subsection "reading-writing-memory" } ; +{ $see-also "aliens" } ; diff --git a/core/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor similarity index 87% rename from core/alien/c-types/c-types-tests.factor rename to basis/alien/c-types/c-types-tests.factor index 5f57068bab..edda9e7fdb 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -2,6 +2,12 @@ IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc alien.strings io.encodings.utf8 ; +\ expand-constants must-infer + +: xyz 123 ; + +[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test + : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ; [ 123 ] [ foo ] unit-test @@ -48,3 +54,5 @@ TYPEDEF: uchar* MyLPBYTE [ 0 B{ 1 2 3 4 } ] must-fail + +[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test diff --git a/core/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor similarity index 80% rename from core/alien/c-types/c-types.factor rename to basis/alien/c-types/c-types.factor index 44c0112c77..f44941d88f 100755 --- a/core/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: bit-arrays byte-arrays float-arrays arrays -assocs kernel kernel.private libc math +USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators ; +accessors combinators effects continuations ; IN: alien.c-types DEFER: @@ -38,6 +37,7 @@ ERROR: no-c-type name ; dup string? [ (c-type) ] when ] when ; +! C type protocol GENERIC: c-type ( name -- type ) foldable : resolve-pointer-type ( name -- name ) @@ -63,6 +63,60 @@ M: string c-type ( name -- type ) ] ?if ] if ; +GENERIC: c-type-boxer ( name -- boxer ) + +M: c-type c-type-boxer boxer>> ; + +M: string c-type-boxer c-type c-type-boxer ; + +GENERIC: c-type-boxer-quot ( name -- quot ) + +M: c-type c-type-boxer-quot boxer-quot>> ; + +M: string c-type-boxer-quot c-type c-type-boxer-quot ; + +GENERIC: c-type-unboxer ( name -- boxer ) + +M: c-type c-type-unboxer unboxer>> ; + +M: string c-type-unboxer c-type c-type-unboxer ; + +GENERIC: c-type-unboxer-quot ( name -- quot ) + +M: c-type c-type-unboxer-quot unboxer-quot>> ; + +M: string c-type-unboxer-quot c-type c-type-unboxer-quot ; + +GENERIC: c-type-reg-class ( name -- reg-class ) + +M: c-type c-type-reg-class reg-class>> ; + +M: string c-type-reg-class c-type c-type-reg-class ; + +GENERIC: c-type-getter ( name -- quot ) + +M: c-type c-type-getter getter>> ; + +M: string c-type-getter c-type c-type-getter ; + +GENERIC: c-type-setter ( name -- quot ) + +M: c-type c-type-setter setter>> ; + +M: string c-type-setter c-type c-type-setter ; + +GENERIC: c-type-align ( name -- n ) + +M: c-type c-type-align align>> ; + +M: string c-type-align c-type c-type-align ; + +GENERIC: c-type-stack-align? ( name -- ? ) + +M: c-type c-type-stack-align? stack-align?>> ; + +M: string c-type-stack-align? c-type c-type-stack-align? ; + : c-type-box ( n type -- ) dup c-type-reg-class swap c-type-boxer [ "No boxer" throw ] unless* @@ -73,10 +127,6 @@ M: string c-type ( name -- type ) swap c-type-unboxer [ "No unboxer" throw ] unless* %unbox ; -M: string c-type-align c-type c-type-align ; - -M: string c-type-stack-align? c-type c-type-stack-align? ; - GENERIC: box-parameter ( n ctype -- ) M: c-type box-parameter c-type-box ; @@ -108,29 +158,25 @@ GENERIC: heap-size ( type -- size ) foldable M: string heap-size c-type heap-size ; -M: c-type heap-size c-type-size ; +M: c-type heap-size size>> ; GENERIC: stack-size ( type -- size ) foldable M: string stack-size c-type stack-size ; -M: c-type stack-size c-type-size ; +M: c-type stack-size size>> ; GENERIC: byte-length ( seq -- n ) flushable -M: bit-array byte-length length 7 + -3 shift ; - M: byte-array byte-length length ; -M: float-array byte-length length "double" heap-size * ; - : c-getter ( name -- quot ) - c-type c-type-getter [ + c-type-getter [ [ "Cannot read struct fields with type" throw ] ] unless* ; : c-setter ( name -- quot ) - c-type c-type-setter [ + c-type-setter [ [ "Cannot write struct fields with type" throw ] ] unless* ; @@ -156,7 +202,9 @@ M: float-array byte-length length "double" heap-size * ; swap dup length memcpy ; : (define-nth) ( word type quot -- ) - >r heap-size [ rot * ] swap prefix r> append define-inline ; + [ + \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi* + ] [ ] make define-inline ; : nth-word ( name vocab -- word ) >r "-nth" append r> create ; @@ -203,9 +251,9 @@ M: long-long-type box-return ( type -- ) : c-bool> ( int -- ? ) zero? not ; -: >c-array ( seq type word -- ) - >r >r dup length dup r> dup -roll r> - [ execute ] 2curry 2each ; inline +: >c-array ( seq type word -- byte-array ) + [ [ dup length ] dip ] dip + [ [ execute ] 2curry each-index ] 2keep drop ; inline : >c-array-quot ( type vocab -- quot ) dupd set-nth-word [ >c-array ] 2curry ; @@ -214,7 +262,8 @@ M: long-long-type box-return ( type -- ) >r ">c-" swap "-array" 3append r> create ; : define-to-array ( type vocab -- ) - [ to-array-word ] 2keep >c-array-quot define ; + [ to-array-word ] 2keep >c-array-quot + (( array -- byte-array )) define-declared ; : c-array>quot ( type vocab -- quot ) [ @@ -227,7 +276,8 @@ M: long-long-type box-return ( type -- ) >r "c-" swap "-array>" 3append r> create ; : define-from-array ( type vocab -- ) - [ from-array-word ] 2keep c-array>quot define ; + [ from-array-word ] 2keep c-array>quot + (( c-ptr n -- array )) define-declared ; : define-primitive-type ( type name -- ) "alien.c-types" @@ -240,16 +290,20 @@ M: long-long-type box-return ( type -- ) } 2cleave ; : expand-constants ( c-type -- c-type' ) - #! We use word-def call instead of execute to get around - #! staging violations dup array? [ - unclip >r [ dup word? [ word-def call ] when ] map - r> prefix + unclip >r [ + dup word? [ + def>> { } swap with-datastack first + ] when + ] map r> prefix ] when ; : malloc-file-contents ( path -- alien len ) binary file-contents dup malloc-byte-array swap length ; +: if-void ( type true false -- ) + pick "void" = [ drop nip call ] [ nip call ] if ; inline + [ [ alien-cell ] >>getter @@ -352,7 +406,7 @@ M: long-long-type box-return ( type -- ) [ alien-unsigned-4 zero? not ] >>getter - [ 1 0 ? set-alien-unsigned-4 ] >>setter + [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter 4 >>size 4 >>align "box_boolean" >>boxer @@ -361,7 +415,7 @@ M: long-long-type box-return ( type -- ) [ alien-float ] >>getter - [ >r >r >float r> r> set-alien-float ] >>setter + [ [ >float ] 2dip set-alien-float ] >>setter 4 >>size 4 >>align "box_float" >>boxer @@ -372,7 +426,7 @@ M: long-long-type box-return ( type -- ) [ alien-double ] >>getter - [ >r >r >float r> r> set-alien-double ] >>setter + [ [ >float ] 2dip set-alien-double ] >>setter 8 >>size 8 >>align "box_double" >>boxer diff --git a/core/alien/c-types/summary.txt b/basis/alien/c-types/summary.txt similarity index 100% rename from core/alien/c-types/summary.txt rename to basis/alien/c-types/summary.txt diff --git a/core/alien/remote-control/authors.txt b/basis/alien/remote-control/authors.txt similarity index 100% rename from core/alien/remote-control/authors.txt rename to basis/alien/remote-control/authors.txt diff --git a/core/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor similarity index 66% rename from core/alien/remote-control/remote-control.factor rename to basis/alien/remote-control/remote-control.factor index 1d713f6edd..9cd9050ea8 100755 --- a/core/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -1,21 +1,21 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings parser threads words -kernel.private kernel io.encodings.utf8 ; +USING: accessors alien alien.c-types alien.strings parser +threads words kernel.private kernel io.encodings.utf8 eval ; IN: alien.remote-control -: eval-callback +: eval-callback ( -- callback ) "void*" { "char*" } "cdecl" [ eval>string utf8 malloc-string ] alien-callback ; -: yield-callback +: yield-callback ( -- callback ) "void" { } "cdecl" [ yield ] alien-callback ; -: sleep-callback +: sleep-callback ( -- callback ) "void" { "long" } "cdecl" [ sleep ] alien-callback ; : ?callback ( word -- alien ) - dup compiled? [ execute ] [ drop f ] if ; inline + dup compiled>> [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) \ eval-callback ?callback 16 setenv diff --git a/core/alien/remote-control/summary.txt b/basis/alien/remote-control/summary.txt similarity index 100% rename from core/alien/remote-control/summary.txt rename to basis/alien/remote-control/summary.txt diff --git a/core/alien/strings/strings-docs.factor b/basis/alien/strings/strings-docs.factor similarity index 81% rename from core/alien/strings/strings-docs.factor rename to basis/alien/strings/strings-docs.factor index 27b0122ebe..3dc358336c 100644 --- a/core/alien/strings/strings-docs.factor +++ b/basis/alien/strings/strings-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax strings byte-arrays alien libc -debugger ; +debugger io.encodings.string sequences ; IN: alien.strings HELP: string>alien @@ -38,7 +38,11 @@ HELP: utf16n ARTICLE: "c-strings" "C strings" "C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." $nl -"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." +"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function." +$nl +"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." +$nl +"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array." $nl "Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" { $subsection string>alien } diff --git a/core/alien/strings/strings-tests.factor b/basis/alien/strings/strings-tests.factor similarity index 100% rename from core/alien/strings/strings-tests.factor rename to basis/alien/strings/strings-tests.factor diff --git a/core/alien/strings/strings.factor b/basis/alien/strings/strings.factor similarity index 98% rename from core/alien/strings/strings.factor rename to basis/alien/strings/strings.factor index 827d478d06..70bbe773ee 100755 --- a/core/alien/strings/strings.factor +++ b/basis/alien/strings/strings.factor @@ -100,7 +100,7 @@ M: utf16n drop utf16n ; os windows? [ utf16n ] [ utf8 ] if alien>string ; : dll-path ( dll -- string ) - (dll-path) alien>native-string ; + path>> alien>native-string ; : string>symbol ( str -- alien ) [ os wince? [ utf16n ] [ utf8 ] if string>alien ] diff --git a/core/alien/structs/authors.txt b/basis/alien/structs/authors.txt similarity index 100% rename from core/alien/structs/authors.txt rename to basis/alien/structs/authors.txt diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor new file mode 100644 index 0000000000..5273c2c7ba --- /dev/null +++ b/basis/alien/structs/fields/fields.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays kernel kernel.private math namespaces +sequences strings words effects combinators alien.c-types ; +IN: alien.structs.fields + +TUPLE: field-spec name offset type reader writer ; + +: reader-effect ( type spec -- effect ) + [ 1array ] [ name>> 1array ] bi* ; + +PREDICATE: slot-reader < word "reading" word-prop >boolean ; + +: set-reader-props ( class spec -- ) + 2dup reader-effect + over reader>> + swap "declared-effect" set-word-prop + reader>> swap "reading" set-word-prop ; + +: writer-effect ( type spec -- effect ) + name>> swap 2array 0 ; + +PREDICATE: slot-writer < word "writing" word-prop >boolean ; + +: set-writer-props ( class spec -- ) + 2dup writer-effect + over writer>> + swap "declared-effect" set-word-prop + writer>> swap "writing" set-word-prop ; + +: reader-word ( class name vocab -- word ) + >r >r "-" r> 3append r> create ; + +: writer-word ( class name vocab -- word ) + >r [ swap "set-" % % "-" % % ] "" make r> create ; + +: ( struct-name vocab type field-name -- spec ) + field-spec new + 0 >>offset + swap >>name + swap expand-constants >>type + 3dup name>> swap reader-word >>reader + 3dup name>> swap writer-word >>writer + 2nip ; + +: align-offset ( offset type -- offset ) + c-type-align align ; + +: struct-offsets ( specs -- size ) + 0 [ + [ type>> align-offset ] keep + [ (>>offset) ] [ type>> heap-size + ] 2bi + ] reduce ; + +: define-struct-slot-word ( spec word quot -- ) + rot offset>> prefix define-inline ; + +: define-getter ( type spec -- ) + [ set-reader-props ] keep + [ ] + [ reader>> ] + [ + type>> + [ c-getter ] [ c-type-boxer-quot ] bi append + ] tri + define-struct-slot-word ; + +: define-setter ( type spec -- ) + [ set-writer-props ] keep + [ ] + [ writer>> ] + [ type>> c-setter ] tri + define-struct-slot-word ; + +: define-field ( type spec -- ) + [ define-getter ] [ define-setter ] 2bi ; diff --git a/core/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor similarity index 52% rename from core/alien/structs/structs-docs.factor rename to basis/alien/structs/structs-docs.factor index baf0b40707..62b8510d17 100755 --- a/core/alien/structs/structs-docs.factor +++ b/basis/alien/structs/structs-docs.factor @@ -1,69 +1,7 @@ +USING: accessors alien.c-types strings help.markup help.syntax +alien.syntax sequences io arrays kernel words assocs namespaces +accessors ; IN: alien.structs -USING: alien.c-types strings help.markup help.syntax -alien.syntax sequences io arrays slots.deprecated -kernel words slots assocs namespaces ; - -! Deprecated code -: ($spec-reader-values) ( slot-spec class -- element ) - dup ?word-name swap 2array - over slot-spec-name - rot slot-spec-type 2array 2array - [ { $instance } swap suffix ] assoc-map ; - -: $spec-reader-values ( slot-spec class -- ) - ($spec-reader-values) $values ; - -: $spec-reader-description ( slot-spec class -- ) - [ - "Outputs the value stored in the " , - { $snippet } rot slot-spec-name suffix , - " slot of " , - { $instance } swap suffix , - " instance." , - ] { } make $description ; - -: $spec-reader ( reader slot-specs class -- ) - >r slot-of-reader r> - over [ - 2dup $spec-reader-values - 2dup $spec-reader-description - ] when 2drop ; - -GENERIC: slot-specs ( help-type -- specs ) - -M: word slot-specs "slots" word-prop ; - -: $slot-reader ( reader -- ) - first dup "reading" word-prop [ slot-specs ] keep - $spec-reader ; - -: $spec-writer-values ( slot-spec class -- ) - ($spec-reader-values) reverse $values ; - -: $spec-writer-description ( slot-spec class -- ) - [ - "Stores a new value to the " , - { $snippet } rot slot-spec-name suffix , - " slot of " , - { $instance } swap suffix , - " instance." , - ] { } make $description ; - -: $spec-writer ( writer slot-specs class -- ) - >r slot-of-writer r> - over [ - 2dup $spec-writer-values - 2dup $spec-writer-description - dup ?word-name 1array $side-effects - ] when 2drop ; - -: $slot-writer ( reader -- ) - first dup "writing" word-prop [ slot-specs ] keep - $spec-writer ; - -M: string slot-specs c-type struct-type-fields ; - -M: array ($instance) first ($instance) " array" write ; ARTICLE: "c-structs" "C structure types" "A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address." diff --git a/core/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor similarity index 92% rename from core/alien/structs/structs-tests.factor rename to basis/alien/structs/structs-tests.factor index bfdcd31b99..8c7d9f9b29 100644 --- a/core/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -7,7 +7,7 @@ C-STRUCT: bar { { "int" 8 } "y" } ; [ 36 ] [ "bar" heap-size ] unit-test -[ t ] [ \ "bar" c-type c-type-getter memq? ] unit-test +[ t ] [ \ "bar" c-type-getter memq? ] unit-test C-STRUCT: align-test { "int" "x" } diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor new file mode 100755 index 0000000000..e82d663d08 --- /dev/null +++ b/basis/alien/structs/structs.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays generic hashtables kernel kernel.private +math namespaces parser sequences strings words libc +alien.c-types alien.structs.fields cpu.architecture ; +IN: alien.structs + +: if-value-structs? ( ctype true false -- ) + value-structs? + [ drop call ] [ >r 2drop "void*" r> call ] if ; inline + +TUPLE: struct-type size align fields ; + +M: struct-type heap-size size>> ; + +M: struct-type c-type-align align>> ; + +M: struct-type c-type-stack-align? drop f ; + +M: struct-type unbox-parameter + [ heap-size %unbox-struct ] + [ unbox-parameter ] + if-value-structs? ; + +M: struct-type unbox-return + f swap heap-size %unbox-struct ; + +M: struct-type box-parameter + [ heap-size %box-struct ] + [ box-parameter ] + if-value-structs? ; + +M: struct-type box-return + f swap heap-size %box-struct ; + +M: struct-type stack-size + [ heap-size ] [ stack-size ] if-value-structs? ; + +: c-struct? ( type -- ? ) (c-type) struct-type? ; + +: (define-struct) ( name vocab size align fields -- ) + >r [ align ] keep r> + struct-type boa + -rot define-c-type ; + +: define-struct-early ( name vocab fields -- fields ) + -rot [ rot first2 ] 2curry map ; + +: compute-struct-align ( types -- n ) + [ c-type-align ] map supremum ; + +: define-struct ( name vocab fields -- ) + pick >r + [ struct-offsets ] keep + [ [ type>> ] map compute-struct-align ] keep + [ (define-struct) ] keep + r> [ swap define-field ] curry each ; + +: define-union ( name vocab members -- ) + [ expand-constants ] map + [ [ heap-size ] map supremum ] keep + compute-struct-align f (define-struct) ; diff --git a/core/alien/structs/summary.txt b/basis/alien/structs/summary.txt similarity index 100% rename from core/alien/structs/summary.txt rename to basis/alien/structs/summary.txt diff --git a/core/alien/syntax/authors.txt b/basis/alien/syntax/authors.txt similarity index 100% rename from core/alien/syntax/authors.txt rename to basis/alien/syntax/authors.txt diff --git a/core/alien/syntax/summary.txt b/basis/alien/syntax/summary.txt similarity index 100% rename from core/alien/syntax/summary.txt rename to basis/alien/syntax/summary.txt diff --git a/core/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor similarity index 97% rename from core/alien/syntax/syntax-docs.factor rename to basis/alien/syntax/syntax-docs.factor index 6565ea0e2c..37cbd12801 100755 --- a/core/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -11,7 +11,7 @@ HELP: ALIEN: { $syntax "ALIEN: address" } { $values { "address" "a non-negative integer" } } { $description "Creates an alien object at parse time." } -{ $notes "Alien objects are invalidated between image saves and loads." } ; +{ $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ; ARTICLE: "syntax-aliens" "Alien object literal syntax" { $subsection POSTPONE: ALIEN: } diff --git a/core/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor similarity index 82% rename from core/alien/syntax/syntax.factor rename to basis/alien/syntax/syntax.factor index b2e819f8fb..7629897fc0 100755 --- a/core/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays alien alien.c-types alien.structs alien.arrays -alien.strings kernel math namespaces parser sequences words -quotations math.parser splitting effects prettyprint -prettyprint.sections prettyprint.backend assocs combinators ; +USING: accessors arrays alien alien.c-types alien.structs +alien.arrays alien.strings kernel math namespaces parser +sequences words quotations math.parser splitting grouping +effects prettyprint prettyprint.sections prettyprint.backend +assocs combinators lexer strings.parser ; IN: alien.syntax : ALIEN: scan string>number parsed ; parsing +: BAD-ALIEN parsed ; parsing + : LIBRARY: scan "c-library" set ; parsing : FUNCTION: @@ -66,7 +69,7 @@ PRIVATE> M: alien pprint* { - { [ dup expired? ] [ drop "( alien expired )" text ] } + { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] } { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } cond ; diff --git a/extra/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor similarity index 100% rename from extra/ascii/ascii-docs.factor rename to basis/ascii/ascii-docs.factor diff --git a/extra/ascii/ascii-tests.factor b/basis/ascii/ascii-tests.factor similarity index 100% rename from extra/ascii/ascii-tests.factor rename to basis/ascii/ascii-tests.factor diff --git a/extra/ascii/ascii.factor b/basis/ascii/ascii.factor similarity index 77% rename from extra/ascii/ascii.factor rename to basis/ascii/ascii.factor index 30b801a950..c009c66cde 100755 --- a/extra/ascii/ascii.factor +++ b/basis/ascii/ascii.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.order sequences ; +USING: kernel math math.order sequences +combinators.short-circuit ; IN: ascii : blank? ( ch -- ? ) " \t\n\r" member? ; inline @@ -20,7 +21,7 @@ IN: ascii dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline : Letter? ( ch -- ? ) - dup letter? [ drop t ] [ LETTER? ] if ; inline + [ [ letter? ] [ LETTER? ] ] 1|| ; : alpha? ( ch -- ? ) - dup Letter? [ drop t ] [ digit? ] if ; inline + [ [ Letter? ] [ digit? ] ] 1|| ; diff --git a/core/bit-arrays/authors.txt b/basis/ascii/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from core/bit-arrays/authors.txt rename to basis/ascii/authors.txt diff --git a/extra/ascii/summary.txt b/basis/ascii/summary.txt similarity index 100% rename from extra/ascii/summary.txt rename to basis/ascii/summary.txt diff --git a/core/io/encodings/utf16/tags.txt b/basis/ascii/tags.txt old mode 100644 new mode 100755 similarity index 100% rename from core/io/encodings/utf16/tags.txt rename to basis/ascii/tags.txt diff --git a/extra/base64/authors.txt b/basis/base64/authors.txt similarity index 100% rename from extra/base64/authors.txt rename to basis/base64/authors.txt diff --git a/extra/base64/base64-docs.factor b/basis/base64/base64-docs.factor similarity index 100% rename from extra/base64/base64-docs.factor rename to basis/base64/base64-docs.factor diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor new file mode 100644 index 0000000000..9958e7943f --- /dev/null +++ b/basis/base64/base64-tests.factor @@ -0,0 +1,19 @@ +USING: kernel tools.test base64 strings ; +IN: base64.tests + +[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string +] unit-test +[ "" ] [ "" >base64 base64> >string ] unit-test +[ "a" ] [ "a" >base64 base64> >string ] unit-test +[ "ab" ] [ "ab" >base64 base64> >string ] unit-test +[ "abc" ] [ "abc" >base64 base64> >string ] unit-test + +! From http://en.wikipedia.org/wiki/Base64 +[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ] +[ + "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure." + >base64 >string +] unit-test + +\ >base64 must-infer +\ base64> must-infer diff --git a/extra/base64/base64.factor b/basis/base64/base64.factor similarity index 60% rename from extra/base64/base64.factor rename to basis/base64/base64.factor index 074640c536..747cfa1128 100644 --- a/extra/base64/base64.factor +++ b/basis/base64/base64.factor @@ -1,11 +1,12 @@ -USING: kernel math sequences namespaces io.binary splitting - strings hashtables ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences io.binary splitting grouping ; IN: base64 r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; + >r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline : ch>base64 ( ch -- ch ) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; @@ -20,28 +21,26 @@ IN: base64 } nth ; : encode3 ( seq -- seq ) - be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] with map ; + be> 4 [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ; : decode4 ( str -- str ) - [ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ; + 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ; : >base64-rem ( str -- str ) - [ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ; + [ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ; PRIVATE> : >base64 ( seq -- base64 ) #! cut string into two pieces, convert 3 bytes at a time #! pad string with = when not enough bits - dup length dup 3 mod - cut swap - [ - 3 [ encode3 % ] each - dup empty? [ drop ] [ >base64-rem % ] if - ] "" make ; + dup length dup 3 mod - cut + [ 3 [ encode3 ] map concat ] + [ [ "" ] [ >base64-rem ] if-empty ] + bi* append ; : base64> ( base64 -- str ) #! input length must be a multiple of 4 - [ - [ 4 [ decode4 % ] each ] keep [ CHAR: = = not ] count-end - ] SBUF" " make swap [ dup pop* ] times >string ; - + [ 4 [ decode4 ] map concat ] + [ [ CHAR: = = not ] count-end ] + bi head* ; diff --git a/extra/base64/summary.txt b/basis/base64/summary.txt similarity index 100% rename from extra/base64/summary.txt rename to basis/base64/summary.txt diff --git a/core/bootstrap/compiler/authors.txt b/basis/biassocs/authors.txt similarity index 100% rename from core/bootstrap/compiler/authors.txt rename to basis/biassocs/authors.txt diff --git a/basis/biassocs/biassocs-docs.factor b/basis/biassocs/biassocs-docs.factor new file mode 100644 index 0000000000..1fde3d05b3 --- /dev/null +++ b/basis/biassocs/biassocs-docs.factor @@ -0,0 +1,28 @@ +IN: biassocs +USING: help.markup help.syntax assocs kernel ; + +HELP: biassoc +{ $class-description "The class of bidirectional assocs. Bidirectional assoc are implemented by combining two assocs, with one the transpose of the other." } ; + +HELP: +{ $values { "exemplar" assoc } { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a new assoc of the same type as " { $snippet "exemplar" } " for underlying storage." } ; + +HELP: +{ $values { "biassoc" biassoc } } +{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ; + +HELP: once-at +{ $values { "value" object } { "key" object } { "assoc" assoc } } +{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ; + +ARTICLE: "biassocs" "Bidirectional assocs" +"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." +$nl +"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." +{ $subsection biassoc } +{ $subsection biassoc? } +{ $subsection } +{ $subsection } ; + +ABOUT: "biassocs" diff --git a/basis/biassocs/biassocs-tests.factor b/basis/biassocs/biassocs-tests.factor new file mode 100644 index 0000000000..4cd7f00f80 --- /dev/null +++ b/basis/biassocs/biassocs-tests.factor @@ -0,0 +1,22 @@ +IN: biassocs.tests +USING: biassocs assocs namespaces tools.test ; + + "h" set + +[ 0 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 2 "h" get set-at ] unit-test + +[ 1 ] [ 2 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 1 ] [ "h" get assoc-size ] unit-test + +[ ] [ 1 3 "h" get set-at ] unit-test + +[ 1 ] [ 3 "h" get at ] unit-test + +[ 2 ] [ 1 "h" get value-at ] unit-test + +[ 2 ] [ "h" get assoc-size ] unit-test diff --git a/basis/biassocs/biassocs.factor b/basis/biassocs/biassocs.factor new file mode 100644 index 0000000000..a9f0cabd10 --- /dev/null +++ b/basis/biassocs/biassocs.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs accessors summary ; +IN: biassocs + +TUPLE: biassoc from to ; + +: ( exemplar -- biassoc ) + [ clone ] [ clone ] bi biassoc boa ; + +: ( -- biassoc ) + H{ } ; + +M: biassoc assoc-size from>> assoc-size ; + +M: biassoc at* from>> at* ; + +M: biassoc value-at* to>> at* ; + +: once-at ( value key assoc -- ) + 2dup key? [ 3drop ] [ set-at ] if ; + +M: biassoc set-at + [ from>> set-at ] [ swapd to>> once-at ] 3bi ; + +ERROR: no-biassoc-deletion ; + +M: no-biassoc-deletion summary + drop "biassocs do not support deletion" ; + +M: biassoc delete-at + no-biassoc-deletion ; + +M: biassoc >alist + from>> >alist ; + +M: biassoc clear-assoc + [ from>> clear-assoc ] [ to>> clear-assoc ] bi ; + +INSTANCE: biassoc assoc diff --git a/basis/biassocs/summary.txt b/basis/biassocs/summary.txt new file mode 100644 index 0000000000..84c5b15afc --- /dev/null +++ b/basis/biassocs/summary.txt @@ -0,0 +1 @@ +Bidirectional assocs diff --git a/core/bit-arrays/tags.txt b/basis/biassocs/tags.txt similarity index 100% rename from core/bit-arrays/tags.txt rename to basis/biassocs/tags.txt diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor new file mode 100644 index 0000000000..8b85e078ce --- /dev/null +++ b/basis/binary-search/binary-search-docs.factor @@ -0,0 +1,43 @@ +IN: binary-search +USING: help.markup help.syntax sequences kernel math.order ; + +ARTICLE: "binary-search" "Binary search" +"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time." +{ $subsection search } +"Variants of sequence words optimized for sorted sequences:" +{ $subsection sorted-index } +{ $subsection sorted-member? } +{ $subsection sorted-memq? } +{ $see-also "order-specifiers" "sequences-sorting" } ; + +ABOUT: "binary-search" + +HELP: search +{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } } +{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")." +$nl +"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "." +$nl +"If the sequence is empty, outputs " { $link f } " " { $link f } "." } +{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ; + +{ find find-from find-last find-last find-last-from search } related-words + +HELP: sorted-index +{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } } +{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." } +{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ; + +{ index index-from last-index last-index-from sorted-index } related-words + +HELP: sorted-member? +{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } } +{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ; + +{ member? sorted-member? } related-words + +HELP: sorted-memq? +{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } } +{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ; + +{ memq? sorted-memq? } related-words diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor new file mode 100644 index 0000000000..77b1c16505 --- /dev/null +++ b/basis/binary-search/binary-search-tests.factor @@ -0,0 +1,17 @@ +IN: binary-search.tests +USING: binary-search math.order vectors kernel tools.test ; + +\ sorted-member? must-infer + +[ f ] [ 3 { } [ <=> ] with search drop ] unit-test +[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test +[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test +[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test +[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test +[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test +[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test + +[ t ] [ "hello" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test +[ 3 ] [ "hey" { "alligrator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test +[ f ] [ "hello" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test +[ f ] [ "zebra" { "alligrator" "cat" "fish" "ikarus" "java" } sorted-member? ] unit-test diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor new file mode 100644 index 0000000000..f29e05c023 --- /dev/null +++ b/basis/binary-search/binary-search.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences sequences.private accessors math +math.order combinators hints arrays ; +IN: binary-search + + ) + [ midpoint swap call ] 2keep rot ; inline + +: finish ( quot slice -- i elt ) + [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi + [ drop ] [ dup ] [ ] tri* nth ; inline + +: (search) ( quot: ( elt -- <=> ) seq -- i elt ) + dup length 1 <= [ + finish + ] [ + decide { + { +eq+ [ finish ] } + { +lt+ [ dup midpoint@ head-slice (search) ] } + { +gt+ [ dup midpoint@ tail-slice (search) ] } + } case + ] if ; inline recursive + +PRIVATE> + +: search ( seq quot -- i elt ) + over empty? [ 2drop f f ] [ swap (search) ] if ; + inline + +: natural-search ( obj seq -- i elt ) + [ <=> ] with search ; + +HINTS: natural-search array ; + +: sorted-index ( obj seq -- i ) + natural-search drop ; + +: sorted-member? ( obj seq -- ? ) + dupd natural-search nip = ; + +: sorted-memq? ( obj seq -- ? ) + dupd natural-search nip eq? ; diff --git a/core/bootstrap/image/authors.txt b/basis/bit-arrays/authors.txt similarity index 100% rename from core/bootstrap/image/authors.txt rename to basis/bit-arrays/authors.txt diff --git a/core/bit-arrays/bit-arrays-docs.factor b/basis/bit-arrays/bit-arrays-docs.factor similarity index 51% rename from core/bit-arrays/bit-arrays-docs.factor rename to basis/bit-arrays/bit-arrays-docs.factor index f804ed21f4..fab2a62062 100644 --- a/core/bit-arrays/bit-arrays-docs.factor +++ b/basis/bit-arrays/bit-arrays-docs.factor @@ -1,9 +1,9 @@ USING: arrays help.markup help.syntax kernel -kernel.private prettyprint strings vectors sbufs ; +kernel.private math prettyprint strings vectors sbufs ; IN: bit-arrays ARTICLE: "bit-arrays" "Bit arrays" -"Bit array are a fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are either " { $link t } " or " { $link f } ". Each element only uses one bit of storage, hence the name. The literal syntax is covered in " { $link "syntax-bit-arrays" } "." +"Bit array are a fixed-size mutable sequences (" { $link "sequence-protocol" } ") whose elements are either " { $link t } " or " { $link f } ". Each element only uses one bit of storage, hence the name." $nl "Bit array words are in the " { $vocab-link "bit-arrays" } " vocabulary." $nl @@ -17,12 +17,23 @@ $nl { $subsection } "Efficiently setting and clearing all bits in a bit array:" { $subsection set-bits } -{ $subsection clear-bits } ; +{ $subsection clear-bits } +"Converting between unsigned integers and their binary representation:" +{ $subsection integer>bit-array } +{ $subsection bit-array>integer } +"Bit array literal syntax:" +{ $subsection POSTPONE: ?{ } ; ABOUT: "bit-arrays" +HELP: ?{ +{ $syntax "?{ elements... }" } +{ $values { "elements" "a list of booleans" } } +{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "?{ t f t }" } } ; + HELP: bit-array -{ $description "The class of fixed-length bit arrays. See " { $link "syntax-bit-arrays" } " for syntax and " { $link "bit-arrays" } " for general information." } ; +{ $description "The class of fixed-length bit arrays." } ; HELP: ( n -- bit-array ) { $values { "n" "a non-negative integer" } { "bit-array" "a new " { $link bit-array } } } @@ -47,3 +58,13 @@ HELP: set-bits { $code "[ drop t ] change-each" } } { $side-effects "bit-array" } ; + +HELP: integer>bit-array +{ $values { "n" integer } { "bit-array" bit-array } } +{ $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." } +{ $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ; + +HELP: bit-array>integer +{ $values { "bit-array" bit-array } { "n" integer } } +{ $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." } +{ $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ; diff --git a/basis/bit-arrays/bit-arrays-tests.factor b/basis/bit-arrays/bit-arrays-tests.factor new file mode 100755 index 0000000000..a5ae23dde6 --- /dev/null +++ b/basis/bit-arrays/bit-arrays-tests.factor @@ -0,0 +1,78 @@ +USING: sequences sequences.private arrays bit-arrays kernel +tools.test math random ; +IN: bit-arrays.tests + +[ 100 ] [ 100 length ] unit-test + +[ + { t f t } +] [ + 3 t 0 pick set-nth t 2 pick set-nth + >array +] unit-test + +[ + { t f t } +] [ + { t f t } >bit-array >array +] unit-test + +[ + { t f t } { f t f } +] [ + { t f t } >bit-array dup clone dup [ not ] change-each + [ >array ] bi@ +] unit-test + +[ + { f f f f f } +] [ + { t f t t f } >bit-array dup clear-bits >array +] unit-test + +[ + { t t t t t } +] [ + { t f t t f } >bit-array dup set-bits >array +] unit-test + +[ t ] [ + 100 [ + drop 100 [ 2 random zero? ] replicate + dup >bit-array >array = + ] all? +] unit-test + +[ ?{ f } ] [ + 1 2 { t f t f } >bit-array +] unit-test + +[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test + +[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize ] unit-test + +[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize ] unit-test + +[ -10 ?{ } resize ] must-fail + +[ -1 integer>bit-array ] must-fail +[ ?{ } ] [ 0 integer>bit-array ] unit-test +[ ?{ f t } ] [ 2 integer>bit-array ] unit-test +[ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test +[ ?{ + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t +} ] [ + HEX: ffffffffffffffffffffffffffffffff integer>bit-array +] unit-test + +[ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test +[ 0 ] [ ?{ } bit-array>integer ] unit-test +[ HEX: ffffffffffffffffffffffffffffffff ] [ ?{ + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t + t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t +} bit-array>integer ] unit-test diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor new file mode 100755 index 0000000000..11601f7b63 --- /dev/null +++ b/basis/bit-arrays/bit-arrays.factor @@ -0,0 +1,95 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types accessors math alien.accessors kernel +kernel.private locals sequences sequences.private byte-arrays +parser prettyprint.backend ; +IN: bit-arrays + +TUPLE: bit-array +{ length array-capacity read-only } +{ underlying byte-array read-only } ; + +byte -3 shift ; inline + +: byte/bit ( n alien -- byte bit ) + over n>byte alien-unsigned-1 swap 7 bitand ; inline + +: set-bit ( ? byte bit -- byte ) + 2^ rot [ bitor ] [ bitnot bitand ] if ; inline + +: bits>cells 31 + -5 shift ; inline + +: bits>bytes 7 + n>byte ; inline + +: (set-bits) ( bit-array n -- ) + [ [ length bits>cells ] keep ] dip + [ -rot underlying>> set-uint-nth ] 2curry + each ; inline + +PRIVATE> + +: ( n -- bit-array ) + dup bits>bytes bit-array boa ; inline + +M: bit-array length length>> ; + +M: bit-array nth-unsafe + [ >fixnum ] [ underlying>> ] bi* byte/bit bit? ; + +M: bit-array set-nth-unsafe + [ >fixnum ] [ underlying>> ] bi* + [ byte/bit set-bit ] 2keep + swap n>byte set-alien-unsigned-1 ; + +: clear-bits ( bit-array -- ) 0 (set-bits) ; + +: set-bits ( bit-array -- ) -1 (set-bits) ; + +M: bit-array clone + [ length>> ] [ underlying>> clone ] bi bit-array boa ; + +: >bit-array ( seq -- bit-array ) + T{ bit-array f 0 B{ } } clone-like ; inline + +M: bit-array like drop dup bit-array? [ >bit-array ] unless ; + +M: bit-array new-sequence drop ; + +M: bit-array equal? + over bit-array? [ sequence= ] [ 2drop f ] if ; + +M: bit-array resize + [ drop ] [ + [ bits>bytes ] [ underlying>> ] bi* + resize-byte-array + ] 2bi + bit-array boa ; + +M: bit-array byte-length length 7 + -3 shift ; + +: ?{ \ } [ >bit-array ] parse-literal ; parsing + +:: integer>bit-array ( n -- bit-array ) + n zero? [ 0 ] [ + [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | + [ n' zero? not ] [ + n' out underlying>> i set-alien-unsigned-1 + n' -8 shift n'! + i 1+ i! + ] [ ] while + out + ] + ] if ; + +: bit-array>integer ( bit-array -- n ) + 0 swap underlying>> [ length ] keep [ + uchar-nth swap 8 shift bitor + ] curry each ; + +INSTANCE: bit-array sequence + +M: bit-array pprint-delims drop \ ?{ \ } ; +M: bit-array >pprint-sequence ; +M: bit-array pprint* pprint-object ; diff --git a/core/bit-arrays/summary.txt b/basis/bit-arrays/summary.txt similarity index 100% rename from core/bit-arrays/summary.txt rename to basis/bit-arrays/summary.txt diff --git a/core/dlists/tags.txt b/basis/bit-arrays/tags.txt similarity index 100% rename from core/dlists/tags.txt rename to basis/bit-arrays/tags.txt diff --git a/extra/bit-vectors/bit-vectors-docs.factor b/basis/bit-vectors/bit-vectors-docs.factor similarity index 72% rename from extra/bit-vectors/bit-vectors-docs.factor rename to basis/bit-vectors/bit-vectors-docs.factor index 41f32b4cdb..f0e4e47586 100755 --- a/extra/bit-vectors/bit-vectors-docs.factor +++ b/basis/bit-vectors/bit-vectors-docs.factor @@ -1,5 +1,5 @@ USING: arrays bit-arrays help.markup help.syntax kernel -bit-vectors.private combinators ; +combinators ; IN: bit-vectors ARTICLE: "bit-vectors" "Bit vectors" @@ -29,11 +29,6 @@ HELP: >bit-vector { $values { "seq" "a sequence" } { "bit-vector" bit-vector } } { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ; -HELP: bit-array>vector -{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } } -{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." } -{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ; - HELP: ?V{ { $syntax "?V{ elements... }" } { $values { "elements" "a list of booleans" } } diff --git a/extra/bit-vectors/bit-vectors-tests.factor b/basis/bit-vectors/bit-vectors-tests.factor similarity index 100% rename from extra/bit-vectors/bit-vectors-tests.factor rename to basis/bit-vectors/bit-vectors-tests.factor diff --git a/extra/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor similarity index 57% rename from extra/bit-vectors/bit-vectors.factor rename to basis/bit-vectors/bit-vectors.factor index c14b0a5476..404b26829b 100755 --- a/extra/bit-vectors/bit-vectors.factor +++ b/basis/bit-vectors/bit-vectors.factor @@ -5,25 +5,12 @@ sequences.private growable bit-arrays prettyprint.backend parser accessors ; IN: bit-vectors -TUPLE: bit-vector underlying fill ; - -M: bit-vector underlying underlying>> { bit-array } declare ; - -M: bit-vector set-underlying (>>underlying) ; - -M: bit-vector length fill>> { array-capacity } declare ; - -M: bit-vector set-fill (>>fill) ; - -vector ( bit-array length -- bit-vector ) - bit-vector boa ; inline - -PRIVATE> +TUPLE: bit-vector +{ underlying bit-array initial: ?{ } } +{ length array-capacity } ; : ( n -- bit-vector ) - 0 bit-array>vector ; inline + 0 bit-vector boa ; inline : >bit-vector ( seq -- bit-vector ) T{ bit-vector f ?{ } 0 } clone-like ; @@ -31,11 +18,11 @@ PRIVATE> M: bit-vector like drop dup bit-vector? [ dup bit-array? - [ dup length bit-array>vector ] [ >bit-vector ] if + [ dup length bit-vector boa ] [ >bit-vector ] if ] unless ; M: bit-vector new-sequence - drop [ ] keep >fixnum bit-array>vector ; + drop [ ] [ >fixnum ] bi bit-vector boa ; M: bit-vector equal? over bit-vector? [ sequence= ] [ 2drop f ] if ; @@ -47,5 +34,5 @@ INSTANCE: bit-vector growable : ?V{ \ } [ >bit-vector ] parse-literal ; parsing M: bit-vector >pprint-sequence ; - M: bit-vector pprint-delims drop \ ?V{ \ } ; +M: bit-vector pprint* pprint-object ; diff --git a/extra/bit-vectors/summary.txt b/basis/bit-vectors/summary.txt similarity index 100% rename from extra/bit-vectors/summary.txt rename to basis/bit-vectors/summary.txt diff --git a/core/float-arrays/tags.txt b/basis/bit-vectors/tags.txt similarity index 100% rename from core/float-arrays/tags.txt rename to basis/bit-vectors/tags.txt diff --git a/core/command-line/authors.txt b/basis/bootstrap/compiler/authors.txt similarity index 100% rename from core/command-line/authors.txt rename to basis/bootstrap/compiler/authors.txt diff --git a/core/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor similarity index 55% rename from core/bootstrap/compiler/compiler.factor rename to basis/bootstrap/compiler/compiler.factor index 7ad1c6978b..0b44761f5c 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -1,11 +1,13 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler cpu.architecture vocabs.loader system sequences -namespaces parser kernel kernel.private classes classes.private -arrays hashtables vectors classes.tuple sbufs inference.dataflow +USING: accessors compiler cpu.architecture vocabs.loader system +sequences namespaces parser kernel kernel.private classes +classes.private arrays hashtables vectors classes.tuple sbufs hashtables.private sequences.private math classes.tuple.private -growable namespaces.private assocs words generator command-line -vocabs io prettyprint libc compiler.units math.order ; +growable namespaces.private assocs words command-line vocabs io +io.encodings.string prettyprint libc splitting math.parser +compiler.units math.order compiler.tree.builder +compiler.tree.optimizer ; IN: bootstrap.compiler ! Don't bring this in when deploying, since it will store a @@ -14,11 +16,12 @@ IN: bootstrap.compiler "alien.remote-control" require ] unless -"cpu." cpu word-name append require +"cpu." cpu name>> append require enable-compiler -: compile-uncompiled [ compiled? not ] filter compile ; +: compile-uncompiled ( words -- ) + [ compiled>> not ] filter compile ; nl "Compiling..." write flush @@ -33,16 +36,18 @@ nl roll -roll declare not array? hashtable? vector? - tuple? sbuf? node? tombstone? + tuple? sbuf? tombstone? - array-capacity array-nth set-array-nth + array-nth set-array-nth wrap probe - underlying + namestack* +} compile-uncompiled - find-pair-next namestack* +"." write flush +{ bitand bitor bitxor bitnot } compile-uncompiled @@ -67,15 +72,27 @@ nl "." write flush { - . lines + memq? split harvest sift cut cut-slice start index clone + set-at reverse push-all class number>string string>number } compile-uncompiled "." write flush { - malloc calloc free memcpy + lines prefix suffix unclip new-assoc update + word-prop set-word-prop 1array 2array 3array ?nth } compile-uncompiled +"." write flush + +{ + . malloc calloc free memcpy +} compile-uncompiled + +{ build-tree } compile-uncompiled + +{ optimize-tree } compile-uncompiled + vocabs [ words compile-uncompiled "." write flush ] each " done" print flush diff --git a/core/bootstrap/compiler/summary.txt b/basis/bootstrap/compiler/summary.txt similarity index 100% rename from core/bootstrap/compiler/summary.txt rename to basis/bootstrap/compiler/summary.txt diff --git a/extra/bootstrap/handbook/handbook.factor b/basis/bootstrap/handbook/handbook.factor similarity index 77% rename from extra/bootstrap/handbook/handbook.factor rename to basis/bootstrap/handbook/handbook.factor index 2ffb77de7a..51aa9eefaf 100755 --- a/extra/bootstrap/handbook/handbook.factor +++ b/basis/bootstrap/handbook/handbook.factor @@ -1,3 +1,4 @@ USING: vocabs.loader vocabs kernel ; +IN: bootstrap.handbook "bootstrap.help" vocab [ "help.handbook" require ] when diff --git a/core/compiler/authors.txt b/basis/bootstrap/help/authors.txt similarity index 100% rename from core/compiler/authors.txt rename to basis/bootstrap/help/authors.txt diff --git a/extra/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor similarity index 95% rename from extra/bootstrap/help/help.factor rename to basis/bootstrap/help/help.factor index 9dd4fd04b2..e2a2288988 100755 --- a/extra/bootstrap/help/help.factor +++ b/basis/bootstrap/help/help.factor @@ -3,7 +3,7 @@ help.definitions io io.files kernel namespaces vocabs sequences parser vocabs.loader ; IN: bootstrap.help -: load-help +: load-help ( -- ) "alien.syntax" require "compiler" require diff --git a/extra/bootstrap/help/summary.txt b/basis/bootstrap/help/summary.txt similarity index 100% rename from extra/bootstrap/help/summary.txt rename to basis/bootstrap/help/summary.txt diff --git a/core/compiler/constants/authors.txt b/basis/bootstrap/image/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/compiler/constants/authors.txt rename to basis/bootstrap/image/authors.txt diff --git a/core/cpu/architecture/authors.txt b/basis/bootstrap/image/download/authors.txt similarity index 100% rename from core/cpu/architecture/authors.txt rename to basis/bootstrap/image/download/authors.txt diff --git a/extra/bootstrap/image/download/download.factor b/basis/bootstrap/image/download/download.factor similarity index 69% rename from extra/bootstrap/image/download/download.factor rename to basis/bootstrap/image/download/download.factor index c2e80fee9a..71aa2e8adc 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/basis/bootstrap/image/download/download.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: bootstrap.image.download USING: http.client checksums checksums.openssl splitting assocs -kernel io.files bootstrap.image sequences io ; +kernel io.files bootstrap.image sequences io urls ; +IN: bootstrap.image.download -: url "http://factorcode.org/images/latest/" ; +: url URL" http://factorcode.org/images/latest/" ; : download-checksums ( -- alist ) - url "checksums.txt" append http-get + url "checksums.txt" >url derive-url http-get nip string-lines [ " " split1 ] { } map>assoc ; : need-new-image? ( image -- ? ) @@ -21,7 +21,10 @@ kernel io.files bootstrap.image sequences io ; : download-image ( arch -- ) boot-image-name dup need-new-image? [ "Downloading " write dup write "..." print - url prepend download + url over >url derive-url download + need-new-image? [ + "Boot image corrupt, or checksums.txt on server out of date" throw + ] when ] [ "Boot image up to date" print drop diff --git a/extra/bootstrap/image/download/summary.txt b/basis/bootstrap/image/download/summary.txt similarity index 100% rename from extra/bootstrap/image/download/summary.txt rename to basis/bootstrap/image/download/summary.txt diff --git a/core/bootstrap/image/image-docs.factor b/basis/bootstrap/image/image-docs.factor similarity index 100% rename from core/bootstrap/image/image-docs.factor rename to basis/bootstrap/image/image-docs.factor diff --git a/core/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor similarity index 100% rename from core/bootstrap/image/image-tests.factor rename to basis/bootstrap/image/image-tests.factor diff --git a/core/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor similarity index 80% rename from core/bootstrap/image/image.factor rename to basis/bootstrap/image/image.factor index aa7377adbf..9c99ed5cdb 100755 --- a/core/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,19 +1,19 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays bit-arrays byte-arrays generic assocs -hashtables assocs hashtables.private io kernel kernel.private -math namespaces parser prettyprint sequences sequences.private -strings sbufs vectors words quotations assocs system layouts -splitting growable classes classes.builtin classes.tuple +USING: alien arrays byte-arrays generic assocs hashtables assocs +hashtables.private io kernel kernel.private math namespaces +parser prettyprint sequences sequences.private strings sbufs +vectors words quotations assocs system layouts splitting +grouping growable classes classes.builtin classes.tuple classes.tuple.private words.private io.binary io.files vocabs -vocabs.loader source-files definitions debugger float-arrays +vocabs.loader source-files definitions debugger quotations.private sequences.private combinators -io.encodings.binary math.order accessors ; +io.encodings.binary math.order math.private accessors slots.private ; IN: bootstrap.image : my-arch ( -- arch ) - cpu word-name - dup "ppc" = [ >r os word-name "-" r> 3append ] when ; + cpu name>> + dup "ppc" = [ >r os name>> "-" r> 3append ] when ; : boot-image-name ( arch -- string ) "boot." swap ".image" 3append ; @@ -75,7 +75,7 @@ SYMBOL: objects : data-base 1024 ; inline -: userenv-size 64 ; inline +: userenv-size 70 ; inline : header-size 10 ; inline @@ -85,15 +85,16 @@ SYMBOL: objects : 1-offset 8 ; inline : -1-offset 9 ; inline -: array-start 2 bootstrap-cells object tag-number - ; -: scan@ array-start bootstrap-cell - ; -: wrapper@ bootstrap-cell object tag-number - ; -: word-xt@ 8 bootstrap-cells object tag-number - ; -: quot-array@ bootstrap-cell object tag-number - ; -: quot-xt@ 3 bootstrap-cells object tag-number - ; +SYMBOL: sub-primitives + +: make-jit ( quot rc rt offset -- quad ) + { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline : jit-define ( quot rc rt offset name -- ) - >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ; + >r make-jit r> set ; inline + +: define-sub-primitive ( quot rc rt offset word -- ) + >r make-jit r> sub-primitives get set-at ; ! The image being constructed; a vector of word-size integers SYMBOL: image @@ -118,6 +119,7 @@ SYMBOL: jit-primitive SYMBOL: jit-word-jump SYMBOL: jit-word-call SYMBOL: jit-push-literal +SYMBOL: jit-push-immediate SYMBOL: jit-if-word SYMBOL: jit-if-jump SYMBOL: jit-dispatch-word @@ -125,6 +127,7 @@ SYMBOL: jit-dispatch SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling +SYMBOL: jit-declare-word ! Default definition for undefined words SYMBOL: undefined-quot @@ -147,7 +150,9 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } - { undefined-quot 37 } + { jit-push-immediate 36 } + { jit-declare-word 42 } + { undefined-quot 60 } } at header-size + ; : emit ( cell -- ) image get push ; @@ -203,15 +208,15 @@ GENERIC: ' ( obj -- ptr ) ! Bignums -: bignum-bits bootstrap-cell-bits 2 - ; +: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ; -: bignum-radix bignum-bits 2^ 1- ; +: bignum-radix ( -- n ) bignum-bits 2^ 1- ; : bignum>seq ( n -- seq ) #! n is positive or zero. [ dup 0 > ] [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ] - [ ] unfold nip ; + [ ] produce nip ; : emit-bignum ( n -- ) dup dup 0 < [ neg ] when bignum>seq @@ -235,6 +240,12 @@ M: fixnum ' bootstrap-most-positive-fixnum between? [ tag-fixnum ] [ >bignum ' ] if ; +TUPLE: fake-bignum n ; + +C: fake-bignum + +M: fake-bignum ' n>> tag-fixnum ; + ! Floats M: float ' @@ -248,18 +259,21 @@ M: float ' ! Padded with fixnums for 8-byte alignment -: t, t t-offset fixup ; +: t, ( -- ) t t-offset fixup ; M: f ' #! f is #define F RETAG(0,F_TYPE) drop \ f tag-number ; -: 0, 0 >bignum ' 0-offset fixup ; -: 1, 1 >bignum ' 1-offset fixup ; -: -1, -1 >bignum ' -1-offset fixup ; +: 0, ( -- ) 0 >bignum ' 0-offset fixup ; +: 1, ( -- ) 1 >bignum ' 1-offset fixup ; +: -1, ( -- ) -1 >bignum ' -1-offset fixup ; ! Words +: word-sub-primitive ( word -- obj ) + global [ target-word ] bind sub-primitives get at ; + : emit-word ( word -- ) [ [ subwords [ emit-word ] each ] @@ -267,16 +281,17 @@ M: f ' [ { [ hashcode , ] - [ word-name , ] - [ word-vocabulary , ] - [ word-def , ] - [ word-props , ] + [ name>> , ] + [ vocabulary>> , ] + [ def>> , ] + [ props>> , ] + [ drop f , ] + [ drop 0 , ] ! count + [ word-sub-primitive , ] + [ drop 0 , ] ! xt + [ drop 0 , ] ! code + [ drop 0 , ] ! profiling } cleave - f , - 0 , ! count - 0 , ! xt - 0 , ! code - 0 , ! profiling ] { } make [ ' ] map ] bi \ word type-number object tag-number @@ -284,7 +299,7 @@ M: f ' ] keep put-object ; : word-error ( word msg -- * ) - [ % dup word-vocabulary % " " % word-name % ] "" make throw ; + [ % dup vocabulary>> % " " % name>> % ] "" make throw ; : transfer-word ( word -- word ) [ target-word ] keep or ; @@ -301,7 +316,7 @@ M: word ' ; ! Wrappers M: wrapper ' - wrapped ' wrapper type-number object tag-number + wrapped>> ' wrapper type-number object tag-number [ emit ] emit-object ; ! Strings @@ -341,18 +356,14 @@ M: byte-array ' pad-bytes emit-bytes ] emit-object ; -M: bit-array ' bit-array emit-dummy-array ; - -M: float-array ' float-array emit-dummy-array ; - ! Tuples : (emit-tuple) ( tuple -- pointer ) - [ tuple>array rest-slice ] + [ tuple-slots ] [ class transfer-word tuple-layout ] bi prefix [ ' ] map tuple type-number dup [ emit-seq ] emit-object ; : emit-tuple ( tuple -- pointer ) - dup class word-name "tombstone" = + dup class name>> "tombstone" = [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ; M: tuple ' emit-tuple ; @@ -361,11 +372,11 @@ M: tuple-layout ' [ [ { - [ layout-hashcode , ] - [ layout-class , ] - [ layout-size , ] - [ layout-superclasses , ] - [ layout-echelon , ] + [ hashcode>> , ] + [ class>> , ] + [ size>> , ] + [ superclasses>> , ] + [ echelon>> , ] } cleave ] { } make [ ' ] map \ tuple-layout type-number @@ -373,9 +384,9 @@ M: tuple-layout ' ] cache-object ; M: tombstone ' - delegate - "((tombstone))" "((empty))" ? "hashtables.private" lookup - word-def first [ emit-tuple ] cache-object ; + state>> "((tombstone))" "((empty))" ? + "hashtables.private" lookup def>> first + [ emit-tuple ] cache-object ; ! Arrays M: array ' @@ -386,10 +397,10 @@ M: array ' M: quotation ' [ - quotation-array ' + array>> ' quotation type-number object tag-number [ emit ! array - f ' emit ! compiled? + f ' emit ! compiled>> 0 emit ! xt 0 emit ! code ] emit-object @@ -404,7 +415,7 @@ M: quotation ' [ { dictionary source-files builtins - update-map class<=-cache + update-map implementors-map class<=-cache class-not-cache classes-intersect-cache class-and-cache class-or-cache } [ dup get swap bootstrap-word set ] each @@ -419,6 +430,7 @@ M: quotation ' \ if jit-if-word set \ dispatch jit-dispatch-word set \ do-primitive jit-primitive-word set + \ declare jit-declare-word set [ undefined ] undefined-quot set { jit-code-format @@ -428,6 +440,7 @@ M: quotation ' jit-word-jump jit-word-call jit-push-literal + jit-push-immediate jit-if-word jit-if-jump jit-dispatch-word @@ -435,6 +448,7 @@ M: quotation ' jit-epilog jit-return jit-profiling + jit-declare-word undefined-quot } [ emit-userenv ] each ; diff --git a/core/bootstrap/image/summary.txt b/basis/bootstrap/image/summary.txt similarity index 100% rename from core/bootstrap/image/summary.txt rename to basis/bootstrap/image/summary.txt diff --git a/core/bootstrap/image/tags.txt b/basis/bootstrap/image/tags.txt similarity index 100% rename from core/bootstrap/image/tags.txt rename to basis/bootstrap/image/tags.txt diff --git a/core/cpu/arm/4/authors.txt b/basis/bootstrap/image/upload/authors.txt similarity index 100% rename from core/cpu/arm/4/authors.txt rename to basis/bootstrap/image/upload/authors.txt diff --git a/extra/bootstrap/image/upload/summary.txt b/basis/bootstrap/image/upload/summary.txt similarity index 100% rename from extra/bootstrap/image/upload/summary.txt rename to basis/bootstrap/image/upload/summary.txt diff --git a/extra/bootstrap/image/upload/upload.factor b/basis/bootstrap/image/upload/upload.factor similarity index 89% rename from extra/bootstrap/image/upload/upload.factor rename to basis/bootstrap/image/upload/upload.factor index 29c9d5b072..de13b4aed4 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/basis/bootstrap/image/upload/upload.factor @@ -12,9 +12,9 @@ SYMBOL: upload-images-destination "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/" or ; -: checksums "checksums.txt" temp-file ; +: checksums ( -- temp ) "checksums.txt" temp-file ; -: boot-image-names images [ boot-image-name ] map ; +: boot-image-names ( -- seq ) images [ boot-image-name ] map ; : compute-checksums ( -- ) checksums ascii [ diff --git a/core/cpu/arm/allot/authors.txt b/basis/bootstrap/io/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/cpu/arm/allot/authors.txt rename to basis/bootstrap/io/authors.txt diff --git a/extra/bootstrap/io/io.factor b/basis/bootstrap/io/io.factor similarity index 100% rename from extra/bootstrap/io/io.factor rename to basis/bootstrap/io/io.factor diff --git a/extra/bootstrap/io/summary.txt b/basis/bootstrap/io/summary.txt similarity index 100% rename from extra/bootstrap/io/summary.txt rename to basis/bootstrap/io/summary.txt diff --git a/extra/bootstrap/math/math.factor b/basis/bootstrap/math/math.factor similarity index 100% rename from extra/bootstrap/math/math.factor rename to basis/bootstrap/math/math.factor diff --git a/extra/bootstrap/math/summary.txt b/basis/bootstrap/math/summary.txt similarity index 100% rename from extra/bootstrap/math/summary.txt rename to basis/bootstrap/math/summary.txt diff --git a/extra/bootstrap/random/random.factor b/basis/bootstrap/random/random.factor similarity index 94% rename from extra/bootstrap/random/random.factor rename to basis/bootstrap/random/random.factor index 5f5e11d913..3782d517cf 100755 --- a/extra/bootstrap/random/random.factor +++ b/basis/bootstrap/random/random.factor @@ -1,6 +1,7 @@ USING: vocabs.loader sequences system random random.mersenne-twister combinators init namespaces random ; +IN: bootstrap.random "random.mersenne-twister" require diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor new file mode 100755 index 0000000000..58ea725d1e --- /dev/null +++ b/basis/bootstrap/stage2.factor @@ -0,0 +1,107 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors init namespaces words io +kernel.private math memory continuations kernel io.files +io.backend system parser vocabs sequences prettyprint +vocabs.loader combinators splitting source-files strings +definitions assocs compiler.errors compiler.units +math.parser generic sets debugger command-line ; +IN: bootstrap.stage2 + +SYMBOL: bootstrap-time + +: default-image-name ( -- string ) + vm file-name os windows? [ "." split1 drop ] when + ".image" append resource-path ; + +: do-crossref ( -- ) + "Cross-referencing..." print flush + H{ } clone crossref set-global + xref-words + xref-generics + xref-sources ; + +: load-components ( -- ) + "include" "exclude" + [ get-global " " split harvest ] bi@ + diff + [ "bootstrap." prepend require ] each ; + +: count-words ( pred -- ) + all-words swap count number>string write ; + +: print-report ( time -- ) + 1000 /i + 60 /mod swap + "Bootstrap completed in " write number>string write + " minutes and " write number>string write " seconds." print + + [ compiled>> ] count-words " compiled words" print + [ symbol? ] count-words " symbol words" print + [ ] count-words " words total" print + + "Bootstrapping is complete." print + "Now, you can run Factor:" print + vm write " -i=" write "output-image" get print flush ; + +[ + ! We time bootstrap + millis >r + + default-image-name "output-image" set-global + + "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global + "" "exclude" set-global + + parse-command-line + + "-no-crossref" cli-args member? [ do-crossref ] unless + + ! Set dll paths + os wince? [ "windows.ce" require ] when + os winnt? [ "windows.nt" require ] when + + "deploy-vocab" get [ + "stage2: deployment mode" print + ] [ + "listener" require + "none" require + ] if + + [ + load-components + + run-bootstrap-init + ] with-compiler-errors + :errors + + f error set-global + f error-continuation set-global + + "deploy-vocab" get [ + "tools.deploy.shaker" run + ] [ + [ + boot + do-init-hooks + [ + parse-command-line + run-user-init + "run" get run + output-stream get [ stream-flush ] when* + ] [ print-error 1 exit ] recover + ] set-boot-quot + + millis r> - dup bootstrap-time set-global + print-report + + "output-image" get save-image-and-exit + ] if +] [ + :c + dup print-error flush + "listener" vocab + [ restarts. vocab-main execute ] + [ die ] if* + 1 exit +] recover diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor new file mode 100644 index 0000000000..6c30489bb4 --- /dev/null +++ b/basis/bootstrap/threads/threads.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: bootstrap.threads + +USE: io.thread +USE: threads +USE: debugger.threads diff --git a/core/cpu/arm/architecture/authors.txt b/basis/bootstrap/tools/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/cpu/arm/architecture/authors.txt rename to basis/bootstrap/tools/authors.txt diff --git a/extra/bootstrap/tools/summary.txt b/basis/bootstrap/tools/summary.txt similarity index 100% rename from extra/bootstrap/tools/summary.txt rename to basis/bootstrap/tools/summary.txt diff --git a/extra/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor similarity index 90% rename from extra/bootstrap/tools/tools.factor rename to basis/bootstrap/tools/tools.factor index 670bca4903..c6ec7f0b99 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/basis/bootstrap/tools/tools.factor @@ -1,6 +1,8 @@ USING: vocabs.loader sequences ; +IN: bootstrap.tools { + "inspector" "bootstrap.image" "tools.annotations" "tools.crossref" diff --git a/core/cpu/arm/assembler/authors.txt b/basis/bootstrap/ui/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/cpu/arm/assembler/authors.txt rename to basis/bootstrap/ui/authors.txt diff --git a/extra/bootstrap/ui/summary.txt b/basis/bootstrap/ui/summary.txt similarity index 100% rename from extra/bootstrap/ui/summary.txt rename to basis/bootstrap/ui/summary.txt diff --git a/core/cpu/arm/authors.txt b/basis/bootstrap/ui/tools/authors.txt similarity index 100% rename from core/cpu/arm/authors.txt rename to basis/bootstrap/ui/tools/authors.txt diff --git a/extra/bootstrap/ui/tools/summary.txt b/basis/bootstrap/ui/tools/summary.txt similarity index 100% rename from extra/bootstrap/ui/tools/summary.txt rename to basis/bootstrap/ui/tools/summary.txt diff --git a/extra/bootstrap/ui/tools/tools.factor b/basis/bootstrap/ui/tools/tools.factor similarity index 100% rename from extra/bootstrap/ui/tools/tools.factor rename to basis/bootstrap/ui/tools/tools.factor diff --git a/extra/bootstrap/ui/ui.factor b/basis/bootstrap/ui/ui.factor similarity index 95% rename from extra/bootstrap/ui/ui.factor rename to basis/bootstrap/ui/ui.factor index 5aa7683efc..0cdf3137f6 100644 --- a/extra/bootstrap/ui/ui.factor +++ b/basis/bootstrap/ui/ui.factor @@ -1,5 +1,6 @@ USING: alien namespaces system combinators kernel sequences vocabs vocabs.loader ; +IN: bootstrap.ui "bootstrap.compiler" vocab [ "ui-backend" get [ diff --git a/basis/bootstrap/unicode/unicode.factor b/basis/bootstrap/unicode/unicode.factor new file mode 100755 index 0000000000..1046d41bdc --- /dev/null +++ b/basis/bootstrap/unicode/unicode.factor @@ -0,0 +1,5 @@ +USING: strings.parser kernel namespaces unicode.data ; +IN: bootstrap.unicode + +[ name>char [ "Invalid character" throw ] unless* ] +name>char-hook set-global diff --git a/core/boxes/boxes-docs.factor b/basis/boxes/boxes-docs.factor similarity index 100% rename from core/boxes/boxes-docs.factor rename to basis/boxes/boxes-docs.factor diff --git a/core/boxes/boxes-tests.factor b/basis/boxes/boxes-tests.factor similarity index 100% rename from core/boxes/boxes-tests.factor rename to basis/boxes/boxes-tests.factor diff --git a/core/boxes/boxes.factor b/basis/boxes/boxes.factor similarity index 100% rename from core/boxes/boxes.factor rename to basis/boxes/boxes.factor diff --git a/extra/calendar/authors.txt b/basis/calendar/authors.txt similarity index 100% rename from extra/calendar/authors.txt rename to basis/calendar/authors.txt diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor new file mode 100644 index 0000000000..62ff4ad517 --- /dev/null +++ b/basis/calendar/calendar-docs.factor @@ -0,0 +1,606 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays kernel math strings help.markup help.syntax +math.order ; +IN: calendar + +HELP: duration +{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two durations with the " { $link <=> } " word." } ; + +HELP: timestamp +{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two duarionts with the " { $link <=> } " word." } ; + +{ timestamp duration } related-words + +HELP: gmt-offset-duration +{ $values { "duration" duration } } +{ $description "Returns a " { $link duration } " object with the GMT offset returned by " { $link gmt-offset } "." } ; + +HELP: +{ $values { "year" integer } { "month" integer } { "day" integer } { "timestamp" timestamp } } +{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." } +{ $examples + { $example "USING: calendar prettyprint ;" + "2010 12 25 ." + "T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}" + } +} ; + +HELP: month-names +{ $values { "array" array } } +{ $description "Returns an array with the English names of all the months." } +{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ; + +HELP: month-name +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ; + +HELP: month-abbreviations +{ $values { "array" array } } +{ $description "Returns an array with the English abbreviated names of all the months." } +{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ; + +HELP: month-abbreviation +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ; + + +HELP: day-names +{ $values { "array" array } } +{ $description "Returns an array with the English names of the days of the week." } ; + +HELP: day-name +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the day name and returns it as a string." } ; + +HELP: day-abbreviations2 +{ $values { "array" array } } +{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ; + +HELP: day-abbreviation2 +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ; + +HELP: day-abbreviations3 +{ $values { "array" array } } +{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ; + +HELP: day-abbreviation3 +{ $values { "n" integer } { "string" string } } +{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is three characters long." } ; + +{ + day-name day-names + day-abbreviation2 day-abbreviations2 + day-abbreviation3 day-abbreviations3 +} related-words + +HELP: average-month +{ $values { "ratio" ratio } } +{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ; + +HELP: months-per-year +{ $values { "integer" integer } } +{ $description "Returns the number of months in a year." } ; + +HELP: days-per-year +{ $values { "ratio" ratio } } +{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ; + +HELP: hours-per-year +{ $values { "ratio" ratio } } +{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ; + +HELP: minutes-per-year +{ $values { "ratio" ratio } } +{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ; + +HELP: seconds-per-year +{ $values { "integer" integer } } +{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ; + +HELP: julian-day-number +{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } } +{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." } +{ $warning "Not valid before year -4800 BCE." } ; + +HELP: julian-day-number>date +{ $values { "n" integer } { "year" integer } { "month" integer } { "day" integer } } +{ $description "Converts from a Julian day number back to a year, month, and day." } ; +{ julian-day-number julian-day-number>date } related-words + +HELP: >date< +{ $values { "timestamp" timestamp } { "year" integer } { "month" integer } { "day" integer } } +{ $description "Explodes a " { $snippet "timestamp" } " into its year, month, and day components." } +{ $examples { $example "USING: arrays calendar prettyprint ;" + "2010 8 24 >date< 3array ." + "{ 2010 8 24 }" + } +} ; + +HELP: >time< +{ $values { "timestamp" timestamp } { "hour" integer } { "minute" integer } { "second" integer } } +{ $description "Explodes a " { $snippet "timestamp" } " into its hour, minute, and second components." } +{ $examples { $example "USING: arrays calendar prettyprint ;" + "now noon >time< 3array ." + "{ 12 0 0 }" + } +} ; + +{ >date< >time< } related-words + +HELP: instant +{ $values { "duration" duration } } +{ $description "Pushes a " { $snippet "duration" } " of zero seconds." } ; + +HELP: years +{ $values { "x" number } { "duration" duration } } +{ $description "Creates a duration object with the specified number of years." } ; + +HELP: months +{ $values { "x" number } { "duration" duration } } +{ $description "Creates a duration object with the specified number of months." } ; + +HELP: days +{ $values { "x" number } { "duration" duration } } +{ $description "Creates a duration object with the specified number of days." } ; + +HELP: weeks +{ $values { "x" number } { "duration" duration } } +{ $description "Creates a duration object with the specified number of weeks." } ; + +HELP: hours +{ $values { "x" number } { "duration" duration } } +{ $description "Creates a duration object with the specified number of hours." } ; + +HELP: minutes +{ $values { "x" number } { "duration" duration } } +{ $description "Creates a duration object with the specified number of minutes." } ; + +HELP: seconds +{ $values { "x" number } { "duration" duration } } +{ $description "Creates a duration object with the specified number of seconds." } ; + +HELP: milliseconds +{ $values { "x" number } { "duration" duration } } +{ $description "Creates a duration object with the specified number of milliseconds." } ; + +{ years months days hours minutes seconds milliseconds } related-words + +HELP: leap-year? +{ $values { "obj" object } { "?" "a boolean" } } +{ $description "Returns " { $link t } " if the object represents a leap year." } +{ $examples + { $example "USING: calendar prettyprint ;" + "2008 leap-year? ." + "t" + } + { $example "USING: calendar prettyprint ;" + "2010 1 1 leap-year? ." + "f" + } +} ; + +HELP: time+ +{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } } +{ $description "Adds two durations to produce a duration or adds a timestamp and a duration to produce a timestamp. The calculation takes timezones into account." } +{ $examples + { $example "USING: calendar math.order prettyprint ;" + "10 months 2 months time+ 1 years <=> ." + "+eq+" + } + { $example "USING: accessors calendar math.order prettyprint ;" + "2010 1 1 3 days time+ day>> ." + "4" + } +} ; + +HELP: duration>years +{ $values { "duration" duration } { "x" number } } +{ $description "Calculates the length of a duration in years." } +{ $examples + { $example "USING: calendar prettyprint ;" + "6 months duration>years ." + "1/2" + } +} ; + +HELP: duration>months +{ $values { "duration" duration } { "x" number } } +{ $description "Calculates the length of a duration in months." } +{ $examples + { $example "USING: calendar prettyprint ;" + "30 days duration>months ." + "16000/16233" + } +} ; + +HELP: duration>days +{ $values { "duration" duration } { "x" number } } +{ $description "Calculates the length of a duration in days." } +{ $examples + { $example "USING: calendar prettyprint ;" + "6 hours duration>days ." + "1/4" + } +} ; + +HELP: duration>hours +{ $values { "duration" duration } { "x" number } } +{ $description "Calculates the length of a duration in hours." } +{ $examples + { $example "USING: calendar prettyprint ;" + "3/4 days duration>hours ." + "18" + } +} ; +HELP: duration>minutes +{ $values { "duration" duration } { "x" number } } +{ $description "Calculates the length of a duration in minutes." } +{ $examples + { $example "USING: calendar prettyprint ;" + "6 hours duration>minutes ." + "360" + } +} ; +HELP: duration>seconds +{ $values { "duration" duration } { "x" number } } +{ $description "Calculates the length of a duration in seconds." } +{ $examples + { $example "USING: calendar prettyprint ;" + "6 minutes duration>seconds ." + "360" + } +} ; + +HELP: duration>milliseconds +{ $values { "duration" duration } { "x" number } } +{ $description "Calculates the length of a duration in milliseconds." } +{ $examples + { $example "USING: calendar prettyprint ;" + "6 seconds duration>milliseconds ." + "6000" + } +} ; + +{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds } related-words + + +HELP: time- +{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } } +{ $description "Subtracts two durations to produce a duration or subtracts a duration from a timestamp to produce a timestamp. The calculation takes timezones into account." } +{ $examples + { $example "USING: calendar math.order prettyprint ;" + "10 months 2 months time- 8 months <=> ." + "+eq+" + } + { $example "USING: accessors calendar math.order prettyprint ;" + "2010 1 1 3 days time- day>> ." + "29" + } +} ; + +HELP: convert-timezone +{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } } +{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." } +{ $examples + { $example "USING: accessors calendar prettyprint ;" + "gmt noon instant -5 >>hour convert-timezone gmt-offset>> hour>> ." + "-5" + } +} ; + +HELP: >local-time +{ $values { "timestamp" timestamp } { "timestamp" timestamp } } +{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." } +{ $examples + { $example "USING: accessors calendar kernel prettyprint ;" + "now gmt >local-time [ gmt-offset>> ] bi@ = ." + "t" + } +} ; + +HELP: >gmt +{ $values { "timestamp" timestamp } { "timestamp" timestamp } } +{ $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." } +{ $examples + { $example "USING: accessors calendar kernel prettyprint ;" + "now >gmt gmt-offset>> hour>> ." + "0" + } +} ; + +HELP: time* +{ $values { "obj1" object } { "obj2" object } { "obj3" object } } +{ $description "Multiplies each time slot of a timestamp or duration by a number and make a new duration from the result. Used in the implementation of " { $link before } "." } ; +{ time+ time- time* } related-words + +HELP: before +{ $values { "duration" duration } { "-duration" duration } } +{ $description "Negates a duration." } +{ $examples + { $example "USING: accessors calendar prettyprint ;" + "3 hours before now noon time+ hour>> ." + "9" + } +} ; + +HELP: +{ $values { "timestamp" timestamp } } +{ $description "Outputs a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ; + +HELP: valid-timestamp? +{ $values { "timestamp" timestamp } { "?" "a boolean" } } +{ $description "Tests if a timestamp is valid or not." } ; + +HELP: unix-1970 +{ $values { "timestamp" timestamp } } +{ $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ; + +HELP: millis>timestamp +{ $values { "x" number } { "timestamp" timestamp } } +{ $description "Converts a number of milliseconds into a timestamp value in GMT time." } +{ $examples + { $example "USING: accessors calendar prettyprint ;" + "1000 millis>timestamp year>> ." + "1970" + } +} ; + +HELP: gmt +{ $values { "timestamp" timestamp } } +{ $description "Outputs the time right now, but in the GMT timezone." } ; + +{ gmt now } related-words + +HELP: now +{ $values { "timestamp" timestamp } } +{ $description "Outputs the time right now in your computer's timezone." } +{ $examples + { $unchecked-example "USING: calendar prettyprint ;" + "now ." + "T{ timestamp f 2008 9 1 16 38 24+801/1000 T{ duration f 0 0 0 -5 0 0 } }" + } +} ; + +HELP: hence +{ $values { "duration" duration } { "timestamp" timestamp } } +{ $description "Computes a time in the future that is the " { $snippet "duration" } " added to the result of " { $link now } "." } +{ $examples + { $unchecked-example + "USING: calendar prettyprint ;" + "10 hours hence ." + "T{ timestamp f 2008 9 2 2 47 45+943/1000 T{ duration f 0 0 0 -5 0 0 } }" + } +} ; + +HELP: ago +{ $values { "duration" duration } { "timestamp" timestamp } } +{ $description "Computes a time in the past that is the " { $snippet "duration" } " subtracted from the result of " { $link now } "." } +{ $examples + { $unchecked-example + "USING: calendar prettyprint ;" + "3 weeks ago ." + "T{ timestamp f 2008 8 11 16 49 52+99/500 T{ duration f 0 0 0 -5 0 0 } }" + } +} ; + +HELP: zeller-congruence +{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } } +{ $description "An implementation of an algorithm that computes the day of the week given a date. Days are indexed starting from Sunday, which is index 0." } +{ $notes "User code should use the " { $link day-of-week } " word, which takes a " { $snippet "timestamp" } " instead of integers." } ; + +HELP: days-in-year +{ $values { "obj" "a timestamp or an integer" } { "n" integer } } +{ $description "Calculates the number of days in a given year." } +{ $examples + { $example "USING: calendar prettyprint ;" + "2004 days-in-year ." + "366" + } +} ; + +HELP: days-in-month +{ $values { "timestamp" timestamp } { "n" integer } } +{ $description "Calculates the number of days in a given month." } +{ $examples + { $example "USING: calendar prettyprint ;" + "2008 8 24 days-in-month ." + "31" + } +} ; + +HELP: day-of-week +{ $values { "timestamp" timestamp } { "n" integer } } +{ $description "Calculates the index of the day of the week. Sunday will result in an index of 0." } +{ $examples + { $example "USING: calendar prettyprint ;" + "now sunday day-of-week ." + "0" + } +} ; + +HELP: day-of-year +{ $values { "timestamp" timestamp } { "n" integer } } +{ $description "Calculates the day of the year, resulting in a number from 1 to 366 (leap years)." } +{ $examples + { $example "USING: calendar prettyprint ;" + "2008 1 4 day-of-year ." + "4" + } +} ; + +HELP: sunday +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Returns the Sunday from the current week, which starts on a Sunday." } ; + +HELP: monday +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Returns the Monday from the current week, which starts on a Sunday." } ; + +HELP: tuesday +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Returns the Tuesday from the current week, which starts on a Sunday." } ; + +HELP: wednesday +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Returns the Wednesday from the current week, which starts on a Sunday." } ; + +HELP: thursday +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Returns the Thursday from the current week, which starts on a Sunday." } ; + +HELP: friday +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Returns the Friday from the current week, which starts on a Sunday." } ; + +HELP: saturday +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Returns the Saturday from the current week, which starts on a Sunday." } ; + +{ sunday monday tuesday wednesday thursday friday saturday } related-words + +HELP: midnight +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Returns a timestamp that represents today at midnight, or the beginning of the day." } ; + +HELP: noon +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Returns a timestamp that represents today at noon, or the middle of the day." } ; + +HELP: beginning-of-month +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Outputs a timestamp with the day set to one." } ; + +HELP: beginning-of-week +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Outputs a timestamp where the day of the week is Sunday." } ; + +HELP: beginning-of-year +{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } } +{ $description "Outputs a timestamp with the month and day set to one, or January 1 of the input timestamp." } ; + +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" } "." } ; + +ARTICLE: "calendar" "Calendar" +"The two data types used throughout the calendar library:" +{ $subsection timestamp } +{ $subsection duration } +"Durations represent spans of time:" +{ $subsection "using-durations" } +"Arithmetic on timestamps and durations:" +{ $subsection "timestamp-arithmetic" } +"Getting the current timestamp:" +{ $subsection now } +{ $subsection gmt } +"Converting between timestamps:" +{ $subsection >local-time } +{ $subsection >gmt } +"Converting between timezones:" +{ $subsection convert-timezone } +"Timestamps relative to each other:" +{ $subsection "relative-timestamps" } +"Operations on units of time:" +{ $subsection "years" } +{ $subsection "months" } +{ $subsection "days" } +"Meta-data about the calendar:" +{ $subsection "calendar-facts" } +; + +ARTICLE: "timestamp-arithmetic" "Timestamp arithmetic" +"Adding timestamps and durations, or durations and durations:" +{ $subsection time+ } +"Subtracting:" +{ $subsection time- } +"Element-wise multiplication:" +{ $subsection time* } ; + +ARTICLE: "using-durations" "Using durations" +"Creating a duration object:" +{ $subsection years } +{ $subsection months } +{ $subsection weeks } +{ $subsection days } +{ $subsection hours } +{ $subsection minutes } +{ $subsection seconds } +{ $subsection milliseconds } +{ $subsection instant } +"Converting a duration to a number:" +{ $subsection duration>years } +{ $subsection duration>months } +{ $subsection duration>days } +{ $subsection duration>hours } +{ $subsection duration>minutes } +{ $subsection duration>seconds } +{ $subsection duration>milliseconds } ; + +ARTICLE: "relative-timestamps" "Relative timestamps" +"In the future:" +{ $subsection hence } +"In the past:" +{ $subsection ago } +"Invert a duration:" +{ $subsection before } +"Days of the week relative to " { $link now } ":" +{ $subsection sunday } +{ $subsection monday } +{ $subsection tuesday } +{ $subsection wednesday } +{ $subsection thursday } +{ $subsection friday } +{ $subsection saturday } +"New timestamps relative to calendar events:" +{ $subsection beginning-of-year } +{ $subsection beginning-of-month } +{ $subsection beginning-of-week } +{ $subsection midnight } +{ $subsection noon } +; + +ARTICLE: "days" "Day operations" +"Naming days:" +{ $subsection day-abbreviation2 } +{ $subsection day-abbreviations2 } +{ $subsection day-abbreviation3 } +{ $subsection day-abbreviations3 } +{ $subsection day-name } +{ $subsection day-names } +"Calculating a Julian day number:" +{ $subsection julian-day-number } +"Calculate a timestamp:" +{ $subsection julian-day-number>date } +; + +ARTICLE: "calendar-facts" "Calendar facts" +"Calendar facts:" +{ $subsection average-month } +{ $subsection months-per-year } +{ $subsection days-per-year } +{ $subsection hours-per-year } +{ $subsection minutes-per-year } +{ $subsection seconds-per-year } +{ $subsection days-in-month } +{ $subsection day-of-year } +{ $subsection day-of-week } +; + +ARTICLE: "years" "Year operations" +"Leap year predicate:" +{ $subsection leap-year? } +"Find the number of days in a year:" +{ $subsection days-in-year } +; + +ARTICLE: "months" "Month operations" +"Naming months:" +{ $subsection month-name } +{ $subsection month-names } +{ $subsection month-abbreviation } +{ $subsection month-abbreviations } +; + +ABOUT: "calendar" diff --git a/extra/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor similarity index 98% rename from extra/calendar/calendar-tests.factor rename to basis/calendar/calendar-tests.factor index 7d9716ae1a..995bd23c09 100755 --- a/extra/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -33,8 +33,8 @@ IN: calendar.tests [ t ] [ 2006 10 10 0 0 0 instant 10 minutes time+ 2006 10 10 0 10 0 instant = ] unit-test -[ t ] [ 2006 10 10 0 0 0 instant 10.5 minutes time+ - 2006 10 10 0 10 30 instant = ] unit-test +[ +eq+ ] [ 2006 10 10 0 0 0 instant 10.5 minutes time+ + 2006 10 10 0 10 30 instant <=> ] unit-test [ t ] [ 2006 10 10 0 0 0 instant 3/4 minutes time+ 2006 10 10 0 0 45 instant = ] unit-test [ t ] [ 2006 10 10 0 0 0 instant -3/4 minutes time+ diff --git a/extra/calendar/calendar.factor b/basis/calendar/calendar.factor similarity index 62% rename from extra/calendar/calendar.factor rename to basis/calendar/calendar.factor index 0e21876fe9..c2c386a790 100755 --- a/extra/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -1,63 +1,94 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. - USING: arrays kernel math math.functions namespaces sequences -strings system vocabs.loader calendar.backend threads -accessors combinators locals classes.tuple math.order ; +strings system vocabs.loader threads accessors combinators +locals classes.tuple math.order summary +combinators.short-circuit ; IN: calendar -TUPLE: timestamp year month day hour minute second gmt-offset ; +HOOK: gmt-offset os ( -- hours minutes seconds ) -C: timestamp - -TUPLE: duration year month day hour minute second ; +TUPLE: duration + { year real } + { month real } + { day real } + { hour real } + { minute real } + { second real } ; C: duration +TUPLE: timestamp + { year integer } + { month integer } + { day integer } + { hour integer } + { minute integer } + { second real } + { gmt-offset duration } ; + +C: timestamp + : gmt-offset-duration ( -- duration ) 0 0 0 gmt-offset ; : ( year month day -- timestamp ) 0 0 0 gmt-offset-duration ; -: month-names +ERROR: not-a-month n ; +M: not-a-month summary + drop "Months are indexed starting at 1" ; + + + +: month-names ( -- array ) { - "Not a month" "January" "February" "March" "April" "May" "June" + "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December" } ; -: month-abbreviations +: month-name ( n -- string ) + check-month 1- month-names nth ; + +: month-abbreviations ( -- array ) { - "Not a month" - "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" + "Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" } ; -: day-names +: month-abbreviation ( n -- string ) + check-month 1- month-abbreviations nth ; + +: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline + +: day-names ( -- array ) { "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" } ; -: day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ; -: day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ; +: day-name ( n -- string ) day-names nth ; -: average-month 30+5/12 ; inline -: months-per-year 12 ; inline -: days-per-year 3652425/10000 ; inline -: hours-per-year 876582/100 ; inline -: minutes-per-year 5259492/10 ; inline -: seconds-per-year 31556952 ; inline +: day-abbreviations2 ( -- array ) + { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ; - +: day-abbreviation3 ( n -- string ) + day-abbreviations3 nth ; + +: average-month ( -- ratio ) 30+5/12 ; inline +: months-per-year ( -- integer ) 12 ; inline +: days-per-year ( -- ratio ) 3652425/10000 ; inline +: hours-per-year ( -- ratio ) 876582/100 ; inline +: minutes-per-year ( -- ratio ) 5259492/10 ; inline +: seconds-per-year ( -- integer ) 31556952 ; inline :: julian-day-number ( year month day -- n ) #! Returns a composite date number @@ -89,15 +120,15 @@ PRIVATE> : >time< ( timestamp -- hour minute second ) [ hour>> ] [ minute>> ] [ second>> ] tri ; -: instant ( -- dt ) 0 0 0 0 0 0 ; -: years ( n -- dt ) instant swap >>year ; -: months ( n -- dt ) instant swap >>month ; -: days ( n -- dt ) instant swap >>day ; -: weeks ( n -- dt ) 7 * days ; -: hours ( n -- dt ) instant swap >>hour ; -: minutes ( n -- dt ) instant swap >>minute ; -: seconds ( n -- dt ) instant swap >>second ; -: milliseconds ( n -- dt ) 1000 / seconds ; +: instant ( -- duration ) 0 0 0 0 0 0 ; +: years ( x -- duration ) instant clone swap >>year ; +: months ( x -- duration ) instant clone swap >>month ; +: days ( x -- duration ) instant clone swap >>day ; +: weeks ( x -- duration ) 7 * days ; +: hours ( x -- duration ) instant clone swap >>hour ; +: minutes ( x -- duration ) instant clone swap >>minute ; +: seconds ( x -- duration ) instant clone swap >>second ; +: milliseconds ( x -- duration ) 1000 / seconds ; GENERIC: leap-year? ( obj -- ? ) @@ -124,10 +155,12 @@ GENERIC: +second ( timestamp x -- timestamp ) [ floor >integer ] keep over - ; : adjust-leap-year ( timestamp -- timestamp ) - dup day>> 29 = over month>> 2 = pick leap-year? not and and + dup + { [ day>> 29 = ] [ month>> 2 = ] [ leap-year? not ] } 1&& [ 3 >>month 1 >>day ] when ; -: unless-zero >r dup zero? [ drop ] r> if ; inline +: unless-zero ( n quot -- ) + [ dup zero? [ drop ] ] dip if ; inline M: integer +year ( timestamp n -- timestamp ) [ [ + ] curry change-year adjust-leap-year ] unless-zero ; @@ -189,7 +222,7 @@ M: number +second ( timestamp n -- timestamp ) PRIVATE> -GENERIC# time+ 1 ( time dt -- time ) +GENERIC# time+ 1 ( time1 time2 -- time3 ) M: timestamp time+ >r clone r> (time+) drop ; @@ -207,8 +240,8 @@ M: duration time+ 2drop ] if ; -: dt>years ( dt -- x ) - #! Uses average month/year length since dt loses calendar +: duration>years ( duration -- x ) + #! Uses average month/year length since duration loses calendar #! data 0 swap { @@ -220,16 +253,16 @@ M: duration time+ [ second>> seconds-per-year / + ] } cleave ; -M: duration <=> [ dt>years ] compare ; +M: duration <=> [ duration>years ] compare ; -: dt>months ( dt -- x ) dt>years months-per-year * ; -: dt>days ( dt -- x ) dt>years days-per-year * ; -: dt>hours ( dt -- x ) dt>years hours-per-year * ; -: dt>minutes ( dt -- x ) dt>years minutes-per-year * ; -: dt>seconds ( dt -- x ) dt>years seconds-per-year * ; -: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ; +: duration>months ( duration -- x ) duration>years months-per-year * ; +: duration>days ( duration -- x ) duration>years days-per-year * ; +: duration>hours ( duration -- x ) duration>years hours-per-year * ; +: duration>minutes ( duration -- x ) duration>years minutes-per-year * ; +: duration>seconds ( duration -- x ) duration>years seconds-per-year * ; +: duration>milliseconds ( duration -- x ) duration>seconds 1000 * ; -GENERIC: time- ( time1 time2 -- time ) +GENERIC: time- ( time1 time2 -- time3 ) : convert-timezone ( timestamp duration -- timestamp ) over gmt-offset>> over = [ drop ] [ @@ -267,22 +300,23 @@ M: timestamp time- } 2cleave ] if ; -: before ( dt -- -dt ) +: before ( duration -- -duration ) -1 time* ; M: duration time- before time+ ; -: 0 0 0 0 0 0 instant ; +: ( -- timestamp ) + 0 0 0 0 0 0 instant ; : valid-timestamp? ( timestamp -- ? ) clone instant >>gmt-offset dup time- time+ = ; : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 instant ; foldable + 1970 1 1 0 0 0 instant ; -: millis>timestamp ( n -- timestamp ) +: millis>timestamp ( x -- timestamp ) >r unix-1970 r> milliseconds time+ ; : timestamp>millis ( timestamp -- n ) @@ -293,11 +327,8 @@ M: duration time- unix-1970 millis milliseconds time+ ; : now ( -- timestamp ) gmt >local-time ; - -: from-now ( dt -- timestamp ) now swap time+ ; -: ago ( dt -- timestamp ) now swap time- ; - -: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline +: hence ( duration -- timestamp ) now swap time+ ; +: ago ( duration -- timestamp ) now swap time- ; : zeller-congruence ( year month day -- n ) #! Zeller Congruence @@ -313,77 +344,63 @@ GENERIC: days-in-year ( obj -- n ) M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; -GENERIC: days-in-month ( obj -- n ) +: (days-in-month) ( year month -- n ) + dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ; -M: array days-in-month ( obj -- n ) - first2 dup 2 = [ - drop leap-year? 29 28 ? - ] [ - nip day-counts nth - ] if ; +: days-in-month ( timestamp -- n ) + >date< drop (days-in-month) ; -M: timestamp days-in-month ( timestamp -- n ) - >date< drop 2array days-in-month ; - -GENERIC: day-of-week ( obj -- n ) - -M: timestamp day-of-week ( timestamp -- n ) +: day-of-week ( timestamp -- n ) >date< zeller-congruence ; -M: array day-of-week ( array -- n ) - first3 zeller-congruence ; - -GENERIC: day-of-year ( obj -- n ) - -M: array day-of-year ( array -- n ) - first3 - 3dup day-counts rot head-slice sum + - swap leap-year? [ - -roll - pick 3 1 >r r> +:: (day-of-year) ( year month day -- n ) + day-counts month head-slice sum day + + year leap-year? [ + year month day + year 3 1 after=? [ 1+ ] when - ] [ - >r 3drop r> - ] if ; + ] when ; -M: timestamp day-of-year ( timestamp -- n ) - >date< 3array day-of-year ; +: day-of-year ( timestamp -- n ) + >date< (day-of-year) ; + -: sunday ( timestamp -- timestamp ) 0 day-this-week ; -: monday ( timestamp -- timestamp ) 1 day-this-week ; -: tuesday ( timestamp -- timestamp ) 2 day-this-week ; -: wednesday ( timestamp -- timestamp ) 3 day-this-week ; -: thursday ( timestamp -- timestamp ) 4 day-this-week ; -: friday ( timestamp -- timestamp ) 5 day-this-week ; -: saturday ( timestamp -- timestamp ) 6 day-this-week ; +: sunday ( timestamp -- new-timestamp ) 0 day-this-week ; +: monday ( timestamp -- new-timestamp ) 1 day-this-week ; +: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ; +: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ; +: thursday ( timestamp -- new-timestamp ) 4 day-this-week ; +: friday ( timestamp -- new-timestamp ) 5 day-this-week ; +: saturday ( timestamp -- new-timestamp ) 6 day-this-week ; -: beginning-of-day ( timestamp -- new-timestamp ) - clone - 0 >>hour - 0 >>minute - 0 >>second ; inline +: midnight ( timestamp -- new-timestamp ) + clone 0 >>hour 0 >>minute 0 >>second ; inline + +: noon ( timestamp -- new-timestamp ) + midnight 12 >>hour ; inline : beginning-of-month ( timestamp -- new-timestamp ) - beginning-of-day 1 >>day ; + midnight 1 >>day ; : beginning-of-week ( timestamp -- new-timestamp ) - beginning-of-day sunday ; + midnight sunday ; : beginning-of-year ( timestamp -- new-timestamp ) beginning-of-month 1 >>month ; : time-since-midnight ( timestamp -- duration ) - dup beginning-of-day time- ; + dup midnight time- ; M: timestamp sleep-until timestamp>millis sleep-until ; -M: duration sleep from-now sleep-until ; +M: duration sleep hence sleep-until ; { { [ os unix? ] [ "calendar.unix" ] } diff --git a/extra/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor similarity index 87% rename from extra/calendar/format/format-tests.factor rename to basis/calendar/format/format-tests.factor index 3efe33e265..c433a118c2 100755 --- a/extra/calendar/format/format-tests.factor +++ b/basis/calendar/format/format-tests.factor @@ -3,23 +3,23 @@ io.streams.string accessors io math.order ; IN: calendar.format.tests [ 0 ] [ - "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ 1 ] [ - "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ -1 ] [ - "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ -1-1/2 ] [ - "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ 1+1/2 ] [ - "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours + "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader duration>hours ] unit-test [ ] [ now timestamp>rfc3339 drop ] unit-test @@ -58,7 +58,7 @@ IN: calendar.format.tests 26 0 37 - 42.12345 + 42+2469/20000 T{ duration f 0 0 0 -5 0 0 } } ] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test diff --git a/extra/calendar/format/format.factor b/basis/calendar/format/format.factor similarity index 81% rename from extra/calendar/format/format.factor rename to basis/calendar/format/format.factor index ff1811e9d5..bfe438fae1 100755 --- a/extra/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -4,46 +4,46 @@ combinators accessors debugger calendar calendar.format.macros ; IN: calendar.format -: pad-00 number>string 2 CHAR: 0 pad-left ; +: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ; -: pad-0000 number>string 4 CHAR: 0 pad-left ; +: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ; -: pad-00000 number>string 5 CHAR: 0 pad-left ; +: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ; -: write-00 pad-00 write ; +: write-00 ( n -- ) pad-00 write ; -: write-0000 pad-0000 write ; +: write-0000 ( n -- ) pad-0000 write ; -: write-00000 pad-00000 write ; +: write-00000 ( n -- ) pad-00000 write ; -: hh hour>> write-00 ; +: hh ( time -- ) hour>> write-00 ; -: mm minute>> write-00 ; +: mm ( time -- ) minute>> write-00 ; -: ss second>> >integer write-00 ; +: ss ( time -- ) second>> >integer write-00 ; -: D day>> number>string write ; +: D ( time -- ) day>> number>string write ; -: DD day>> write-00 ; +: DD ( time -- ) day>> write-00 ; -: DAY day-of-week day-abbreviations3 nth write ; +: DAY ( time -- ) day-of-week day-abbreviation3 write ; -: MM month>> write-00 ; +: MM ( time -- ) month>> write-00 ; -: MONTH month>> month-abbreviations nth write ; +: MONTH ( time -- ) month>> month-abbreviation write ; -: YYYY year>> write-0000 ; +: YYYY ( time -- ) year>> write-0000 ; -: YYYYY year>> write-00000 ; +: YYYYY ( time -- ) year>> write-00000 ; : expect ( str -- ) read1 swap member? [ "Parse error" throw ] unless ; -: read-00 2 read string>number ; +: read-00 ( -- n ) 2 read string>number ; -: read-000 3 read string>number ; +: read-000 ( -- n ) 3 read string>number ; -: read-0000 4 read string>number ; +: read-0000 ( -- n ) 4 read string>number ; GENERIC: day. ( obj -- ) @@ -57,9 +57,9 @@ GENERIC: month. ( obj -- ) M: array month. ( pair -- ) first2 - [ month-names nth write bl number>string print ] 2keep - [ 1 zeller-congruence ] 2keep - 2array days-in-month day-abbreviations2 " " join print + [ month-name write bl number>string print ] + [ 1 zeller-congruence ] + [ (days-in-month) day-abbreviations2 " " join print ] 2tri over " " concat write [ [ 1+ day. ] keep @@ -191,7 +191,7 @@ ERROR: invalid-timestamp-format ; "," read-token day-abbreviations3 member? check-timestamp drop read1 CHAR: \s assert= read-sp checked-number >>day - read-sp month-abbreviations index check-timestamp >>month + read-sp month-abbreviations index 1+ check-timestamp >>month read-sp checked-number >>year ":" read-token checked-number >>hour ":" read-token checked-number >>minute @@ -206,7 +206,7 @@ ERROR: invalid-timestamp-format ; "," read-token day-abbreviations3 member? check-timestamp drop read1 CHAR: \s assert= "-" read-token checked-number >>day - "-" read-token month-abbreviations index check-timestamp >>month + "-" read-token month-abbreviations index 1+ check-timestamp >>month read-sp checked-number >>year ":" read-token checked-number >>hour ":" read-token checked-number >>minute @@ -219,7 +219,7 @@ ERROR: invalid-timestamp-format ; : (cookie-string>timestamp-2) ( -- timestamp ) timestamp new read-sp day-abbreviations3 member? check-timestamp drop - read-sp month-abbreviations index check-timestamp >>month + read-sp month-abbreviations index 1+ check-timestamp >>month read-sp checked-number >>day ":" read-token checked-number >>hour ":" read-token checked-number >>minute @@ -244,13 +244,13 @@ ERROR: invalid-timestamp-format ; [ (ymdhms>timestamp) ] with-string-reader ; : (hms>timestamp) ( -- timestamp ) - f f f read-hms instant ; + 0 0 0 read-hms instant ; : hms>timestamp ( str -- timestamp ) [ (hms>timestamp) ] with-string-reader ; : (ymd>timestamp) ( -- timestamp ) - read-ymd f f f instant ; + read-ymd 0 0 0 instant ; : ymd>timestamp ( str -- timestamp ) [ (ymd>timestamp) ] with-string-reader ; @@ -261,7 +261,7 @@ ERROR: invalid-timestamp-format ; : timestamp>ymd ( timestamp -- str ) [ (timestamp>ymd) ] with-string-writer ; -: (timestamp>hms) +: (timestamp>hms) ( timestamp -- ) { hh ":" mm ":" ss } formatted ; : timestamp>hms ( timestamp -- str ) diff --git a/extra/calendar/format/macros/macros-tests.factor b/basis/calendar/format/macros/macros-tests.factor similarity index 80% rename from extra/calendar/format/macros/macros-tests.factor rename to basis/calendar/format/macros/macros-tests.factor index 91a8f80894..544332770f 100644 --- a/extra/calendar/format/macros/macros-tests.factor +++ b/basis/calendar/format/macros/macros-tests.factor @@ -7,7 +7,8 @@ IN: calendar.format.macros [ { [ 1 throw ] } attempt-all-quots ] [ 1 = ] must-fail-with -: compiled-test-1 { [ 1 throw ] [ 2 ] } attempt-all-quots ; +: compiled-test-1 ( -- n ) + { [ 1 throw ] [ 2 ] } attempt-all-quots ; \ compiled-test-1 must-infer diff --git a/extra/calendar/format/macros/macros.factor b/basis/calendar/format/macros/macros.factor similarity index 100% rename from extra/calendar/format/macros/macros.factor rename to basis/calendar/format/macros/macros.factor diff --git a/extra/calendar/format/summary.txt b/basis/calendar/format/summary.txt similarity index 100% rename from extra/calendar/format/summary.txt rename to basis/calendar/format/summary.txt diff --git a/extra/calendar/model/model.factor b/basis/calendar/model/model.factor similarity index 76% rename from extra/calendar/model/model.factor rename to basis/calendar/model/model.factor index aa295e0f75..60a61c2026 100755 --- a/extra/calendar/model/model.factor +++ b/basis/calendar/model/model.factor @@ -10,7 +10,10 @@ SYMBOL: time 1000 sleep (time-thread) ; : time-thread ( -- ) - [ (time-thread) ] "Time model update" spawn drop ; + [ + init-namespaces + (time-thread) + ] "Time model update" spawn drop ; f time set-global [ time-thread ] "calendar.model" add-init-hook diff --git a/extra/calendar/model/summary.txt b/basis/calendar/model/summary.txt similarity index 100% rename from extra/calendar/model/summary.txt rename to basis/calendar/model/summary.txt diff --git a/extra/calendar/summary.txt b/basis/calendar/summary.txt similarity index 100% rename from extra/calendar/summary.txt rename to basis/calendar/summary.txt diff --git a/extra/calendar/backend/authors.txt b/basis/calendar/unix/authors.txt similarity index 100% rename from extra/calendar/backend/authors.txt rename to basis/calendar/unix/authors.txt diff --git a/basis/calendar/unix/tags.txt b/basis/calendar/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/calendar/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor similarity index 68% rename from extra/calendar/unix/unix.factor rename to basis/calendar/unix/unix.factor index 6383d4ec42..1da554e0f1 100644 --- a/extra/calendar/unix/unix.factor +++ b/basis/calendar/unix/unix.factor @@ -1,5 +1,5 @@ -USING: alien alien.c-types arrays calendar.backend -kernel structs math unix.time namespaces system ; +USING: alien alien.c-types arrays calendar kernel structs +math unix.time namespaces system ; IN: calendar.unix : get-time ( -- alien ) diff --git a/extra/calendar/unix/authors.txt b/basis/calendar/windows/authors.txt similarity index 100% rename from extra/calendar/unix/authors.txt rename to basis/calendar/windows/authors.txt diff --git a/basis/calendar/windows/tags.txt b/basis/calendar/windows/tags.txt new file mode 100644 index 0000000000..02ec70f741 --- /dev/null +++ b/basis/calendar/windows/tags.txt @@ -0,0 +1,2 @@ +unportable +windows diff --git a/extra/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor similarity index 82% rename from extra/calendar/windows/windows.factor rename to basis/calendar/windows/windows.factor index b621d3bde3..508cbb0a49 100755 --- a/extra/calendar/windows/windows.factor +++ b/basis/calendar/windows/windows.factor @@ -1,5 +1,5 @@ -USING: calendar.backend namespaces alien.c-types system -windows windows.kernel32 kernel math combinators ; +USING: calendar namespaces alien.c-types system windows +windows.kernel32 kernel math combinators ; IN: calendar.windows M: windows gmt-offset ( -- hours minutes seconds ) diff --git a/extra/balloon-bomber/authors.txt b/basis/channels/authors.txt similarity index 100% rename from extra/balloon-bomber/authors.txt rename to basis/channels/authors.txt diff --git a/extra/channels/channels-docs.factor b/basis/channels/channels-docs.factor similarity index 100% rename from extra/channels/channels-docs.factor rename to basis/channels/channels-docs.factor diff --git a/extra/channels/channels-tests.factor b/basis/channels/channels-tests.factor similarity index 95% rename from extra/channels/channels-tests.factor rename to basis/channels/channels-tests.factor index df72572c67..3300faa125 100755 --- a/extra/channels/channels-tests.factor +++ b/basis/channels/channels-tests.factor @@ -17,7 +17,7 @@ IN: channels.tests from ] unit-test -{ V{ 1 2 3 4 } } [ +{ { 1 2 3 4 } } [ V{ } clone [ from swap push ] in-thread [ from swap push ] in-thread @@ -30,7 +30,7 @@ IN: channels.tests natural-sort ] unit-test -{ V{ 1 2 4 9 } } [ +{ { 1 2 4 9 } } [ V{ } clone [ 4 swap to ] in-thread [ 2 swap to ] in-thread diff --git a/extra/channels/channels.factor b/basis/channels/channels.factor similarity index 70% rename from extra/channels/channels.factor rename to basis/channels/channels.factor index ea54766ad4..9b8c418634 100755 --- a/extra/channels/channels.factor +++ b/basis/channels/channels.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Channels - based on ideas from newsqueak -USING: kernel sequences sequences.lib threads continuations -random math ; +USING: kernel sequences threads continuations +random math accessors random ; IN: channels TUPLE: channel receivers senders ; @@ -17,14 +17,14 @@ GENERIC: from ( channel -- value ) > push ] curry "channel send" suspend drop ; : (to) ( value receivers -- ) delete-random resume-with yield ; : notify ( continuation channel -- channel ) - [ channel-receivers push ] keep ; + [ receivers>> push ] keep ; : (from) ( senders -- ) delete-random resume ; @@ -32,11 +32,11 @@ GENERIC: from ( channel -- value ) PRIVATE> M: channel to ( value channel -- ) - dup channel-receivers - dup empty? [ drop dup wait to ] [ nip (to) ] if ; + dup receivers>> + [ dup wait to ] [ nip (to) ] if-empty ; M: channel from ( channel -- value ) [ - notify channel-senders - dup empty? [ drop ] [ (from) ] if + notify senders>> + [ (from) ] unless-empty ] curry "channel receive" suspend ; diff --git a/extra/channels/authors.txt b/basis/channels/examples/authors.txt similarity index 100% rename from extra/channels/authors.txt rename to basis/channels/examples/authors.txt diff --git a/extra/channels/examples/examples.factor b/basis/channels/examples/examples.factor similarity index 100% rename from extra/channels/examples/examples.factor rename to basis/channels/examples/examples.factor diff --git a/extra/channels/examples/summary.txt b/basis/channels/examples/summary.txt similarity index 100% rename from extra/channels/examples/summary.txt rename to basis/channels/examples/summary.txt diff --git a/extra/channels/examples/tags.txt b/basis/channels/examples/tags.txt similarity index 100% rename from extra/channels/examples/tags.txt rename to basis/channels/examples/tags.txt diff --git a/extra/channels/examples/authors.txt b/basis/channels/remote/authors.txt similarity index 100% rename from extra/channels/examples/authors.txt rename to basis/channels/remote/authors.txt diff --git a/extra/channels/remote/remote-docs.factor b/basis/channels/remote/remote-docs.factor similarity index 100% rename from extra/channels/remote/remote-docs.factor rename to basis/channels/remote/remote-docs.factor diff --git a/extra/channels/remote/remote-tests.factor b/basis/channels/remote/remote-tests.factor similarity index 100% rename from extra/channels/remote/remote-tests.factor rename to basis/channels/remote/remote-tests.factor diff --git a/extra/channels/remote/remote.factor b/basis/channels/remote/remote.factor similarity index 85% rename from extra/channels/remote/remote.factor rename to basis/channels/remote/remote.factor index c9cfc83d27..9c1878e14d 100755 --- a/extra/channels/remote/remote.factor +++ b/basis/channels/remote/remote.factor @@ -4,7 +4,7 @@ ! Remote Channels USING: kernel init namespaces assocs arrays random sequences channels match concurrency.messaging -concurrency.distributed threads ; +concurrency.distributed threads accessors ; IN: channels.remote remote-channel M: remote-channel to ( value remote-channel -- ) - [ [ \ to , remote-channel-id , , ] { } make ] keep - remote-channel-node "remote-channels" + [ [ \ to , id>> , , ] { } make ] keep + node>> "remote-channels" send-synchronous no-channel = [ no-channel throw ] when ; M: remote-channel from ( remote-channel -- value ) - [ [ \ from , remote-channel-id , ] { } make ] keep - remote-channel-node "remote-channels" + [ [ \ from , id>> , ] { } make ] keep + node>> "remote-channels" send-synchronous dup no-channel = [ no-channel throw ] when* ; [ diff --git a/extra/channels/remote/summary.txt b/basis/channels/remote/summary.txt similarity index 100% rename from extra/channels/remote/summary.txt rename to basis/channels/remote/summary.txt diff --git a/extra/channels/remote/tags.txt b/basis/channels/remote/tags.txt similarity index 100% rename from extra/channels/remote/tags.txt rename to basis/channels/remote/tags.txt diff --git a/extra/channels/summary.txt b/basis/channels/summary.txt similarity index 100% rename from extra/channels/summary.txt rename to basis/channels/summary.txt diff --git a/extra/channels/tags.txt b/basis/channels/tags.txt similarity index 100% rename from extra/channels/tags.txt rename to basis/channels/tags.txt diff --git a/extra/checksums/adler-32/adler-32-docs.factor b/basis/checksums/adler-32/adler-32-docs.factor similarity index 100% rename from extra/checksums/adler-32/adler-32-docs.factor rename to basis/checksums/adler-32/adler-32-docs.factor diff --git a/extra/checksums/adler-32/adler-32-tests.factor b/basis/checksums/adler-32/adler-32-tests.factor similarity index 100% rename from extra/checksums/adler-32/adler-32-tests.factor rename to basis/checksums/adler-32/adler-32-tests.factor diff --git a/extra/checksums/adler-32/adler-32.factor b/basis/checksums/adler-32/adler-32.factor similarity index 100% rename from extra/checksums/adler-32/adler-32.factor rename to basis/checksums/adler-32/adler-32.factor diff --git a/extra/calendar/windows/authors.txt b/basis/checksums/adler-32/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/calendar/windows/authors.txt rename to basis/checksums/adler-32/authors.txt diff --git a/extra/checksums/adler-32/authors.txt b/basis/checksums/common/authors.txt similarity index 100% rename from extra/checksums/adler-32/authors.txt rename to basis/checksums/common/authors.txt diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor new file mode 100644 index 0000000000..ea1c6f5b39 --- /dev/null +++ b/basis/checksums/common/common.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2006, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.bitwise strings io.binary namespaces +grouping ; +IN: checksums.common + +SYMBOL: bytes-read + +: calculate-pad-length ( length -- pad-length ) + dup 56 < 55 119 ? swap - ; + +: pad-last-block ( str big-endian? length -- str ) + [ + rot % + HEX: 80 , + dup HEX: 3f bitand calculate-pad-length 0 % + 3 shift 8 rot [ >be ] [ >le ] if % + ] "" make 64 group ; + +: update-old-new ( old new -- ) + [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline diff --git a/basis/checksums/common/summary.txt b/basis/checksums/common/summary.txt new file mode 100644 index 0000000000..0956c052a4 --- /dev/null +++ b/basis/checksums/common/summary.txt @@ -0,0 +1 @@ +Some code shared by MD5, SHA1 and SHA2 implementations diff --git a/extra/checksums/md5/authors.txt b/basis/checksums/md5/authors.txt similarity index 100% rename from extra/checksums/md5/authors.txt rename to basis/checksums/md5/authors.txt diff --git a/extra/checksums/md5/md5-docs.factor b/basis/checksums/md5/md5-docs.factor similarity index 100% rename from extra/checksums/md5/md5-docs.factor rename to basis/checksums/md5/md5-docs.factor diff --git a/extra/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor similarity index 100% rename from extra/checksums/md5/md5-tests.factor rename to basis/checksums/md5/md5-tests.factor diff --git a/extra/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor similarity index 90% rename from extra/checksums/md5/md5.factor rename to basis/checksums/md5/md5.factor index a385f6d04f..6158254f84 100755 --- a/extra/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -1,11 +1,14 @@ -! See http://www.faqs.org/rfcs/rfc1321.html - +! Copyright (C) 2006, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: kernel io io.binary io.files io.streams.byte-array math -math.functions math.parser namespaces splitting strings -sequences crypto.common byte-arrays locals sequences.private -io.encodings.binary symbols math.bitfields.lib checksums ; +math.functions math.parser namespaces splitting grouping strings +sequences byte-arrays locals sequences.private +io.encodings.binary symbols math.bitwise checksums +checksums.common ; IN: checksums.md5 +! See http://www.faqs.org/rfcs/rfc1321.html + be> ; inline + : make-w ( str -- ) #! compute w, steps a-b of RFC 3174, section 6.1 16 [ nth-int-be w get push ] with each @@ -113,8 +118,16 @@ INSTANCE: sha1 checksum M: sha1 checksum-stream ( stream -- sha1 ) drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ; +: seq>2seq ( seq -- seq1 seq2 ) + #! { abcdefgh } -> { aceg } { bdfh } + 2 group flip [ { } { } ] [ first2 ] if-empty ; + +: 2seq>seq ( seq1 seq2 -- seq ) + #! { aceg } { bdfh } -> { abcdefgh } + [ zip concat ] keep like ; + : sha1-interleave ( string -- seq ) - [ zero? ] left-trim + [ zero? ] trim-left dup length odd? [ rest ] when seq>2seq [ sha1 checksum-bytes ] bi@ 2seq>seq ; diff --git a/extra/checksums/sha2/authors.txt b/basis/checksums/sha2/authors.txt similarity index 100% rename from extra/checksums/sha2/authors.txt rename to basis/checksums/sha2/authors.txt diff --git a/extra/checksums/sha2/sha2-docs.factor b/basis/checksums/sha2/sha2-docs.factor similarity index 100% rename from extra/checksums/sha2/sha2-docs.factor rename to basis/checksums/sha2/sha2-docs.factor diff --git a/extra/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor similarity index 100% rename from extra/checksums/sha2/sha2-tests.factor rename to basis/checksums/sha2/sha2-tests.factor diff --git a/extra/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor similarity index 84% rename from extra/checksums/sha2/sha2.factor rename to basis/checksums/sha2/sha2.factor index e5f16c9c11..ac93c05260 100755 --- a/extra/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -1,5 +1,8 @@ -USING: crypto.common kernel splitting math sequences namespaces -io.binary symbols math.bitfields.lib checksums ; +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel splitting grouping math sequences namespaces +io.binary symbols math.bitwise checksums checksums.common +sbufs strings ; IN: checksums.sha2 r dup 3 + r> first3 ; inline + : T1 ( W n -- T1 ) [ swap nth ] keep K get nth + @@ -111,6 +116,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ; : seq>byte-array ( n seq -- string ) [ swap [ >be % ] curry each ] B{ } make ; +: preprocess-plaintext ( string big-endian? -- padded-string ) + #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits + >r >sbuf r> over [ + HEX: 80 , + dup length HEX: 3f bitand + calculate-pad-length 0 % + length 3 shift 8 rot [ >be ] [ >le ] if % + ] "" make over push-all ; + : byte-array>sha2 ( byte-array -- string ) t preprocess-plaintext block-size get group [ process-chunk ] each diff --git a/extra/circular/authors.txt b/basis/circular/authors.txt similarity index 100% rename from extra/circular/authors.txt rename to basis/circular/authors.txt diff --git a/extra/circular/circular-tests.factor b/basis/circular/circular-tests.factor similarity index 100% rename from extra/circular/circular-tests.factor rename to basis/circular/circular-tests.factor diff --git a/extra/circular/circular.factor b/basis/circular/circular.factor similarity index 100% rename from extra/circular/circular.factor rename to basis/circular/circular.factor diff --git a/extra/circular/summary.txt b/basis/circular/summary.txt similarity index 100% rename from extra/circular/summary.txt rename to basis/circular/summary.txt diff --git a/core/heaps/tags.txt b/basis/circular/tags.txt similarity index 100% rename from core/heaps/tags.txt rename to basis/circular/tags.txt diff --git a/extra/cocoa/application/application-docs.factor b/basis/cocoa/application/application-docs.factor similarity index 100% rename from extra/cocoa/application/application-docs.factor rename to basis/cocoa/application/application-docs.factor diff --git a/extra/cocoa/application/application.factor b/basis/cocoa/application/application.factor similarity index 79% rename from extra/cocoa/application/application.factor rename to basis/cocoa/application/application.factor index 90159c1656..a28952ea33 100755 --- a/extra/cocoa/application/application.factor +++ b/basis/cocoa/application/application.factor @@ -1,14 +1,22 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien io kernel namespaces core-foundation +USING: alien alien.syntax io kernel namespaces core-foundation core-foundation.run-loop cocoa.messages cocoa cocoa.classes -cocoa.runtime sequences threads debugger init inspector -kernel.private ; +cocoa.runtime sequences threads debugger init summary +kernel.private assocs ; IN: cocoa.application : ( str -- alien ) -> autorelease ; - : ( seq -- alien ) -> autorelease ; +: ( number -- alien ) -> autorelease ; +: ( byte-array -- alien ) -> autorelease ; +: ( assoc -- alien ) + NSMutableDictionary over assoc-size -> dictionaryWithCapacity: + [ + [ + spin -> setObject:forKey: + ] curry assoc-each + ] keep ; : NSApplicationDelegateReplySuccess 0 ; : NSApplicationDelegateReplyCancel 1 ; @@ -19,6 +27,8 @@ IN: cocoa.application : NSApp ( -- app ) NSApplication -> sharedApplication ; +FUNCTION: void NSBeep ( ) ; + : with-cocoa ( quot -- ) [ NSApp drop call ] with-autorelease-pool ; diff --git a/core/cpu/arm/intrinsics/authors.txt b/basis/cocoa/application/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/cpu/arm/intrinsics/authors.txt rename to basis/cocoa/application/authors.txt diff --git a/extra/cocoa/application/summary.txt b/basis/cocoa/application/summary.txt similarity index 100% rename from extra/cocoa/application/summary.txt rename to basis/cocoa/application/summary.txt diff --git a/basis/cocoa/application/tags.txt b/basis/cocoa/application/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/application/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/cpu/ppc/allot/authors.txt b/basis/cocoa/authors.txt similarity index 100% rename from core/cpu/ppc/allot/authors.txt rename to basis/cocoa/authors.txt diff --git a/extra/cocoa/callbacks/authors.txt b/basis/cocoa/callbacks/authors.txt similarity index 100% rename from extra/cocoa/callbacks/authors.txt rename to basis/cocoa/callbacks/authors.txt diff --git a/extra/cocoa/callbacks/callbacks.factor b/basis/cocoa/callbacks/callbacks.factor similarity index 100% rename from extra/cocoa/callbacks/callbacks.factor rename to basis/cocoa/callbacks/callbacks.factor diff --git a/extra/cocoa/callbacks/summary.txt b/basis/cocoa/callbacks/summary.txt similarity index 100% rename from extra/cocoa/callbacks/summary.txt rename to basis/cocoa/callbacks/summary.txt diff --git a/basis/cocoa/callbacks/tags.txt b/basis/cocoa/callbacks/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/callbacks/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/cocoa/cocoa-docs.factor b/basis/cocoa/cocoa-docs.factor similarity index 62% rename from extra/cocoa/cocoa-docs.factor rename to basis/cocoa/cocoa-docs.factor index 30602db40b..01b0809f37 100644 --- a/extra/cocoa/cocoa-docs.factor +++ b/basis/cocoa/cocoa-docs.factor @@ -28,5 +28,21 @@ $nl { $subsection send } { $subsection super-send } ; +ARTICLE: "cocoa" "Cocoa bridge" +"The " { $vocab-link "cocoa" } " vocabulary implements a Factor-Cocoa bridge for Mac OS X (GNUstep is not supported)." +$nl +"The lowest layer uses the " { $link "alien" } " to define bindings for the various functions in Apple's Objective-C runtime. This is defined in the " { $vocab-link "cocoa.runtime" } " vocabulary." +$nl +"On top of this, a dynamic message send facility is built:" +{ $subsection "objc-calling" } +{ $subsection "objc-subclassing" } +"A utility library is built to faciliate the development of Cocoa applications in Factor:" +{ $subsection "cocoa-types" } +{ $subsection "cocoa-application-utils" } +{ $subsection "cocoa-dialogs" } +{ $subsection "cocoa-pasteboard-utils" } +{ $subsection "cocoa-view-utils" } +{ $subsection "cocoa-window-utils" } ; + IN: cocoa -ABOUT: "objc-calling" +ABOUT: "cocoa" diff --git a/extra/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor similarity index 66% rename from extra/cocoa/cocoa-tests.factor rename to basis/cocoa/cocoa-tests.factor index 4b56d81626..e1d6672872 100644 --- a/extra/cocoa/cocoa-tests.factor +++ b/basis/cocoa/cocoa-tests.factor @@ -20,10 +20,10 @@ CLASS: { test-foo -[ 1 ] [ "x" get NSRect-x ] unit-test -[ 2 ] [ "x" get NSRect-y ] unit-test -[ 101 ] [ "x" get NSRect-w ] unit-test -[ 102 ] [ "x" get NSRect-h ] unit-test +[ 1.0 ] [ "x" get NSRect-x ] unit-test +[ 2.0 ] [ "x" get NSRect-y ] unit-test +[ 101.0 ] [ "x" get NSRect-w ] unit-test +[ 102.0 ] [ "x" get NSRect-h ] unit-test CLASS: { { +superclass+ "NSObject" } @@ -41,7 +41,7 @@ Bar [ -> release ] compile-call -[ 1 ] [ "x" get NSRect-x ] unit-test -[ 2 ] [ "x" get NSRect-y ] unit-test -[ 101 ] [ "x" get NSRect-w ] unit-test -[ 102 ] [ "x" get NSRect-h ] unit-test +[ 1.0 ] [ "x" get NSRect-x ] unit-test +[ 2.0 ] [ "x" get NSRect-y ] unit-test +[ 101.0 ] [ "x" get NSRect-w ] unit-test +[ 102.0 ] [ "x" get NSRect-h ] unit-test diff --git a/extra/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor similarity index 90% rename from extra/cocoa/cocoa.factor rename to basis/cocoa/cocoa.factor index f4cfb20591..744d577c0d 100755 --- a/extra/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: compiler io kernel cocoa.runtime cocoa.subclassing cocoa.messages cocoa.types sequences words vocabs parser -core-foundation namespaces assocs hashtables compiler.units ; +core-foundation namespaces assocs hashtables compiler.units +lexer ; IN: cocoa : (remember-send) ( selector variable -- ) @@ -42,6 +43,7 @@ SYMBOL: super-sent-messages "NSArray" "NSAutoreleasePool" "NSBundle" + "NSData" "NSDictionary" "NSError" "NSEvent" @@ -52,15 +54,18 @@ SYMBOL: super-sent-messages "NSNib" "NSNotification" "NSNotificationCenter" + "NSNumber" "NSObject" "NSOpenGLContext" "NSOpenGLPixelFormat" "NSOpenGLView" "NSOpenPanel" "NSPasteboard" + "NSPropertyListSerialization" "NSResponder" "NSSavePanel" "NSScreen" + "NSString" "NSView" "NSWindow" "NSWorkspace" diff --git a/core/cpu/ppc/architecture/authors.txt b/basis/cocoa/dialogs/authors.txt similarity index 100% rename from core/cpu/ppc/architecture/authors.txt rename to basis/cocoa/dialogs/authors.txt diff --git a/extra/cocoa/dialogs/dialogs-docs.factor b/basis/cocoa/dialogs/dialogs-docs.factor similarity index 100% rename from extra/cocoa/dialogs/dialogs-docs.factor rename to basis/cocoa/dialogs/dialogs-docs.factor diff --git a/extra/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor similarity index 100% rename from extra/cocoa/dialogs/dialogs.factor rename to basis/cocoa/dialogs/dialogs.factor diff --git a/extra/cocoa/dialogs/summary.txt b/basis/cocoa/dialogs/summary.txt similarity index 100% rename from extra/cocoa/dialogs/summary.txt rename to basis/cocoa/dialogs/summary.txt diff --git a/basis/cocoa/dialogs/tags.txt b/basis/cocoa/dialogs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/dialogs/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor new file mode 100644 index 0000000000..765fb65ef2 --- /dev/null +++ b/basis/cocoa/enumeration/enumeration.factor @@ -0,0 +1,30 @@ +USING: kernel cocoa cocoa.types alien.c-types locals math sequences +vectors fry libc ; +IN: cocoa.enumeration + +: NS-EACH-BUFFER-SIZE 16 ; inline + +: (with-enumeration-buffers) ( quot -- ) + "NSFastEnumerationState" heap-size swap '[ + NS-EACH-BUFFER-SIZE "id" heap-size * [ + NS-EACH-BUFFER-SIZE @ + ] with-malloc + ] with-malloc ; inline + +:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) + object state stackbuf count -> countByEnumeratingWithState:objects:count: + dup zero? [ drop ] [ + state NSFastEnumerationState-itemsPtr [ stackbuf ] unless* + '[ , void*-nth quot call ] each + object quot state stackbuf count (NSFastEnumeration-each) + ] if ; inline recursive + +: NSFastEnumeration-each ( object quot -- ) + [ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline + +: NSFastEnumeration-map ( object quot -- vector ) + NS-EACH-BUFFER-SIZE + [ '[ @ , push ] NSFastEnumeration-each ] keep ; inline + +: NSFastEnumeration>vector ( object -- vector ) + [ ] NSFastEnumeration-map ; diff --git a/basis/cocoa/enumeration/tags.txt b/basis/cocoa/enumeration/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/enumeration/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/cpu/ppc/assembler/authors.txt b/basis/cocoa/messages/authors.txt similarity index 100% rename from core/cpu/ppc/assembler/authors.txt rename to basis/cocoa/messages/authors.txt diff --git a/extra/cocoa/messages/messages-docs.factor b/basis/cocoa/messages/messages-docs.factor similarity index 100% rename from extra/cocoa/messages/messages-docs.factor rename to basis/cocoa/messages/messages-docs.factor diff --git a/extra/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor similarity index 80% rename from extra/cocoa/messages/messages.factor rename to basis/cocoa/messages/messages.factor index f917e20bc4..ceb3a0021c 100755 --- a/extra/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings alien.compiler -arrays assocs combinators compiler inference.transforms kernel +USING: accessors alien alien.c-types alien.strings +arrays assocs combinators compiler kernel math namespaces parser prettyprint prettyprint.sections quotations sequences strings words cocoa.runtime io macros -memoize debugger io.encodings.ascii ; +memoize debugger io.encodings.ascii effects compiler.generator +libc libc.private ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -36,7 +37,7 @@ super-message-senders global [ H{ } assoc-like ] change-at : ( receiver -- super ) "objc-super" [ - >r dup objc-object-isa objc-class-super-class r> + >r dup object_getClass class_getSuperclass r> set-objc-super-class ] keep [ set-objc-super-receiver ] keep ; @@ -46,11 +47,11 @@ TUPLE: selector name object ; MEMO: ( name -- sel ) f \ selector boa ; : selector ( selector -- alien ) - dup selector-object expired? [ - dup selector-name sel_registerName - dup rot set-selector-object + dup object>> expired? [ + dup name>> sel_registerName + [ >>object drop ] keep ] [ - selector-object + object>> ] if ; SYMBOL: objc-methods @@ -101,11 +102,6 @@ MACRO: (send) ( selector super? -- quot ) : objc-meta-class ( string -- class ) \ objc_getMetaClass (objc-class) ; -: method-arg-type ( method i -- type ) - f 0 over - >r method_getArgumentInfo drop - r> *void* ascii alien>string ; - SYMBOL: objc>alien-types H{ @@ -159,34 +155,32 @@ H{ : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ; +: method-arg-type ( method i -- type ) + method_copyArgumentType + [ ascii alien>string parse-objc-type ] keep + (free) ; + : method-arg-types ( method -- args ) dup method_getNumberOfArguments - [ method-arg-type parse-objc-type ] with map ; + [ method-arg-type ] with map ; : method-return-type ( method -- ctype ) - #! Undocumented hack! Apple does not support this feature! - objc-method-types parse-objc-type ; + method_copyReturnType + [ ascii alien>string parse-objc-type ] keep + (free) ; : register-objc-method ( method -- ) dup method-return-type over method-arg-types 2array dup cache-stubs - swap objc-method-name sel_getName + swap method_getName sel_getName objc-methods get set-at ; -: method-list@ ( ptr -- ptr ) - "objc-method-list" heap-size swap ; - -: (register-objc-methods) ( objc-class iterator -- ) - 2dup class_nextMethodList [ - dup objc-method-list-count swap method-list@ [ - objc-method-nth register-objc-method - ] curry each (register-objc-methods) - ] [ - 2drop - ] if* ; +: (register-objc-methods) ( methods count -- methods ) + over [ void*-nth register-objc-method ] curry each ; : register-objc-methods ( class -- ) - f (register-objc-methods) ; + 0 [ class_copyMethodList ] keep *uint + (register-objc-methods) (free) ; : class-exists? ( string -- class ) objc_getClass >boolean ; @@ -196,7 +190,8 @@ H{ : define-objc-class-word ( name quot -- ) [ over , , \ unless-defined , dup , \ objc-class , - ] [ ] make >r "cocoa.classes" create r> define ; + ] [ ] make >r "cocoa.classes" create r> + (( -- class )) define-declared ; : import-objc-class ( name quot -- ) 2dup unless-defined @@ -208,4 +203,4 @@ H{ ] curry try ; : root-class ( class -- root ) - dup objc-class-super-class [ root-class ] [ ] ?if ; + dup class_getSuperclass [ root-class ] [ ] ?if ; diff --git a/extra/cocoa/messages/summary.txt b/basis/cocoa/messages/summary.txt similarity index 100% rename from extra/cocoa/messages/summary.txt rename to basis/cocoa/messages/summary.txt diff --git a/basis/cocoa/messages/tags.txt b/basis/cocoa/messages/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/messages/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/cocoa/nibs/authors.txt b/basis/cocoa/nibs/authors.txt similarity index 100% rename from extra/cocoa/nibs/authors.txt rename to basis/cocoa/nibs/authors.txt diff --git a/extra/cocoa/nibs/nibs-docs.factor b/basis/cocoa/nibs/nibs-docs.factor similarity index 100% rename from extra/cocoa/nibs/nibs-docs.factor rename to basis/cocoa/nibs/nibs-docs.factor diff --git a/extra/cocoa/nibs/nibs.factor b/basis/cocoa/nibs/nibs.factor similarity index 100% rename from extra/cocoa/nibs/nibs.factor rename to basis/cocoa/nibs/nibs.factor diff --git a/extra/cocoa/nibs/summary.txt b/basis/cocoa/nibs/summary.txt similarity index 100% rename from extra/cocoa/nibs/summary.txt rename to basis/cocoa/nibs/summary.txt diff --git a/basis/cocoa/nibs/tags.txt b/basis/cocoa/nibs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/nibs/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/cpu/ppc/authors.txt b/basis/cocoa/pasteboard/authors.txt similarity index 100% rename from core/cpu/ppc/authors.txt rename to basis/cocoa/pasteboard/authors.txt diff --git a/extra/cocoa/pasteboard/pasteboard-docs.factor b/basis/cocoa/pasteboard/pasteboard-docs.factor similarity index 100% rename from extra/cocoa/pasteboard/pasteboard-docs.factor rename to basis/cocoa/pasteboard/pasteboard-docs.factor diff --git a/extra/cocoa/pasteboard/pasteboard.factor b/basis/cocoa/pasteboard/pasteboard.factor similarity index 100% rename from extra/cocoa/pasteboard/pasteboard.factor rename to basis/cocoa/pasteboard/pasteboard.factor diff --git a/extra/cocoa/pasteboard/summary.txt b/basis/cocoa/pasteboard/summary.txt similarity index 100% rename from extra/cocoa/pasteboard/summary.txt rename to basis/cocoa/pasteboard/summary.txt diff --git a/basis/cocoa/pasteboard/tags.txt b/basis/cocoa/pasteboard/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/pasteboard/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/cpu/ppc/intrinsics/authors.txt b/basis/cocoa/plists/authors.txt similarity index 100% rename from core/cpu/ppc/intrinsics/authors.txt rename to basis/cocoa/plists/authors.txt diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor new file mode 100644 index 0000000000..bb73b8fac3 --- /dev/null +++ b/basis/cocoa/plists/plists.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: strings arrays hashtables assocs sequences +cocoa.messages cocoa.classes cocoa.application cocoa kernel +namespaces io.backend math cocoa.enumeration byte-arrays +combinators alien.c-types core-foundation ; +IN: cocoa.plists + +GENERIC: >plist ( value -- plist ) + +M: number >plist + ; +M: t >plist + ; +M: f >plist + ; +M: string >plist + ; +M: byte-array >plist + ; +M: hashtable >plist + [ [ >plist ] bi@ ] assoc-map ; +M: sequence >plist + [ >plist ] map ; + +: write-plist ( assoc path -- ) + [ >plist ] [ normalize-path ] bi* 0 + -> writeToFile:atomically: + [ "write-plist failed" throw ] unless ; + +DEFER: plist> + +: (plist-NSString>) ( NSString -- string ) + -> UTF8String ; + +: (plist-NSNumber>) ( NSNumber -- number ) + dup -> doubleValue dup >integer = + [ -> longLongValue ] + [ -> doubleValue ] if ; + +: (plist-NSData>) ( NSData -- byte-array ) + dup -> length [ -> getBytes: ] keep ; + +: (plist-NSArray>) ( NSArray -- vector ) + [ plist> ] NSFastEnumeration-map ; + +: (plist-NSDictionary>) ( NSDictionary -- hashtable ) + dup [ [ -> valueForKey: ] keep swap [ plist> ] bi@ 2array ] with + NSFastEnumeration-map >hashtable ; + +: plist> ( plist -- value ) + { + { [ dup NSString -> isKindOfClass: c-bool> ] [ (plist-NSString>) ] } + { [ dup NSNumber -> isKindOfClass: c-bool> ] [ (plist-NSNumber>) ] } + { [ dup NSData -> isKindOfClass: c-bool> ] [ (plist-NSData>) ] } + { [ dup NSArray -> isKindOfClass: c-bool> ] [ (plist-NSArray>) ] } + { [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] } + [ ] + } cond ; + +: (read-plist) ( NSData -- id ) + NSPropertyListSerialization swap kCFPropertyListImmutable f f + [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep + *void* [ -> release "read-plist failed" throw ] when* ; + +: read-plist ( path -- assoc ) + normalize-path + NSData swap -> dataWithContentsOfFile: + [ (read-plist) plist> ] [ "read-plist failed" throw ] if* ; diff --git a/basis/cocoa/plists/tags.txt b/basis/cocoa/plists/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/plists/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/cpu/x86/32/authors.txt b/basis/cocoa/runtime/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/cpu/x86/32/authors.txt rename to basis/cocoa/runtime/authors.txt diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor new file mode 100644 index 0000000000..3451ce5e6e --- /dev/null +++ b/basis/cocoa/runtime/runtime.factor @@ -0,0 +1,77 @@ +! Copyright (C) 2006, 2007 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax ; +IN: cocoa.runtime + +TYPEDEF: void* SEL + +TYPEDEF: void* id + +FUNCTION: char* sel_getName ( SEL aSelector ) ; + +FUNCTION: bool sel_isMapped ( SEL aSelector ) ; + +FUNCTION: SEL sel_registerName ( char* str ) ; + +TYPEDEF: void* Class +TYPEDEF: void* Method +TYPEDEF: void* Protocol + +C-STRUCT: objc-super + { "id" "receiver" } + { "Class" "class" } ; + +: CLS_CLASS HEX: 1 ; +: CLS_META HEX: 2 ; +: CLS_INITIALIZED HEX: 4 ; +: CLS_POSING HEX: 8 ; +: CLS_MAPPED HEX: 10 ; +: CLS_FLUSH_CACHE HEX: 20 ; +: CLS_GROW_CACHE HEX: 40 ; +: CLS_NEED_BIND HEX: 80 ; +: CLS_METHOD_ARRAY HEX: 100 ; + +FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ; + +FUNCTION: Class objc_getClass ( char* class ) ; + +FUNCTION: Class objc_getMetaClass ( char* class ) ; + +FUNCTION: Protocol objc_getProtocol ( char* class ) ; + +FUNCTION: Class objc_allocateClassPair ( Class superclass, char* name, size_t extraBytes ) ; +FUNCTION: void objc_registerClassPair ( Class cls ) ; + +FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ; + +FUNCTION: id class_createInstanceFromZone ( Class class, uint additionalByteCount, void* zone ) ; + +FUNCTION: Method class_getInstanceMethod ( Class class, SEL selector ) ; + +FUNCTION: Method class_getClassMethod ( Class class, SEL selector ) ; + +FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ; + +FUNCTION: Class class_getSuperclass ( Class cls ) ; + +FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ; + +FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ; + +FUNCTION: uint method_getNumberOfArguments ( Method method ) ; + +FUNCTION: uint method_getSizeOfArguments ( Method method ) ; + +FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, char** type, int* offset ) ; + +FUNCTION: void* method_copyReturnType ( Method method ) ; + +FUNCTION: void* method_copyArgumentType ( Method method, uint index ) ; + +FUNCTION: void* method_getTypeEncoding ( Method method ) ; + +FUNCTION: SEL method_getName ( Method method ) ; + +FUNCTION: void* method_setImplementation ( Method method, void* imp ) ; + +FUNCTION: Class object_getClass ( id object ) ; diff --git a/extra/cocoa/runtime/summary.txt b/basis/cocoa/runtime/summary.txt similarity index 100% rename from extra/cocoa/runtime/summary.txt rename to basis/cocoa/runtime/summary.txt diff --git a/basis/cocoa/runtime/tags.txt b/basis/cocoa/runtime/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/runtime/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/core/cpu/x86/64/authors.txt b/basis/cocoa/subclassing/authors.txt similarity index 100% rename from core/cpu/x86/64/authors.txt rename to basis/cocoa/subclassing/authors.txt diff --git a/extra/cocoa/subclassing/subclassing-docs.factor b/basis/cocoa/subclassing/subclassing-docs.factor similarity index 100% rename from extra/cocoa/subclassing/subclassing-docs.factor rename to basis/cocoa/subclassing/subclassing-docs.factor diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor new file mode 100755 index 0000000000..1ee39c35d5 --- /dev/null +++ b/basis/cocoa/subclassing/subclassing.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2006, 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.strings arrays assocs +combinators compiler hashtables kernel libc math namespaces +parser sequences words cocoa.messages cocoa.runtime +compiler.units io.encodings.ascii generalizations +continuations ; +IN: cocoa.subclassing + +: init-method ( method -- sel imp types ) + first3 swap + [ sel_registerName ] [ execute ] [ ascii string>alien ] + tri* ; + +: add-methods ( methods class -- ) + swap + [ init-method class_addMethod drop ] with each ; + +: add-protocols ( protocols class -- ) + swap [ objc-protocol class_addProtocol drop ] with each ; + +: (define-objc-class) ( protocols superclass name imeth -- ) + -rot + [ objc-class ] dip 0 objc_allocateClassPair + [ add-methods ] [ add-protocols ] [ objc_registerClassPair ] + tri ; + +: encode-types ( return types -- encoding ) + swap prefix [ + alien>objc-types get at "0" append + ] map concat ; + +: prepare-method ( ret types quot -- type imp ) + >r [ encode-types ] 2keep r> [ + "cdecl" swap 4array % \ alien-callback , + ] [ ] make define-temp ; + +: prepare-methods ( methods -- methods ) + [ + [ first4 prepare-method 3array ] map + ] with-compilation-unit ; + +: types= ( a b -- ? ) + [ ascii alien>string ] bi@ = ; + +: (verify-method-type) ( class sel types -- ) + [ class_getInstanceMethod method_getTypeEncoding ] + dip types= + [ "Objective-C method types cannot be changed once defined" throw ] + unless ; +: verify-method-type ( class sel imp types -- class sel imp types ) + 4 ndup nip (verify-method-type) ; + +: (redefine-objc-method) ( class method -- ) + init-method ! verify-method-type + drop + [ class_getInstanceMethod ] dip method_setImplementation drop ; + +: redefine-objc-methods ( imeth name -- ) + dup class-exists? [ + objc_getClass swap [ (redefine-objc-method) ] with each + ] [ + 2drop + ] if ; + +SYMBOL: +name+ +SYMBOL: +protocols+ +SYMBOL: +superclass+ + +: define-objc-class ( imeth hash -- ) + clone [ + prepare-methods + +name+ get "cocoa.classes" create drop + +name+ get 2dup redefine-objc-methods swap [ + +protocols+ get , +superclass+ get , +name+ get , , + \ (define-objc-class) , + ] [ ] make import-objc-class + ] bind ; + +: CLASS: + parse-definition unclip + >hashtable define-objc-class ; parsing diff --git a/extra/cocoa/subclassing/summary.txt b/basis/cocoa/subclassing/summary.txt similarity index 100% rename from extra/cocoa/subclassing/summary.txt rename to basis/cocoa/subclassing/summary.txt diff --git a/basis/cocoa/subclassing/tags.txt b/basis/cocoa/subclassing/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/subclassing/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/cocoa/summary.txt b/basis/cocoa/summary.txt similarity index 100% rename from extra/cocoa/summary.txt rename to basis/cocoa/summary.txt diff --git a/basis/cocoa/tags.txt b/basis/cocoa/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/cocoa/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/core/cpu/x86/allot/authors.txt b/basis/cocoa/types/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/cpu/x86/allot/authors.txt rename to basis/cocoa/types/authors.txt diff --git a/extra/cocoa/types/summary.txt b/basis/cocoa/types/summary.txt similarity index 100% rename from extra/cocoa/types/summary.txt rename to basis/cocoa/types/summary.txt diff --git a/basis/cocoa/types/tags.txt b/basis/cocoa/types/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/types/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/cocoa/types/types-docs.factor b/basis/cocoa/types/types-docs.factor similarity index 100% rename from extra/cocoa/types/types-docs.factor rename to basis/cocoa/types/types-docs.factor diff --git a/extra/cocoa/types/types.factor b/basis/cocoa/types/types.factor similarity index 90% rename from extra/cocoa/types/types.factor rename to basis/cocoa/types/types.factor index 7d21687e1b..dbaf311da2 100644 --- a/extra/cocoa/types/types.factor +++ b/basis/cocoa/types/types.factor @@ -64,3 +64,9 @@ C-STRUCT: CGAffineTransform { "float" "d" } { "float" "tx" } { "float" "ty" } ; + +C-STRUCT: NSFastEnumerationState + { "ulong" "state" } + { "id*" "itemsPtr" } + { "ulong*" "mutationsPtr" } + { "ulong[5]" "extra" } ; diff --git a/core/cpu/x86/architecture/authors.txt b/basis/cocoa/views/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/cpu/x86/architecture/authors.txt rename to basis/cocoa/views/authors.txt diff --git a/extra/cocoa/views/summary.txt b/basis/cocoa/views/summary.txt similarity index 100% rename from extra/cocoa/views/summary.txt rename to basis/cocoa/views/summary.txt diff --git a/basis/cocoa/views/tags.txt b/basis/cocoa/views/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/views/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/cocoa/views/views-docs.factor b/basis/cocoa/views/views-docs.factor similarity index 100% rename from extra/cocoa/views/views-docs.factor rename to basis/cocoa/views/views-docs.factor diff --git a/extra/cocoa/views/views.factor b/basis/cocoa/views/views.factor similarity index 77% rename from extra/cocoa/views/views.factor rename to basis/cocoa/views/views.factor index ca631d5dea..8bfbe330b2 100644 --- a/extra/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -21,6 +21,10 @@ IN: cocoa.views : NSOpenGLPFASampleBuffers 55 ; : NSOpenGLPFASamples 56 ; : NSOpenGLPFAAuxDepthStencil 57 ; +: NSOpenGLPFAColorFloat 58 ; +: NSOpenGLPFAMultisample 59 ; +: NSOpenGLPFASupersample 60 ; +: NSOpenGLPFASampleAlpha 61 ; : NSOpenGLPFARendererID 70 ; : NSOpenGLPFASingleRenderer 71 ; : NSOpenGLPFANoRecovery 72 ; @@ -34,25 +38,36 @@ IN: cocoa.views : NSOpenGLPFACompliant 83 ; : NSOpenGLPFAScreenMask 84 ; : NSOpenGLPFAPixelBuffer 90 ; +: NSOpenGLPFAAllowOfflineRenderers 96 ; : NSOpenGLPFAVirtualScreenCount 128 ; +: kCGLRendererGenericFloatID HEX: 00020400 ; + : with-software-renderer ( quot -- ) - t +software-renderer+ set - [ f +software-renderer+ set ] - [ ] cleanup ; inline + t +software-renderer+ pick with-variable ; inline +: with-multisample ( quot -- ) + t +multisample+ pick with-variable ; inline : ( -- pixelfmt ) NSOpenGLPixelFormat -> alloc [ NSOpenGLPFAWindow , NSOpenGLPFADoubleBuffer , NSOpenGLPFADepthSize , 16 , - +software-renderer+ get [ NSOpenGLPFARobust , ] when + +software-renderer+ get [ + NSOpenGLPFARendererID , kCGLRendererGenericFloatID , + ] when + +multisample+ get [ + NSOpenGLPFASupersample , + NSOpenGLPFASampleBuffers , 1 , + NSOpenGLPFASamples , 8 , + ] when 0 , ] { } make >c-int-array -> initWithAttributes: diff --git a/core/cpu/x86/assembler/authors.txt b/basis/cocoa/windows/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from core/cpu/x86/assembler/authors.txt rename to basis/cocoa/windows/authors.txt diff --git a/extra/cocoa/windows/summary.txt b/basis/cocoa/windows/summary.txt similarity index 100% rename from extra/cocoa/windows/summary.txt rename to basis/cocoa/windows/summary.txt diff --git a/basis/cocoa/windows/tags.txt b/basis/cocoa/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/cocoa/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/extra/cocoa/windows/windows-docs.factor b/basis/cocoa/windows/windows-docs.factor similarity index 100% rename from extra/cocoa/windows/windows-docs.factor rename to basis/cocoa/windows/windows-docs.factor diff --git a/extra/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor similarity index 97% rename from extra/cocoa/windows/windows.factor rename to basis/cocoa/windows/windows.factor index 74a181f9a2..dd2d1bfd41 100755 --- a/extra/cocoa/windows/windows.factor +++ b/basis/cocoa/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math cocoa cocoa.messages cocoa.classes -sequences math.bitfields ; +sequences math.bitwise ; IN: cocoa.windows : NSBorderlessWindowMask 0 ; inline diff --git a/core/cpu/x86/authors.txt b/basis/colors/authors.txt similarity index 100% rename from core/cpu/x86/authors.txt rename to basis/colors/authors.txt diff --git a/basis/colors/colors.factor b/basis/colors/colors.factor new file mode 100644 index 0000000000..77a1f46c87 --- /dev/null +++ b/basis/colors/colors.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2003, 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel combinators sequences arrays classes.tuple accessors colors.hsv ; + +IN: colors + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: color ; + +TUPLE: rgba < color red green blue alpha ; + +TUPLE: hsva < color hue saturation value alpha ; + +TUPLE: gray < color gray alpha ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: >rgba ( object -- rgba ) + +M: rgba >rgba ( rgba -- rgba ) ; + +M: hsva >rgba ( hsva -- rgba ) + { [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array + [ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ; + +M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ; + +M: color red>> ( color -- red ) >rgba red>> ; +M: color green>> ( color -- green ) >rgba green>> ; +M: color blue>> ( color -- blue ) >rgba blue>> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: black T{ rgba f 0.0 0.0 0.0 1.0 } ; +: blue T{ rgba f 0.0 0.0 1.0 1.0 } ; +: cyan T{ rgba f 0 0.941 0.941 1 } ; +: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; +: green T{ rgba f 0.0 1.0 0.0 1.0 } ; +: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; +: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; +: magenta T{ rgba f 0.941 0 0.941 1 } ; +: orange T{ rgba f 0.941 0.627 0 1 } ; +: purple T{ rgba f 0.627 0 0.941 1 } ; +: red T{ rgba f 1.0 0.0 0.0 1.0 } ; +: white T{ rgba f 1.0 1.0 1.0 1.0 } ; +: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; diff --git a/core/cpu/x86/intrinsics/authors.txt b/basis/colors/hsv/authors.txt similarity index 100% rename from core/cpu/x86/intrinsics/authors.txt rename to basis/colors/hsv/authors.txt diff --git a/extra/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor similarity index 100% rename from extra/colors/hsv/hsv.factor rename to basis/colors/hsv/hsv.factor diff --git a/extra/columns/authors.txt b/basis/columns/authors.txt similarity index 100% rename from extra/columns/authors.txt rename to basis/columns/authors.txt diff --git a/extra/columns/columns-docs.factor b/basis/columns/columns-docs.factor similarity index 68% rename from extra/columns/columns-docs.factor rename to basis/columns/columns-docs.factor index a2f0cccf3b..818ce2f752 100644 --- a/extra/columns/columns-docs.factor +++ b/basis/columns/columns-docs.factor @@ -4,14 +4,16 @@ IN: columns ARTICLE: "columns" "Column sequences" "A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:" { $subsection column } -{ $subsection } ; +{ $subsection } +"A utility word:" +{ $subsection } ; HELP: column { $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link } "." } ; HELP: ( seq n -- column ) { $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } } -{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } +{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of " { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } { $examples { $example "USING: arrays prettyprint columns ;" @@ -23,4 +25,9 @@ HELP: ( seq n -- column ) "In the same sense that " { $link } " is a virtual variant of " { $link reverse } ", " { $link } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "." } ; +HELP: +{ $values { "seq" sequence } { "seq'" sequence } } +{ $description "Outputs a new virtual sequence which presents the transpose of " { $snippet "seq" } "." } +{ $notes "This is the virtual sequence equivalent of " { $link flip } "." } ; + ABOUT: "columns" diff --git a/extra/columns/columns-tests.factor b/basis/columns/columns-tests.factor similarity index 100% rename from extra/columns/columns-tests.factor rename to basis/columns/columns-tests.factor diff --git a/extra/columns/columns.factor b/basis/columns/columns.factor similarity index 80% rename from extra/columns/columns.factor rename to basis/columns/columns.factor index 7e4a7fd408..5ac8531f58 100644 --- a/extra/columns/columns.factor +++ b/basis/columns/columns.factor @@ -13,3 +13,6 @@ M: column virtual@ dup col>> -rot seq>> nth bounds-check ; M: column length seq>> length ; INSTANCE: column virtual-sequence + +: ( seq -- seq' ) + dup empty? [ dup first length [ ] with map ] unless ; diff --git a/extra/columns/summary.txt b/basis/columns/summary.txt similarity index 100% rename from extra/columns/summary.txt rename to basis/columns/summary.txt diff --git a/extra/arrays/lib/tags.txt b/basis/columns/tags.txt similarity index 100% rename from extra/arrays/lib/tags.txt rename to basis/columns/tags.txt diff --git a/basis/combinators/short-circuit/short-circuit-tests.factor b/basis/combinators/short-circuit/short-circuit-tests.factor new file mode 100644 index 0000000000..e392d67d2a --- /dev/null +++ b/basis/combinators/short-circuit/short-circuit-tests.factor @@ -0,0 +1,32 @@ + +USING: kernel math tools.test combinators.short-circuit ; + +IN: combinators.short-circuit.tests + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: must-be-t ( in -- ) [ t ] swap unit-test ; +: must-be-f ( in -- ) [ f ] swap unit-test ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ { [ 1 ] [ 2 ] [ 3 ] } 0&& 3 = ] must-be-t +[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& 5 = ] must-be-t +[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t + +[ { [ 1 ] [ f ] [ 3 ] } 0&& 3 = ] must-be-f +[ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] must-be-f +[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t + +[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ] must-be-t + +[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ] must-be-t + +[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor new file mode 100755 index 0000000000..a484e09de1 --- /dev/null +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -0,0 +1,35 @@ + +USING: kernel combinators quotations arrays sequences assocs + locals generalizations macros fry ; + +IN: combinators.short-circuit + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: n&&-rewrite ( quots N -- quot ) + quots + [ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ] + map + [ t ] [ N nnip ] 2array suffix + '[ f , cond ] ; + +MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ; +MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ; +MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ; +MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: n||-rewrite ( quots N -- quot ) + quots + [ '[ drop N ndup @ dup ] [ N nnip ] 2array ] + map + [ drop N ndrop t ] [ f ] 2array suffix + '[ f , cond ] ; + +MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ; +MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ; +MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ; +MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/basis/combinators/short-circuit/smart/smart-tests.factor b/basis/combinators/short-circuit/smart/smart-tests.factor new file mode 100644 index 0000000000..7ec4a0e657 --- /dev/null +++ b/basis/combinators/short-circuit/smart/smart-tests.factor @@ -0,0 +1,32 @@ + +USING: kernel math tools.test combinators.short-circuit.smart ; + +IN: combinators.short-circuit.smart.tests + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: must-be-t ( in -- ) [ t ] swap unit-test ; +: must-be-f ( in -- ) [ f ] swap unit-test ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ { [ 1 ] [ 2 ] [ 3 ] } && 3 = ] must-be-t +[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } && 5 = ] must-be-t +[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } && 30 = ] must-be-t + +[ { [ 1 ] [ f ] [ 3 ] } && 3 = ] must-be-f +[ 3 { [ 0 > ] [ even? ] [ 2 + ] } && ] must-be-f +[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } && 30 = ] must-be-f + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ { [ 10 0 < ] [ f ] [ "factor" ] } || "factor" = ] must-be-t + +[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } || 11 = ] must-be-t + +[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } || 30 = ] must-be-t + +[ { [ 10 0 < ] [ f ] [ 0 1 = ] } || ] must-be-f + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/basis/combinators/short-circuit/smart/smart.factor b/basis/combinators/short-circuit/smart/smart.factor new file mode 100644 index 0000000000..ca659cacbe --- /dev/null +++ b/basis/combinators/short-circuit/smart/smart.factor @@ -0,0 +1,18 @@ + +USING: kernel sequences math stack-checker effects accessors macros + combinators.short-circuit ; + +IN: combinators.short-circuit.smart + +> [ "Cannot determine arity" throw ] when + effect-height neg 1+ ; + +PRIVATE> + +MACRO: && ( quots -- quot ) dup arity n&&-rewrite ; + +MACRO: || ( quots -- quot ) dup arity n||-rewrite ; diff --git a/core/cpu/x86/sse2/authors.txt b/basis/command-line/authors.txt similarity index 100% rename from core/cpu/x86/sse2/authors.txt rename to basis/command-line/authors.txt diff --git a/core/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor similarity index 98% rename from core/command-line/command-line-docs.factor rename to basis/command-line/command-line-docs.factor index 88ea43be20..440896deac 100644 --- a/core/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -52,9 +52,14 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage" { { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } } } ; -ARTICLE: "cli" "Command line usage" +ARTICLE: "rc-files" "Running code on startup" "Unless the " { $snippet "-no-user-init" } " command line switch is specified, The startup routine runs the " { $snippet ".factor-rc" } " file in the user's home directory, if it exists. This file can contain initialization and customization for your development environment." $nl +"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:" +{ $subsection run-user-init } +{ $subsection run-bootstrap-init } ; + +ARTICLE: "cli" "Command line usage" "Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "." $nl "Switches can take one of the following three forms:" @@ -68,9 +73,6 @@ $nl { $subsection "standard-cli-args" } "The list of command line arguments can be obtained and inspected directly:" { $subsection cli-args } -"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:" -{ $subsection run-user-init } -{ $subsection run-bootstrap-init } "There is a way to override the default vocabulary to run on startup:" { $subsection main-vocab-hook } ; diff --git a/core/command-line/command-line-tests.factor b/basis/command-line/command-line-tests.factor similarity index 100% rename from core/command-line/command-line-tests.factor rename to basis/command-line/command-line-tests.factor diff --git a/core/command-line/command-line.factor b/basis/command-line/command-line.factor similarity index 93% rename from core/command-line/command-line.factor rename to basis/command-line/command-line.factor index 84020abca0..37dbf9b7a6 100644 --- a/core/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init continuations debugger hashtables io kernel kernel.private namespaces parser sequences strings system -splitting io.files ; +splitting io.files eval ; IN: command-line : run-bootstrap-init ( -- ) @@ -36,7 +36,7 @@ SYMBOL: main-vocab-hook main-vocab-hook get [ call ] [ "listener" ] if* ] if ; -: default-cli-args +: default-cli-args ( -- ) global [ "quiet" off "script" off diff --git a/core/command-line/summary.txt b/basis/command-line/summary.txt similarity index 100% rename from core/command-line/summary.txt rename to basis/command-line/summary.txt diff --git a/core/debugger/authors.txt b/basis/compiler/authors.txt similarity index 100% rename from core/debugger/authors.txt rename to basis/compiler/authors.txt diff --git a/core/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor similarity index 93% rename from core/compiler/compiler-docs.factor rename to basis/compiler/compiler-docs.factor index 341d56f1d5..1f941a0f88 100755 --- a/core/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -1,4 +1,4 @@ -USING: generator help.markup help.syntax words io parser +USING: compiler.generator help.markup help.syntax words io parser assocs words.private sequences compiler.units ; IN: compiler @@ -26,7 +26,9 @@ ARTICLE: "compiler" "Optimizing compiler" } "The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "." { $subsection "compiler-usage" } -{ $subsection "compiler-errors" } ; +{ $subsection "compiler-errors" } +{ $subsection "hints" } +{ $subsection "generator" } ; ABOUT: "compiler" diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor new file mode 100755 index 0000000000..2dd6e440d5 --- /dev/null +++ b/basis/compiler/compiler.factor @@ -0,0 +1,90 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces arrays sequences io debugger words fry +compiler.units continuations vocabs assocs dlists definitions +math threads graphs generic combinators deques search-deques +stack-checker stack-checker.state compiler.generator +compiler.errors compiler.tree.builder compiler.tree.optimizer ; +IN: compiler + +SYMBOL: +failed+ + +: ripple-up ( words -- ) + dup "compiled-effect" word-prop +failed+ eq? + [ usage [ word? ] filter ] [ compiled-usage keys ] if + [ queue-compile ] each ; + +: ripple-up? ( word effect -- ? ) + #! If the word has previously been compiled and had a + #! different stack effect, we have to recompile any callers. + swap "compiled-effect" word-prop [ = not ] keep and ; + +: save-effect ( word effect -- ) + [ dupd ripple-up? [ ripple-up ] [ drop ] if ] + [ "compiled-effect" set-word-prop ] + 2bi ; + +: compile-begins ( word -- ) + f swap compiler-error ; + +: compile-failed ( word error -- ) + [ swap compiler-error ] + [ + drop + [ compiled-unxref ] + [ f swap compiled get set-at ] + [ +failed+ save-effect ] + tri + ] 2bi ; + +: compile-succeeded ( effect word -- ) + [ swap save-effect ] + [ compiled-unxref ] + [ + dup crossref? + [ + dependencies get >alist + generic-dependencies get >alist + compiled-xref + ] [ drop ] if + ] tri ; + +: (compile) ( word -- ) + '[ + H{ } clone dependencies set + H{ } clone generic-dependencies set + + , { + [ compile-begins ] + [ + [ build-tree-from-word ] [ compile-failed return ] recover + optimize-tree + ] + [ dup generate ] + [ compile-succeeded ] + } cleave + ] with-return ; + +: compile-loop ( deque -- ) + [ (compile) yield ] slurp-deque ; + +: decompile ( word -- ) + f 2array 1array t modify-code-heap ; + +: optimized-recompile-hook ( words -- alist ) + [ + compile-queue set + H{ } clone compiled set + [ queue-compile ] each + compile-queue get compile-loop + compiled get >alist + ] with-scope ; + +: enable-compiler ( -- ) + [ optimized-recompile-hook ] recompile-hook set-global ; + +: disable-compiler ( -- ) + [ default-recompile-hook ] recompile-hook set-global ; + +: recompile-all ( -- ) + forget-errors all-words compile ; diff --git a/core/float-arrays/authors.txt b/basis/compiler/constants/authors.txt similarity index 100% rename from core/float-arrays/authors.txt rename to basis/compiler/constants/authors.txt diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor new file mode 100755 index 0000000000..80f0b4f515 --- /dev/null +++ b/basis/compiler/constants/constants.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math kernel layouts system ; +IN: compiler.constants + +! These constants must match vm/memory.h +: card-bits 8 ; +: deck-bits 18 ; +: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; + +! These constants must match vm/layouts.h +: header-offset ( -- n ) object tag-number neg ; +: float-offset ( -- n ) 8 float tag-number - ; +: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; +: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; +: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; +: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; +: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; +: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; +: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; +: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; +: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; +: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; +: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; +: compiled-header-size ( -- n ) 4 bootstrap-cells ; diff --git a/core/compiler/constants/summary.txt b/basis/compiler/constants/summary.txt similarity index 100% rename from core/compiler/constants/summary.txt rename to basis/compiler/constants/summary.txt diff --git a/core/generator/authors.txt b/basis/compiler/generator/authors.txt similarity index 100% rename from core/generator/authors.txt rename to basis/compiler/generator/authors.txt diff --git a/core/generator/fixup/authors.txt b/basis/compiler/generator/fixup/authors.txt similarity index 100% rename from core/generator/fixup/authors.txt rename to basis/compiler/generator/fixup/authors.txt diff --git a/core/generator/fixup/fixup-docs.factor b/basis/compiler/generator/fixup/fixup-docs.factor similarity index 74% rename from core/generator/fixup/fixup-docs.factor rename to basis/compiler/generator/fixup/fixup-docs.factor index 64d733ef8c..a119d153e6 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/basis/compiler/generator/fixup/fixup-docs.factor @@ -1,6 +1,6 @@ USING: help.syntax help.markup math kernel -words strings alien ; -IN: generator.fixup +words strings alien compiler.generator ; +IN: compiler.generator.fixup HELP: frame-required { $values { "n" "a non-negative integer" } } @@ -14,3 +14,6 @@ HELP: rel-dlsym { $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } } { $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats." } ; + +HELP: literal-table +{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ; diff --git a/core/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor similarity index 91% rename from core/generator/fixup/fixup.factor rename to basis/compiler/generator/fixup/fixup.factor index a0961984ed..5a3337fb32 100755 --- a/core/generator/fixup/fixup.factor +++ b/basis/compiler/generator/fixup/fixup.factor @@ -3,9 +3,9 @@ USING: arrays byte-arrays generic assocs hashtables io.binary kernel kernel.private math namespaces sequences words quotations strings alien.accessors alien.strings layouts system -combinators math.bitfields words.private cpu.architecture +combinators math.bitwise words.private cpu.architecture math.order accessors growable ; -IN: generator.fixup +IN: compiler.generator.fixup : no-stack-frame -1 ; inline @@ -15,7 +15,7 @@ TUPLE: frame-required n ; : stack-frame-size ( code -- n ) no-stack-frame [ - dup frame-required? [ frame-required-n max ] [ drop ] if + dup frame-required? [ n>> max ] [ drop ] if ] reduce ; GENERIC: fixup* ( frame-size obj -- frame-size ) @@ -29,7 +29,7 @@ TUPLE: label offset ; :